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)
1163 e = gfc_copy_expr (p);
1164 e->ref = p->ref->next;
1165 p->ref->next = NULL;
1166 gfc_replace_expr (p, e);
1170 /* Pull an array section out of an array constructor. */
1173 find_array_section (gfc_expr *expr, gfc_ref *ref)
1179 long unsigned one = 1;
1181 mpz_t start[GFC_MAX_DIMENSIONS];
1182 mpz_t end[GFC_MAX_DIMENSIONS];
1183 mpz_t stride[GFC_MAX_DIMENSIONS];
1184 mpz_t delta[GFC_MAX_DIMENSIONS];
1185 mpz_t ctr[GFC_MAX_DIMENSIONS];
1191 gfc_constructor *cons;
1192 gfc_constructor *base;
1198 gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
1203 base = expr->value.constructor;
1204 expr->value.constructor = NULL;
1206 rank = ref->u.ar.as->rank;
1208 if (expr->shape == NULL)
1209 expr->shape = gfc_get_shape (rank);
1211 mpz_init_set_ui (delta_mpz, one);
1212 mpz_init_set_ui (nelts, one);
1215 /* Do the initialization now, so that we can cleanup without
1216 keeping track of where we were. */
1217 for (d = 0; d < rank; d++)
1219 mpz_init (delta[d]);
1220 mpz_init (start[d]);
1223 mpz_init (stride[d]);
1227 /* Build the counters to clock through the array reference. */
1229 for (d = 0; d < rank; d++)
1231 /* Make this stretch of code easier on the eye! */
1232 begin = ref->u.ar.start[d];
1233 finish = ref->u.ar.end[d];
1234 step = ref->u.ar.stride[d];
1235 lower = ref->u.ar.as->lower[d];
1236 upper = ref->u.ar.as->upper[d];
1238 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1242 if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1248 gcc_assert (begin->rank == 1);
1249 /* Zero-sized arrays have no shape and no elements, stop early. */
1252 mpz_init_set_ui (nelts, 0);
1256 vecsub[d] = begin->value.constructor;
1257 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1258 mpz_mul (nelts, nelts, begin->shape[0]);
1259 mpz_set (expr->shape[shape_i++], begin->shape[0]);
1262 for (c = vecsub[d]; c; c = c->next)
1264 if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
1265 || mpz_cmp (c->expr->value.integer,
1266 lower->value.integer) < 0)
1268 gfc_error ("index in dimension %d is out of bounds "
1269 "at %L", d + 1, &ref->u.ar.c_where[d]);
1277 if ((begin && begin->expr_type != EXPR_CONSTANT)
1278 || (finish && finish->expr_type != EXPR_CONSTANT)
1279 || (step && step->expr_type != EXPR_CONSTANT))
1285 /* Obtain the stride. */
1287 mpz_set (stride[d], step->value.integer);
1289 mpz_set_ui (stride[d], one);
1291 if (mpz_cmp_ui (stride[d], 0) == 0)
1292 mpz_set_ui (stride[d], one);
1294 /* Obtain the start value for the index. */
1296 mpz_set (start[d], begin->value.integer);
1298 mpz_set (start[d], lower->value.integer);
1300 mpz_set (ctr[d], start[d]);
1302 /* Obtain the end value for the index. */
1304 mpz_set (end[d], finish->value.integer);
1306 mpz_set (end[d], upper->value.integer);
1308 /* Separate 'if' because elements sometimes arrive with
1310 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1311 mpz_set (end [d], begin->value.integer);
1313 /* Check the bounds. */
1314 if (mpz_cmp (ctr[d], upper->value.integer) > 0
1315 || mpz_cmp (end[d], upper->value.integer) > 0
1316 || mpz_cmp (ctr[d], lower->value.integer) < 0
1317 || mpz_cmp (end[d], lower->value.integer) < 0)
1319 gfc_error ("index in dimension %d is out of bounds "
1320 "at %L", d + 1, &ref->u.ar.c_where[d]);
1325 /* Calculate the number of elements and the shape. */
1326 mpz_set (tmp_mpz, stride[d]);
1327 mpz_add (tmp_mpz, end[d], tmp_mpz);
1328 mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1329 mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1330 mpz_mul (nelts, nelts, tmp_mpz);
1332 /* An element reference reduces the rank of the expression; don't
1333 add anything to the shape array. */
1334 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1335 mpz_set (expr->shape[shape_i++], tmp_mpz);
1338 /* Calculate the 'stride' (=delta) for conversion of the
1339 counter values into the index along the constructor. */
1340 mpz_set (delta[d], delta_mpz);
1341 mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1342 mpz_add_ui (tmp_mpz, tmp_mpz, one);
1343 mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1350 /* Now clock through the array reference, calculating the index in
1351 the source constructor and transferring the elements to the new
1353 for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1355 if (ref->u.ar.offset)
1356 mpz_set (ptr, ref->u.ar.offset->value.integer);
1358 mpz_init_set_ui (ptr, 0);
1361 for (d = 0; d < rank; d++)
1363 mpz_set (tmp_mpz, ctr[d]);
1364 mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1365 mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1366 mpz_add (ptr, ptr, tmp_mpz);
1368 if (!incr_ctr) continue;
1370 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1372 gcc_assert(vecsub[d]);
1374 if (!vecsub[d]->next)
1375 vecsub[d] = ref->u.ar.start[d]->value.constructor;
1378 vecsub[d] = vecsub[d]->next;
1381 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1385 mpz_add (ctr[d], ctr[d], stride[d]);
1387 if (mpz_cmp_ui (stride[d], 0) > 0
1388 ? mpz_cmp (ctr[d], end[d]) > 0
1389 : mpz_cmp (ctr[d], end[d]) < 0)
1390 mpz_set (ctr[d], start[d]);
1396 /* There must be a better way of dealing with negative strides
1397 than resetting the index and the constructor pointer! */
1398 if (mpz_cmp (ptr, index) < 0)
1400 mpz_set_ui (index, 0);
1404 while (cons && cons->next && mpz_cmp (ptr, index) > 0)
1406 mpz_add_ui (index, index, one);
1410 gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
1418 mpz_clear (delta_mpz);
1419 mpz_clear (tmp_mpz);
1421 for (d = 0; d < rank; d++)
1423 mpz_clear (delta[d]);
1424 mpz_clear (start[d]);
1427 mpz_clear (stride[d]);
1429 gfc_free_constructor (base);
1433 /* Pull a substring out of an expression. */
1436 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1443 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1444 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1447 *newp = gfc_copy_expr (p);
1448 gfc_free ((*newp)->value.character.string);
1450 end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1451 start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1452 length = end - start + 1;
1454 chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1455 (*newp)->value.character.length = length;
1456 memcpy (chr, &p->value.character.string[start - 1],
1457 length * sizeof (gfc_char_t));
1464 /* Simplify a subobject reference of a constructor. This occurs when
1465 parameter variable values are substituted. */
1468 simplify_const_ref (gfc_expr *p)
1470 gfc_constructor *cons;
1476 switch (p->ref->type)
1479 switch (p->ref->u.ar.type)
1482 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1483 will generate this. */
1484 if (p->expr_type != EXPR_ARRAY)
1486 remove_subobject_ref (p, NULL);
1489 if (find_array_element (p->value.constructor, &p->ref->u.ar,
1496 remove_subobject_ref (p, cons);
1500 if (find_array_section (p, p->ref) == FAILURE)
1502 p->ref->u.ar.type = AR_FULL;
1507 if (p->ref->next != NULL
1508 && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1510 cons = p->value.constructor;
1511 for (; cons; cons = cons->next)
1513 cons->expr->ref = gfc_copy_ref (p->ref->next);
1514 if (simplify_const_ref (cons->expr) == FAILURE)
1518 if (p->ts.type == BT_DERIVED
1520 && p->value.constructor)
1522 /* There may have been component references. */
1523 p->ts = p->value.constructor->expr->ts;
1527 for (; last_ref->next; last_ref = last_ref->next) {};
1529 if (p->ts.type == BT_CHARACTER
1530 && last_ref->type == REF_SUBSTRING)
1532 /* If this is a CHARACTER array and we possibly took
1533 a substring out of it, update the type-spec's
1534 character length according to the first element
1535 (as all should have the same length). */
1537 if (p->value.constructor)
1539 const gfc_expr* first = p->value.constructor->expr;
1540 gcc_assert (first->expr_type == EXPR_CONSTANT);
1541 gcc_assert (first->ts.type == BT_CHARACTER);
1542 string_len = first->value.character.length;
1548 p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
1551 gfc_free_expr (p->ts.u.cl->length);
1553 p->ts.u.cl->length = gfc_int_expr (string_len);
1556 gfc_free_ref_list (p->ref);
1567 cons = find_component_ref (p->value.constructor, p->ref);
1568 remove_subobject_ref (p, cons);
1572 if (find_substring_ref (p, &newp) == FAILURE)
1575 gfc_replace_expr (p, newp);
1576 gfc_free_ref_list (p->ref);
1586 /* Simplify a chain of references. */
1589 simplify_ref_chain (gfc_ref *ref, int type)
1593 for (; ref; ref = ref->next)
1598 for (n = 0; n < ref->u.ar.dimen; n++)
1600 if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1602 if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1604 if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1610 if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1612 if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1624 /* Try to substitute the value of a parameter variable. */
1627 simplify_parameter_variable (gfc_expr *p, int type)
1632 e = gfc_copy_expr (p->symtree->n.sym->value);
1638 /* Do not copy subobject refs for constant. */
1639 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1640 e->ref = gfc_copy_ref (p->ref);
1641 t = gfc_simplify_expr (e, type);
1643 /* Only use the simplification if it eliminated all subobject references. */
1644 if (t == SUCCESS && !e->ref)
1645 gfc_replace_expr (p, e);
1652 /* Given an expression, simplify it by collapsing constant
1653 expressions. Most simplification takes place when the expression
1654 tree is being constructed. If an intrinsic function is simplified
1655 at some point, we get called again to collapse the result against
1658 We work by recursively simplifying expression nodes, simplifying
1659 intrinsic functions where possible, which can lead to further
1660 constant collapsing. If an operator has constant operand(s), we
1661 rip the expression apart, and rebuild it, hoping that it becomes
1664 The expression type is defined for:
1665 0 Basic expression parsing
1666 1 Simplifying array constructors -- will substitute
1668 Returns FAILURE on error, SUCCESS otherwise.
1669 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1672 gfc_simplify_expr (gfc_expr *p, int type)
1674 gfc_actual_arglist *ap;
1679 switch (p->expr_type)
1686 for (ap = p->value.function.actual; ap; ap = ap->next)
1687 if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1690 if (p->value.function.isym != NULL
1691 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1696 case EXPR_SUBSTRING:
1697 if (simplify_ref_chain (p->ref, type) == FAILURE)
1700 if (gfc_is_constant_expr (p))
1706 if (p->ref && p->ref->u.ss.start)
1708 gfc_extract_int (p->ref->u.ss.start, &start);
1709 start--; /* Convert from one-based to zero-based. */
1712 end = p->value.character.length;
1713 if (p->ref && p->ref->u.ss.end)
1714 gfc_extract_int (p->ref->u.ss.end, &end);
1716 s = gfc_get_wide_string (end - start + 2);
1717 memcpy (s, p->value.character.string + start,
1718 (end - start) * sizeof (gfc_char_t));
1719 s[end - start + 1] = '\0'; /* TODO: C-style string. */
1720 gfc_free (p->value.character.string);
1721 p->value.character.string = s;
1722 p->value.character.length = end - start;
1723 p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1724 p->ts.u.cl->length = gfc_int_expr (p->value.character.length);
1725 gfc_free_ref_list (p->ref);
1727 p->expr_type = EXPR_CONSTANT;
1732 if (simplify_intrinsic_op (p, type) == FAILURE)
1737 /* Only substitute array parameter variables if we are in an
1738 initialization expression, or we want a subsection. */
1739 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1740 && (gfc_init_expr || p->ref
1741 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1743 if (simplify_parameter_variable (p, type) == FAILURE)
1750 gfc_simplify_iterator_var (p);
1753 /* Simplify subcomponent references. */
1754 if (simplify_ref_chain (p->ref, type) == FAILURE)
1759 case EXPR_STRUCTURE:
1761 if (simplify_ref_chain (p->ref, type) == FAILURE)
1764 if (simplify_constructor (p->value.constructor, type) == FAILURE)
1767 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1768 && p->ref->u.ar.type == AR_FULL)
1769 gfc_expand_constructor (p);
1771 if (simplify_const_ref (p) == FAILURE)
1786 /* Returns the type of an expression with the exception that iterator
1787 variables are automatically integers no matter what else they may
1793 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1800 /* Check an intrinsic arithmetic operation to see if it is consistent
1801 with some type of expression. */
1803 static gfc_try check_init_expr (gfc_expr *);
1806 /* Scalarize an expression for an elemental intrinsic call. */
1809 scalarize_intrinsic_call (gfc_expr *e)
1811 gfc_actual_arglist *a, *b;
1812 gfc_constructor *args[5], *ctor, *new_ctor;
1813 gfc_expr *expr, *old;
1814 int n, i, rank[5], array_arg;
1816 /* Find which, if any, arguments are arrays. Assume that the old
1817 expression carries the type information and that the first arg
1818 that is an array expression carries all the shape information.*/
1820 a = e->value.function.actual;
1821 for (; a; a = a->next)
1824 if (a->expr->expr_type != EXPR_ARRAY)
1827 expr = gfc_copy_expr (a->expr);
1834 old = gfc_copy_expr (e);
1836 gfc_free_constructor (expr->value.constructor);
1837 expr->value.constructor = NULL;
1840 expr->where = old->where;
1841 expr->expr_type = EXPR_ARRAY;
1843 /* Copy the array argument constructors into an array, with nulls
1846 a = old->value.function.actual;
1847 for (; a; a = a->next)
1849 /* Check that this is OK for an initialization expression. */
1850 if (a->expr && check_init_expr (a->expr) == FAILURE)
1854 if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
1856 rank[n] = a->expr->rank;
1857 ctor = a->expr->symtree->n.sym->value->value.constructor;
1858 args[n] = gfc_copy_constructor (ctor);
1860 else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
1863 rank[n] = a->expr->rank;
1866 args[n] = gfc_copy_constructor (a->expr->value.constructor);
1874 /* Using the array argument as the master, step through the array
1875 calling the function for each element and advancing the array
1876 constructors together. */
1877 ctor = args[array_arg - 1];
1879 for (; ctor; ctor = ctor->next)
1881 if (expr->value.constructor == NULL)
1882 expr->value.constructor
1883 = new_ctor = gfc_get_constructor ();
1886 new_ctor->next = gfc_get_constructor ();
1887 new_ctor = new_ctor->next;
1889 new_ctor->expr = gfc_copy_expr (old);
1890 gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
1892 b = old->value.function.actual;
1893 for (i = 0; i < n; i++)
1896 new_ctor->expr->value.function.actual
1897 = a = gfc_get_actual_arglist ();
1900 a->next = gfc_get_actual_arglist ();
1904 a->expr = gfc_copy_expr (args[i]->expr);
1906 a->expr = gfc_copy_expr (b->expr);
1911 /* Simplify the function calls. If the simplification fails, the
1912 error will be flagged up down-stream or the library will deal
1914 gfc_simplify_expr (new_ctor->expr, 0);
1916 for (i = 0; i < n; i++)
1918 args[i] = args[i]->next;
1920 for (i = 1; i < n; i++)
1921 if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
1922 || (args[i] == NULL && args[array_arg - 1] != NULL)))
1928 gfc_free_expr (old);
1932 gfc_error_now ("elemental function arguments at %C are not compliant");
1935 gfc_free_expr (expr);
1936 gfc_free_expr (old);
1942 check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
1944 gfc_expr *op1 = e->value.op.op1;
1945 gfc_expr *op2 = e->value.op.op2;
1947 if ((*check_function) (op1) == FAILURE)
1950 switch (e->value.op.op)
1952 case INTRINSIC_UPLUS:
1953 case INTRINSIC_UMINUS:
1954 if (!numeric_type (et0 (op1)))
1959 case INTRINSIC_EQ_OS:
1961 case INTRINSIC_NE_OS:
1963 case INTRINSIC_GT_OS:
1965 case INTRINSIC_GE_OS:
1967 case INTRINSIC_LT_OS:
1969 case INTRINSIC_LE_OS:
1970 if ((*check_function) (op2) == FAILURE)
1973 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1974 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1976 gfc_error ("Numeric or CHARACTER operands are required in "
1977 "expression at %L", &e->where);
1982 case INTRINSIC_PLUS:
1983 case INTRINSIC_MINUS:
1984 case INTRINSIC_TIMES:
1985 case INTRINSIC_DIVIDE:
1986 case INTRINSIC_POWER:
1987 if ((*check_function) (op2) == FAILURE)
1990 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1995 case INTRINSIC_CONCAT:
1996 if ((*check_function) (op2) == FAILURE)
1999 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
2001 gfc_error ("Concatenation operator in expression at %L "
2002 "must have two CHARACTER operands", &op1->where);
2006 if (op1->ts.kind != op2->ts.kind)
2008 gfc_error ("Concat operator at %L must concatenate strings of the "
2009 "same kind", &e->where);
2016 if (et0 (op1) != BT_LOGICAL)
2018 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2019 "operand", &op1->where);
2028 case INTRINSIC_NEQV:
2029 if ((*check_function) (op2) == FAILURE)
2032 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
2034 gfc_error ("LOGICAL operands are required in expression at %L",
2041 case INTRINSIC_PARENTHESES:
2045 gfc_error ("Only intrinsic operators can be used in expression at %L",
2053 gfc_error ("Numeric operands are required in expression at %L", &e->where);
2058 /* F2003, 7.1.7 (3): In init expression, allocatable components
2059 must not be data-initialized. */
2061 check_alloc_comp_init (gfc_expr *e)
2064 gfc_constructor *ctor;
2066 gcc_assert (e->expr_type == EXPR_STRUCTURE);
2067 gcc_assert (e->ts.type == BT_DERIVED);
2069 for (c = e->ts.u.derived->components, ctor = e->value.constructor;
2070 c; c = c->next, ctor = ctor->next)
2072 if (c->attr.allocatable
2073 && ctor->expr->expr_type != EXPR_NULL)
2075 gfc_error("Invalid initialization expression for ALLOCATABLE "
2076 "component '%s' in structure constructor at %L",
2077 c->name, &ctor->expr->where);
2086 check_init_expr_arguments (gfc_expr *e)
2088 gfc_actual_arglist *ap;
2090 for (ap = e->value.function.actual; ap; ap = ap->next)
2091 if (check_init_expr (ap->expr) == FAILURE)
2097 static gfc_try check_restricted (gfc_expr *);
2099 /* F95, 7.1.6.1, Initialization expressions, (7)
2100 F2003, 7.1.7 Initialization expression, (8) */
2103 check_inquiry (gfc_expr *e, int not_restricted)
2106 const char *const *functions;
2108 static const char *const inquiry_func_f95[] = {
2109 "lbound", "shape", "size", "ubound",
2110 "bit_size", "len", "kind",
2111 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2112 "precision", "radix", "range", "tiny",
2116 static const char *const inquiry_func_f2003[] = {
2117 "lbound", "shape", "size", "ubound",
2118 "bit_size", "len", "kind",
2119 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2120 "precision", "radix", "range", "tiny",
2125 gfc_actual_arglist *ap;
2127 if (!e->value.function.isym
2128 || !e->value.function.isym->inquiry)
2131 /* An undeclared parameter will get us here (PR25018). */
2132 if (e->symtree == NULL)
2135 name = e->symtree->n.sym->name;
2137 functions = (gfc_option.warn_std & GFC_STD_F2003)
2138 ? inquiry_func_f2003 : inquiry_func_f95;
2140 for (i = 0; functions[i]; i++)
2141 if (strcmp (functions[i], name) == 0)
2144 if (functions[i] == NULL)
2147 /* At this point we have an inquiry function with a variable argument. The
2148 type of the variable might be undefined, but we need it now, because the
2149 arguments of these functions are not allowed to be undefined. */
2151 for (ap = e->value.function.actual; ap; ap = ap->next)
2156 if (ap->expr->ts.type == BT_UNKNOWN)
2158 if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2159 && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)
2163 ap->expr->ts = ap->expr->symtree->n.sym->ts;
2166 /* Assumed character length will not reduce to a constant expression
2167 with LEN, as required by the standard. */
2168 if (i == 5 && not_restricted
2169 && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2170 && ap->expr->symtree->n.sym->ts.u.cl->length == NULL)
2172 gfc_error ("Assumed character length variable '%s' in constant "
2173 "expression at %L", e->symtree->n.sym->name, &e->where);
2176 else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
2179 if (not_restricted == 0
2180 && ap->expr->expr_type != EXPR_VARIABLE
2181 && check_restricted (ap->expr) == FAILURE)
2189 /* F95, 7.1.6.1, Initialization expressions, (5)
2190 F2003, 7.1.7 Initialization expression, (5) */
2193 check_transformational (gfc_expr *e)
2195 static const char * const trans_func_f95[] = {
2196 "repeat", "reshape", "selected_int_kind",
2197 "selected_real_kind", "transfer", "trim", NULL
2200 static const char * const trans_func_f2003[] = {
2201 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2202 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2203 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2204 "trim", "unpack", NULL
2209 const char *const *functions;
2211 if (!e->value.function.isym
2212 || !e->value.function.isym->transformational)
2215 name = e->symtree->n.sym->name;
2217 functions = (gfc_option.allow_std & GFC_STD_F2003)
2218 ? trans_func_f2003 : trans_func_f95;
2220 /* NULL() is dealt with below. */
2221 if (strcmp ("null", name) == 0)
2224 for (i = 0; functions[i]; i++)
2225 if (strcmp (functions[i], name) == 0)
2228 if (functions[i] == NULL)
2230 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2231 "in an initialization expression", name, &e->where);
2235 return check_init_expr_arguments (e);
2239 /* F95, 7.1.6.1, Initialization expressions, (6)
2240 F2003, 7.1.7 Initialization expression, (6) */
2243 check_null (gfc_expr *e)
2245 if (strcmp ("null", e->symtree->n.sym->name) != 0)
2248 return check_init_expr_arguments (e);
2253 check_elemental (gfc_expr *e)
2255 if (!e->value.function.isym
2256 || !e->value.function.isym->elemental)
2259 if (e->ts.type != BT_INTEGER
2260 && e->ts.type != BT_CHARACTER
2261 && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2262 "nonstandard initialization expression at %L",
2263 &e->where) == FAILURE)
2266 return check_init_expr_arguments (e);
2271 check_conversion (gfc_expr *e)
2273 if (!e->value.function.isym
2274 || !e->value.function.isym->conversion)
2277 return check_init_expr_arguments (e);
2281 /* Verify that an expression is an initialization expression. A side
2282 effect is that the expression tree is reduced to a single constant
2283 node if all goes well. This would normally happen when the
2284 expression is constructed but function references are assumed to be
2285 intrinsics in the context of initialization expressions. If
2286 FAILURE is returned an error message has been generated. */
2289 check_init_expr (gfc_expr *e)
2297 switch (e->expr_type)
2300 t = check_intrinsic_op (e, check_init_expr);
2302 t = gfc_simplify_expr (e, 0);
2310 gfc_intrinsic_sym* isym;
2313 sym = e->symtree->n.sym;
2314 if (!gfc_is_intrinsic (sym, 0, e->where)
2315 || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2317 gfc_error ("Function '%s' in initialization expression at %L "
2318 "must be an intrinsic function",
2319 e->symtree->n.sym->name, &e->where);
2323 if ((m = check_conversion (e)) == MATCH_NO
2324 && (m = check_inquiry (e, 1)) == MATCH_NO
2325 && (m = check_null (e)) == MATCH_NO
2326 && (m = check_transformational (e)) == MATCH_NO
2327 && (m = check_elemental (e)) == MATCH_NO)
2329 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2330 "in an initialization expression",
2331 e->symtree->n.sym->name, &e->where);
2335 /* Try to scalarize an elemental intrinsic function that has an
2337 isym = gfc_find_function (e->symtree->n.sym->name);
2338 if (isym && isym->elemental
2339 && (t = scalarize_intrinsic_call (e)) == SUCCESS)
2344 t = gfc_simplify_expr (e, 0);
2351 if (gfc_check_iter_variable (e) == SUCCESS)
2354 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2356 /* A PARAMETER shall not be used to define itself, i.e.
2357 REAL, PARAMETER :: x = transfer(0, x)
2359 if (!e->symtree->n.sym->value)
2361 gfc_error("PARAMETER '%s' is used at %L before its definition "
2362 "is complete", e->symtree->n.sym->name, &e->where);
2366 t = simplify_parameter_variable (e, 0);
2371 if (gfc_in_match_data ())
2376 if (e->symtree->n.sym->as)
2378 switch (e->symtree->n.sym->as->type)
2380 case AS_ASSUMED_SIZE:
2381 gfc_error ("Assumed size array '%s' at %L is not permitted "
2382 "in an initialization expression",
2383 e->symtree->n.sym->name, &e->where);
2386 case AS_ASSUMED_SHAPE:
2387 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2388 "in an initialization expression",
2389 e->symtree->n.sym->name, &e->where);
2393 gfc_error ("Deferred array '%s' at %L is not permitted "
2394 "in an initialization expression",
2395 e->symtree->n.sym->name, &e->where);
2399 gfc_error ("Array '%s' at %L is a variable, which does "
2400 "not reduce to a constant expression",
2401 e->symtree->n.sym->name, &e->where);
2409 gfc_error ("Parameter '%s' at %L has not been declared or is "
2410 "a variable, which does not reduce to a constant "
2411 "expression", e->symtree->n.sym->name, &e->where);
2420 case EXPR_SUBSTRING:
2421 t = check_init_expr (e->ref->u.ss.start);
2425 t = check_init_expr (e->ref->u.ss.end);
2427 t = gfc_simplify_expr (e, 0);
2431 case EXPR_STRUCTURE:
2432 t = e->ts.is_iso_c ? SUCCESS : FAILURE;
2436 t = check_alloc_comp_init (e);
2440 t = gfc_check_constructor (e, check_init_expr);
2447 t = gfc_check_constructor (e, check_init_expr);
2451 t = gfc_expand_constructor (e);
2455 t = gfc_check_constructor_type (e);
2459 gfc_internal_error ("check_init_expr(): Unknown expression type");
2465 /* Reduces a general expression to an initialization expression (a constant).
2466 This used to be part of gfc_match_init_expr.
2467 Note that this function doesn't free the given expression on FAILURE. */
2470 gfc_reduce_init_expr (gfc_expr *expr)
2475 t = gfc_resolve_expr (expr);
2477 t = check_init_expr (expr);
2483 if (expr->expr_type == EXPR_ARRAY)
2485 if (gfc_check_constructor_type (expr) == FAILURE)
2487 if (gfc_expand_constructor (expr) == FAILURE)
2495 /* Match an initialization expression. We work by first matching an
2496 expression, then reducing it to a constant. The reducing it to
2497 constant part requires a global variable to flag the prohibition
2498 of a non-integer exponent in -std=f95 mode. */
2500 bool init_flag = false;
2503 gfc_match_init_expr (gfc_expr **result)
2513 m = gfc_match_expr (&expr);
2520 t = gfc_reduce_init_expr (expr);
2523 gfc_free_expr (expr);
2535 /* Given an actual argument list, test to see that each argument is a
2536 restricted expression and optionally if the expression type is
2537 integer or character. */
2540 restricted_args (gfc_actual_arglist *a)
2542 for (; a; a = a->next)
2544 if (check_restricted (a->expr) == FAILURE)
2552 /************* Restricted/specification expressions *************/
2555 /* Make sure a non-intrinsic function is a specification function. */
2558 external_spec_function (gfc_expr *e)
2562 f = e->value.function.esym;
2564 if (f->attr.proc == PROC_ST_FUNCTION)
2566 gfc_error ("Specification function '%s' at %L cannot be a statement "
2567 "function", f->name, &e->where);
2571 if (f->attr.proc == PROC_INTERNAL)
2573 gfc_error ("Specification function '%s' at %L cannot be an internal "
2574 "function", f->name, &e->where);
2578 if (!f->attr.pure && !f->attr.elemental)
2580 gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2585 if (f->attr.recursive)
2587 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2588 f->name, &e->where);
2592 return restricted_args (e->value.function.actual);
2596 /* Check to see that a function reference to an intrinsic is a
2597 restricted expression. */
2600 restricted_intrinsic (gfc_expr *e)
2602 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2603 if (check_inquiry (e, 0) == MATCH_YES)
2606 return restricted_args (e->value.function.actual);
2610 /* Check the expressions of an actual arglist. Used by check_restricted. */
2613 check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
2615 for (; arg; arg = arg->next)
2616 if (checker (arg->expr) == FAILURE)
2623 /* Check the subscription expressions of a reference chain with a checking
2624 function; used by check_restricted. */
2627 check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
2637 for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2639 if (checker (ref->u.ar.start[dim]) == FAILURE)
2641 if (checker (ref->u.ar.end[dim]) == FAILURE)
2643 if (checker (ref->u.ar.stride[dim]) == FAILURE)
2649 /* Nothing needed, just proceed to next reference. */
2653 if (checker (ref->u.ss.start) == FAILURE)
2655 if (checker (ref->u.ss.end) == FAILURE)
2664 return check_references (ref->next, checker);
2668 /* Verify that an expression is a restricted expression. Like its
2669 cousin check_init_expr(), an error message is generated if we
2673 check_restricted (gfc_expr *e)
2681 switch (e->expr_type)
2684 t = check_intrinsic_op (e, check_restricted);
2686 t = gfc_simplify_expr (e, 0);
2691 if (e->value.function.esym)
2693 t = check_arglist (e->value.function.actual, &check_restricted);
2695 t = external_spec_function (e);
2699 if (e->value.function.isym && e->value.function.isym->inquiry)
2702 t = check_arglist (e->value.function.actual, &check_restricted);
2705 t = restricted_intrinsic (e);
2710 sym = e->symtree->n.sym;
2713 /* If a dummy argument appears in a context that is valid for a
2714 restricted expression in an elemental procedure, it will have
2715 already been simplified away once we get here. Therefore we
2716 don't need to jump through hoops to distinguish valid from
2718 if (sym->attr.dummy && sym->ns == gfc_current_ns
2719 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2721 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2722 sym->name, &e->where);
2726 if (sym->attr.optional)
2728 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2729 sym->name, &e->where);
2733 if (sym->attr.intent == INTENT_OUT)
2735 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2736 sym->name, &e->where);
2740 /* Check reference chain if any. */
2741 if (check_references (e->ref, &check_restricted) == FAILURE)
2744 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2745 processed in resolve.c(resolve_formal_arglist). This is done so
2746 that host associated dummy array indices are accepted (PR23446).
2747 This mechanism also does the same for the specification expressions
2748 of array-valued functions. */
2750 || sym->attr.in_common
2751 || sym->attr.use_assoc
2753 || sym->attr.implied_index
2754 || sym->attr.flavor == FL_PARAMETER
2755 || (sym->ns && sym->ns == gfc_current_ns->parent)
2756 || (sym->ns && gfc_current_ns->parent
2757 && sym->ns == gfc_current_ns->parent->parent)
2758 || (sym->ns->proc_name != NULL
2759 && sym->ns->proc_name->attr.flavor == FL_MODULE)
2760 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2766 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2767 sym->name, &e->where);
2768 /* Prevent a repetition of the error. */
2777 case EXPR_SUBSTRING:
2778 t = gfc_specification_expr (e->ref->u.ss.start);
2782 t = gfc_specification_expr (e->ref->u.ss.end);
2784 t = gfc_simplify_expr (e, 0);
2788 case EXPR_STRUCTURE:
2789 t = gfc_check_constructor (e, check_restricted);
2793 t = gfc_check_constructor (e, check_restricted);
2797 gfc_internal_error ("check_restricted(): Unknown expression type");
2804 /* Check to see that an expression is a specification expression. If
2805 we return FAILURE, an error has been generated. */
2808 gfc_specification_expr (gfc_expr *e)
2814 if (e->ts.type != BT_INTEGER)
2816 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2817 &e->where, gfc_basic_typename (e->ts.type));
2821 if (e->expr_type == EXPR_FUNCTION
2822 && !e->value.function.isym
2823 && !e->value.function.esym
2824 && !gfc_pure (e->symtree->n.sym))
2826 gfc_error ("Function '%s' at %L must be PURE",
2827 e->symtree->n.sym->name, &e->where);
2828 /* Prevent repeat error messages. */
2829 e->symtree->n.sym->attr.pure = 1;
2835 gfc_error ("Expression at %L must be scalar", &e->where);
2839 if (gfc_simplify_expr (e, 0) == FAILURE)
2842 return check_restricted (e);
2846 /************** Expression conformance checks. *************/
2848 /* Given two expressions, make sure that the arrays are conformable. */
2851 gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
2853 int op1_flag, op2_flag, d;
2854 mpz_t op1_size, op2_size;
2860 if (op1->rank == 0 || op2->rank == 0)
2863 va_start (argp, optype_msgid);
2864 vsnprintf (buffer, 240, optype_msgid, argp);
2867 if (op1->rank != op2->rank)
2869 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
2870 op1->rank, op2->rank, &op1->where);
2876 for (d = 0; d < op1->rank; d++)
2878 op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
2879 op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
2881 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
2883 gfc_error ("Different shape for %s at %L on dimension %d "
2884 "(%d and %d)", _(buffer), &op1->where, d + 1,
2885 (int) mpz_get_si (op1_size),
2886 (int) mpz_get_si (op2_size));
2892 mpz_clear (op1_size);
2894 mpz_clear (op2_size);
2904 /* Given an assignable expression and an arbitrary expression, make
2905 sure that the assignment can take place. */
2908 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
2914 sym = lvalue->symtree->n.sym;
2916 /* Check INTENT(IN), unless the object itself is the component or
2917 sub-component of a pointer. */
2918 has_pointer = sym->attr.pointer;
2920 for (ref = lvalue->ref; ref; ref = ref->next)
2921 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
2927 if (!has_pointer && sym->attr.intent == INTENT_IN)
2929 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2930 sym->name, &lvalue->where);
2934 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2935 variable local to a function subprogram. Its existence begins when
2936 execution of the function is initiated and ends when execution of the
2937 function is terminated...
2938 Therefore, the left hand side is no longer a variable, when it is: */
2939 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
2940 && !sym->attr.external)
2945 /* (i) Use associated; */
2946 if (sym->attr.use_assoc)
2949 /* (ii) The assignment is in the main program; or */
2950 if (gfc_current_ns->proc_name->attr.is_main_program)
2953 /* (iii) A module or internal procedure... */
2954 if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
2955 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
2956 && gfc_current_ns->parent
2957 && (!(gfc_current_ns->parent->proc_name->attr.function
2958 || gfc_current_ns->parent->proc_name->attr.subroutine)
2959 || gfc_current_ns->parent->proc_name->attr.is_main_program))
2961 /* ... that is not a function... */
2962 if (!gfc_current_ns->proc_name->attr.function)
2965 /* ... or is not an entry and has a different name. */
2966 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
2970 /* (iv) Host associated and not the function symbol or the
2971 parent result. This picks up sibling references, which
2972 cannot be entries. */
2973 if (!sym->attr.entry
2974 && sym->ns == gfc_current_ns->parent
2975 && sym != gfc_current_ns->proc_name
2976 && sym != gfc_current_ns->parent->proc_name->result)
2981 gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
2986 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
2988 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2989 lvalue->rank, rvalue->rank, &lvalue->where);
2993 if (lvalue->ts.type == BT_UNKNOWN)
2995 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3000 if (rvalue->expr_type == EXPR_NULL)
3002 if (has_pointer && (ref == NULL || ref->next == NULL)
3003 && lvalue->symtree->n.sym->attr.data)
3007 gfc_error ("NULL appears on right-hand side in assignment at %L",
3013 /* This is possibly a typo: x = f() instead of x => f(). */
3014 if (gfc_option.warn_surprising
3015 && rvalue->expr_type == EXPR_FUNCTION
3016 && rvalue->symtree->n.sym->attr.pointer)
3017 gfc_warning ("POINTER valued function appears on right-hand side of "
3018 "assignment at %L", &rvalue->where);
3020 /* Check size of array assignments. */
3021 if (lvalue->rank != 0 && rvalue->rank != 0
3022 && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
3025 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
3026 && lvalue->symtree->n.sym->attr.data
3027 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
3028 "initialize non-integer variable '%s'",
3029 &rvalue->where, lvalue->symtree->n.sym->name)
3032 else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
3033 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
3034 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3035 &rvalue->where) == FAILURE)
3038 /* Handle the case of a BOZ literal on the RHS. */
3039 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
3042 if (gfc_option.warn_surprising)
3043 gfc_warning ("BOZ literal at %L is bitwise transferred "
3044 "non-integer symbol '%s'", &rvalue->where,
3045 lvalue->symtree->n.sym->name);
3046 if (!gfc_convert_boz (rvalue, &lvalue->ts))
3048 if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
3050 if (rc == ARITH_UNDERFLOW)
3051 gfc_error ("Arithmetic underflow 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_OVERFLOW)
3055 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3056 ". This check can be disabled with the option "
3057 "-fno-range-check", &rvalue->where);
3058 else if (rc == ARITH_NAN)
3059 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3060 ". This check can be disabled with the option "
3061 "-fno-range-check", &rvalue->where);
3066 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
3069 /* Only DATA Statements come here. */
3072 /* Numeric can be converted to any other numeric. And Hollerith can be
3073 converted to any other type. */
3074 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3075 || rvalue->ts.type == BT_HOLLERITH)
3078 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3081 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3082 "conversion of %s to %s", &lvalue->where,
3083 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3088 /* Assignment is the only case where character variables of different
3089 kind values can be converted into one another. */
3090 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3092 if (lvalue->ts.kind != rvalue->ts.kind)
3093 gfc_convert_chartype (rvalue, &lvalue->ts);
3098 return gfc_convert_type (rvalue, &lvalue->ts, 1);
3102 /* Check that a pointer assignment is OK. We first check lvalue, and
3103 we only check rvalue if it's not an assignment to NULL() or a
3104 NULLIFY statement. */
3107 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3109 symbol_attribute attr;
3112 int pointer, check_intent_in, proc_pointer;
3114 if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3115 && !lvalue->symtree->n.sym->attr.proc_pointer)
3117 gfc_error ("Pointer assignment target is not a POINTER at %L",
3122 if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3123 && lvalue->symtree->n.sym->attr.use_assoc
3124 && !lvalue->symtree->n.sym->attr.proc_pointer)
3126 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3127 "l-value since it is a procedure",
3128 lvalue->symtree->n.sym->name, &lvalue->where);
3133 /* Check INTENT(IN), unless the object itself is the component or
3134 sub-component of a pointer. */
3135 check_intent_in = 1;
3136 pointer = lvalue->symtree->n.sym->attr.pointer;
3137 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3139 for (ref = lvalue->ref; ref; ref = ref->next)
3142 check_intent_in = 0;
3144 if (ref->type == REF_COMPONENT)
3146 pointer = ref->u.c.component->attr.pointer;
3147 proc_pointer = ref->u.c.component->attr.proc_pointer;
3150 if (ref->type == REF_ARRAY && ref->next == NULL)
3152 if (ref->u.ar.type == AR_FULL)
3155 if (ref->u.ar.type != AR_SECTION)
3157 gfc_error ("Expected bounds specification for '%s' at %L",
3158 lvalue->symtree->n.sym->name, &lvalue->where);
3162 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3163 "specification for '%s' in pointer assignment "
3164 "at %L", lvalue->symtree->n.sym->name,
3165 &lvalue->where) == FAILURE)
3168 gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3169 "in gfortran", &lvalue->where);
3170 /* TODO: See PR 29785. Add checks that all lbounds are specified and
3171 either never or always the upper-bound; strides shall not be
3177 if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
3179 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3180 lvalue->symtree->n.sym->name, &lvalue->where);
3184 if (!pointer && !proc_pointer
3185 && !(lvalue->ts.type == BT_CLASS
3186 && lvalue->ts.u.derived->components->attr.pointer))
3188 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
3192 is_pure = gfc_pure (NULL);
3194 if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
3195 && lvalue->symtree->n.sym->value != rvalue)
3197 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
3201 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3202 kind, etc for lvalue and rvalue must match, and rvalue must be a
3203 pure variable if we're in a pure function. */
3204 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3207 /* Checks on rvalue for procedure pointer assignments. */
3212 gfc_component *comp;
3215 attr = gfc_expr_attr (rvalue);
3216 if (!((rvalue->expr_type == EXPR_NULL)
3217 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3218 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
3219 || (rvalue->expr_type == EXPR_VARIABLE
3220 && attr.flavor == FL_PROCEDURE)))
3222 gfc_error ("Invalid procedure pointer assignment at %L",
3228 gfc_error ("Abstract interface '%s' is invalid "
3229 "in procedure pointer assignment at %L",
3230 rvalue->symtree->name, &rvalue->where);
3233 /* Check for C727. */
3234 if (attr.flavor == FL_PROCEDURE)
3236 if (attr.proc == PROC_ST_FUNCTION)
3238 gfc_error ("Statement function '%s' is invalid "
3239 "in procedure pointer assignment at %L",
3240 rvalue->symtree->name, &rvalue->where);
3243 if (attr.proc == PROC_INTERNAL &&
3244 gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
3245 "invalid in procedure pointer assignment at %L",
3246 rvalue->symtree->name, &rvalue->where) == FAILURE)
3250 /* Ensure that the calling convention is the same. As other attributes
3251 such as DLLEXPORT may differ, one explicitly only tests for the
3252 calling conventions. */
3253 if (rvalue->expr_type == EXPR_VARIABLE
3254 && lvalue->symtree->n.sym->attr.ext_attr
3255 != rvalue->symtree->n.sym->attr.ext_attr)
3257 symbol_attribute calls;
3260 gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
3261 gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
3262 gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
3264 if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
3265 != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
3267 gfc_error ("Mismatch in the procedure pointer assignment "
3268 "at %L: mismatch in the calling convention",
3274 if (gfc_is_proc_ptr_comp (lvalue, &comp))
3275 s1 = comp->ts.interface;
3277 s1 = lvalue->symtree->n.sym;
3279 if (gfc_is_proc_ptr_comp (rvalue, &comp))
3281 s2 = comp->ts.interface;
3284 else if (rvalue->expr_type == EXPR_FUNCTION)
3286 s2 = rvalue->symtree->n.sym->result;
3287 name = rvalue->symtree->n.sym->result->name;
3291 s2 = rvalue->symtree->n.sym;
3292 name = rvalue->symtree->n.sym->name;
3295 if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
3298 gfc_error ("Interface mismatch in procedure pointer assignment "
3299 "at %L: %s", &rvalue->where, err);
3306 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3308 gfc_error ("Different types in pointer assignment at %L; attempted "
3309 "assignment of %s to %s", &lvalue->where,
3310 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3314 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
3316 gfc_error ("Different kind type parameters in pointer "
3317 "assignment at %L", &lvalue->where);
3321 if (lvalue->rank != rvalue->rank)
3323 gfc_error ("Different ranks in pointer assignment at %L",
3328 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3329 if (rvalue->expr_type == EXPR_NULL)
3332 if (lvalue->ts.type == BT_CHARACTER)
3334 gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3339 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3340 lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3342 attr = gfc_expr_attr (rvalue);
3343 if (!attr.target && !attr.pointer)
3345 gfc_error ("Pointer assignment target is neither TARGET "
3346 "nor POINTER at %L", &rvalue->where);
3350 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3352 gfc_error ("Bad target in pointer assignment in PURE "
3353 "procedure at %L", &rvalue->where);
3356 if (gfc_has_vector_index (rvalue))
3358 gfc_error ("Pointer assignment with vector subscript "
3359 "on rhs at %L", &rvalue->where);
3363 if (attr.is_protected && attr.use_assoc
3364 && !(attr.pointer || attr.proc_pointer))
3366 gfc_error ("Pointer assignment target has PROTECTED "
3367 "attribute at %L", &rvalue->where);
3375 /* Relative of gfc_check_assign() except that the lvalue is a single
3376 symbol. Used for initialization assignments. */
3379 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3384 memset (&lvalue, '\0', sizeof (gfc_expr));
3386 lvalue.expr_type = EXPR_VARIABLE;
3387 lvalue.ts = sym->ts;
3389 lvalue.rank = sym->as->rank;
3390 lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3391 lvalue.symtree->n.sym = sym;
3392 lvalue.where = sym->declared_at;
3394 if (sym->attr.pointer || sym->attr.proc_pointer
3395 || (sym->ts.type == BT_CLASS
3396 && sym->ts.u.derived->components->attr.pointer
3397 && rvalue->expr_type == EXPR_NULL))
3398 r = gfc_check_pointer_assign (&lvalue, rvalue);
3400 r = gfc_check_assign (&lvalue, rvalue, 1);
3402 gfc_free (lvalue.symtree);
3408 /* Get an expression for a default initializer. */
3411 gfc_default_initializer (gfc_typespec *ts)
3413 gfc_constructor *tail;
3417 /* See if we have a default initializer. */
3418 for (c = ts->u.derived->components; c; c = c->next)
3419 if (c->initializer || c->attr.allocatable)
3425 /* Build the constructor. */
3426 init = gfc_get_expr ();
3427 init->expr_type = EXPR_STRUCTURE;
3429 init->where = ts->u.derived->declared_at;
3432 for (c = ts->u.derived->components; c; c = c->next)
3435 init->value.constructor = tail = gfc_get_constructor ();
3438 tail->next = gfc_get_constructor ();
3443 tail->expr = gfc_copy_expr (c->initializer);
3445 if (c->attr.allocatable)
3447 tail->expr = gfc_get_expr ();
3448 tail->expr->expr_type = EXPR_NULL;
3449 tail->expr->ts = c->ts;
3456 /* Given a symbol, create an expression node with that symbol as a
3457 variable. If the symbol is array valued, setup a reference of the
3461 gfc_get_variable_expr (gfc_symtree *var)
3465 e = gfc_get_expr ();
3466 e->expr_type = EXPR_VARIABLE;
3468 e->ts = var->n.sym->ts;
3470 if (var->n.sym->as != NULL)
3472 e->rank = var->n.sym->as->rank;
3473 e->ref = gfc_get_ref ();
3474 e->ref->type = REF_ARRAY;
3475 e->ref->u.ar.type = AR_FULL;
3482 /* Returns the array_spec of a full array expression. A NULL is
3483 returned otherwise. */
3485 gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
3490 if (expr->rank == 0)
3493 /* Follow any component references. */
3494 if (expr->expr_type == EXPR_VARIABLE
3495 || expr->expr_type == EXPR_CONSTANT)
3497 as = expr->symtree->n.sym->as;
3498 for (ref = expr->ref; ref; ref = ref->next)
3503 as = ref->u.c.component->as;
3511 switch (ref->u.ar.type)
3534 /* General expression traversal function. */
3537 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3538 bool (*func)(gfc_expr *, gfc_symbol *, int*),
3543 gfc_actual_arglist *args;
3550 if ((*func) (expr, sym, &f))
3553 if (expr->ts.type == BT_CHARACTER
3555 && expr->ts.u.cl->length
3556 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
3557 && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
3560 switch (expr->expr_type)
3563 for (args = expr->value.function.actual; args; args = args->next)
3565 if (gfc_traverse_expr (args->expr, sym, func, f))
3573 case EXPR_SUBSTRING:
3576 case EXPR_STRUCTURE:
3578 for (c = expr->value.constructor; c; c = c->next)
3580 if (gfc_traverse_expr (c->expr, sym, func, f))
3584 if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3586 if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3588 if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3590 if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3597 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3599 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3615 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3617 if (gfc_traverse_expr (ar.start[i], sym, func, f))
3619 if (gfc_traverse_expr (ar.end[i], sym, func, f))
3621 if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3627 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3629 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3634 if (ref->u.c.component->ts.type == BT_CHARACTER
3635 && ref->u.c.component->ts.u.cl
3636 && ref->u.c.component->ts.u.cl->length
3637 && ref->u.c.component->ts.u.cl->length->expr_type
3639 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
3643 if (ref->u.c.component->as)
3644 for (i = 0; i < ref->u.c.component->as->rank; i++)
3646 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3649 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3663 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3666 expr_set_symbols_referenced (gfc_expr *expr,
3667 gfc_symbol *sym ATTRIBUTE_UNUSED,
3668 int *f ATTRIBUTE_UNUSED)
3670 if (expr->expr_type != EXPR_VARIABLE)
3672 gfc_set_sym_referenced (expr->symtree->n.sym);
3677 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3679 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3683 /* Determine if an expression is a procedure pointer component. If yes, the
3684 argument 'comp' will point to the component (provided that 'comp' was
3688 gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
3693 if (!expr || !expr->ref)
3700 if (ref->type == REF_COMPONENT)
3702 ppc = ref->u.c.component->attr.proc_pointer;
3704 *comp = ref->u.c.component;
3711 /* Walk an expression tree and check each variable encountered for being typed.
3712 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3713 mode as is a basic arithmetic expression using those; this is for things in
3716 INTEGER :: arr(n), n
3717 INTEGER :: arr(n + 1), n
3719 The namespace is needed for IMPLICIT typing. */
3721 static gfc_namespace* check_typed_ns;
3724 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3725 int* f ATTRIBUTE_UNUSED)
3729 if (e->expr_type != EXPR_VARIABLE)
3732 gcc_assert (e->symtree);
3733 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3736 return (t == FAILURE);
3740 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3744 /* If this is a top-level variable or EXPR_OP, do the check with strict given
3748 if (e->expr_type == EXPR_VARIABLE && !e->ref)
3749 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3751 if (e->expr_type == EXPR_OP)
3753 gfc_try t = SUCCESS;
3755 gcc_assert (e->value.op.op1);
3756 t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
3758 if (t == SUCCESS && e->value.op.op2)
3759 t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
3765 /* Otherwise, walk the expression and do it strictly. */
3766 check_typed_ns = ns;
3767 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3769 return error_found ? FAILURE : SUCCESS;
3772 /* Walk an expression tree and replace all symbols with a corresponding symbol
3773 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3774 statements. The boolean return value is required by gfc_traverse_expr. */
3777 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3779 if ((expr->expr_type == EXPR_VARIABLE
3780 || (expr->expr_type == EXPR_FUNCTION
3781 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3782 && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
3785 gfc_namespace *ns = sym->formal_ns;
3786 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3787 the symtree rather than create a new one (and probably fail later). */
3788 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3789 expr->symtree->n.sym->name);
3791 stree->n.sym->attr = expr->symtree->n.sym->attr;
3792 expr->symtree = stree;
3798 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
3800 gfc_traverse_expr (expr, dest, &replace_symbol, 0);
3803 /* The following is analogous to 'replace_symbol', and needed for copying
3804 interfaces for procedure pointer components. The argument 'sym' must formally
3805 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
3806 However, it gets actually passed a gfc_component (i.e. the procedure pointer
3807 component in whose formal_ns the arguments have to be). */
3810 replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3812 gfc_component *comp;
3813 comp = (gfc_component *)sym;
3814 if ((expr->expr_type == EXPR_VARIABLE
3815 || (expr->expr_type == EXPR_FUNCTION
3816 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3817 && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
3820 gfc_namespace *ns = comp->formal_ns;
3821 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3822 the symtree rather than create a new one (and probably fail later). */
3823 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3824 expr->symtree->n.sym->name);
3826 stree->n.sym->attr = expr->symtree->n.sym->attr;
3827 expr->symtree = stree;
3833 gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
3835 gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);