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 if (sym->attr.cray_pointee
3014 && lvalue->ref != NULL
3015 && lvalue->ref->u.ar.type == AR_FULL
3016 && lvalue->ref->u.ar.as->cp_was_assumed)
3018 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
3019 "is illegal", &lvalue->where);
3023 /* This is possibly a typo: x = f() instead of x => f(). */
3024 if (gfc_option.warn_surprising
3025 && rvalue->expr_type == EXPR_FUNCTION
3026 && rvalue->symtree->n.sym->attr.pointer)
3027 gfc_warning ("POINTER valued function appears on right-hand side of "
3028 "assignment at %L", &rvalue->where);
3030 /* Check size of array assignments. */
3031 if (lvalue->rank != 0 && rvalue->rank != 0
3032 && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
3035 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
3036 && lvalue->symtree->n.sym->attr.data
3037 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
3038 "initialize non-integer variable '%s'",
3039 &rvalue->where, lvalue->symtree->n.sym->name)
3042 else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
3043 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
3044 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3045 &rvalue->where) == FAILURE)
3048 /* Handle the case of a BOZ literal on the RHS. */
3049 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
3052 if (gfc_option.warn_surprising)
3053 gfc_warning ("BOZ literal at %L is bitwise transferred "
3054 "non-integer symbol '%s'", &rvalue->where,
3055 lvalue->symtree->n.sym->name);
3056 if (!gfc_convert_boz (rvalue, &lvalue->ts))
3058 if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
3060 if (rc == ARITH_UNDERFLOW)
3061 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3062 ". This check can be disabled with the option "
3063 "-fno-range-check", &rvalue->where);
3064 else if (rc == ARITH_OVERFLOW)
3065 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3066 ". This check can be disabled with the option "
3067 "-fno-range-check", &rvalue->where);
3068 else if (rc == ARITH_NAN)
3069 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3070 ". This check can be disabled with the option "
3071 "-fno-range-check", &rvalue->where);
3076 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
3079 /* Only DATA Statements come here. */
3082 /* Numeric can be converted to any other numeric. And Hollerith can be
3083 converted to any other type. */
3084 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3085 || rvalue->ts.type == BT_HOLLERITH)
3088 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3091 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3092 "conversion of %s to %s", &lvalue->where,
3093 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3098 /* Assignment is the only case where character variables of different
3099 kind values can be converted into one another. */
3100 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3102 if (lvalue->ts.kind != rvalue->ts.kind)
3103 gfc_convert_chartype (rvalue, &lvalue->ts);
3108 return gfc_convert_type (rvalue, &lvalue->ts, 1);
3112 /* Check that a pointer assignment is OK. We first check lvalue, and
3113 we only check rvalue if it's not an assignment to NULL() or a
3114 NULLIFY statement. */
3117 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3119 symbol_attribute attr;
3122 int pointer, check_intent_in, proc_pointer;
3124 if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3125 && !lvalue->symtree->n.sym->attr.proc_pointer)
3127 gfc_error ("Pointer assignment target is not a POINTER at %L",
3132 if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3133 && lvalue->symtree->n.sym->attr.use_assoc
3134 && !lvalue->symtree->n.sym->attr.proc_pointer)
3136 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3137 "l-value since it is a procedure",
3138 lvalue->symtree->n.sym->name, &lvalue->where);
3143 /* Check INTENT(IN), unless the object itself is the component or
3144 sub-component of a pointer. */
3145 check_intent_in = 1;
3146 pointer = lvalue->symtree->n.sym->attr.pointer;
3147 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3149 for (ref = lvalue->ref; ref; ref = ref->next)
3152 check_intent_in = 0;
3154 if (ref->type == REF_COMPONENT)
3156 pointer = ref->u.c.component->attr.pointer;
3157 proc_pointer = ref->u.c.component->attr.proc_pointer;
3160 if (ref->type == REF_ARRAY && ref->next == NULL)
3162 if (ref->u.ar.type == AR_FULL)
3165 if (ref->u.ar.type != AR_SECTION)
3167 gfc_error ("Expected bounds specification for '%s' at %L",
3168 lvalue->symtree->n.sym->name, &lvalue->where);
3172 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3173 "specification for '%s' in pointer assignment "
3174 "at %L", lvalue->symtree->n.sym->name,
3175 &lvalue->where) == FAILURE)
3178 gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3179 "in gfortran", &lvalue->where);
3180 /* TODO: See PR 29785. Add checks that all lbounds are specified and
3181 either never or always the upper-bound; strides shall not be
3187 if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
3189 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3190 lvalue->symtree->n.sym->name, &lvalue->where);
3194 if (!pointer && !proc_pointer
3195 && !(lvalue->ts.type == BT_CLASS
3196 && lvalue->ts.u.derived->components->attr.pointer))
3198 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
3202 is_pure = gfc_pure (NULL);
3204 if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
3205 && lvalue->symtree->n.sym->value != rvalue)
3207 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
3211 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3212 kind, etc for lvalue and rvalue must match, and rvalue must be a
3213 pure variable if we're in a pure function. */
3214 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3217 /* Checks on rvalue for procedure pointer assignments. */
3222 gfc_component *comp;
3225 attr = gfc_expr_attr (rvalue);
3226 if (!((rvalue->expr_type == EXPR_NULL)
3227 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3228 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
3229 || (rvalue->expr_type == EXPR_VARIABLE
3230 && attr.flavor == FL_PROCEDURE)))
3232 gfc_error ("Invalid procedure pointer assignment at %L",
3238 gfc_error ("Abstract interface '%s' is invalid "
3239 "in procedure pointer assignment at %L",
3240 rvalue->symtree->name, &rvalue->where);
3243 /* Check for C727. */
3244 if (attr.flavor == FL_PROCEDURE)
3246 if (attr.proc == PROC_ST_FUNCTION)
3248 gfc_error ("Statement function '%s' is invalid "
3249 "in procedure pointer assignment at %L",
3250 rvalue->symtree->name, &rvalue->where);
3253 if (attr.proc == PROC_INTERNAL &&
3254 gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
3255 "invalid in procedure pointer assignment at %L",
3256 rvalue->symtree->name, &rvalue->where) == FAILURE)
3260 /* Ensure that the calling convention is the same. As other attributes
3261 such as DLLEXPORT may differ, one explicitly only tests for the
3262 calling conventions. */
3263 if (rvalue->expr_type == EXPR_VARIABLE
3264 && lvalue->symtree->n.sym->attr.ext_attr
3265 != rvalue->symtree->n.sym->attr.ext_attr)
3267 symbol_attribute calls;
3270 gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
3271 gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
3272 gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
3274 if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
3275 != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
3277 gfc_error ("Mismatch in the procedure pointer assignment "
3278 "at %L: mismatch in the calling convention",
3284 if (gfc_is_proc_ptr_comp (lvalue, &comp))
3285 s1 = comp->ts.interface;
3287 s1 = lvalue->symtree->n.sym;
3289 if (gfc_is_proc_ptr_comp (rvalue, &comp))
3291 s2 = comp->ts.interface;
3294 else if (rvalue->expr_type == EXPR_FUNCTION)
3296 s2 = rvalue->symtree->n.sym->result;
3297 name = rvalue->symtree->n.sym->result->name;
3301 s2 = rvalue->symtree->n.sym;
3302 name = rvalue->symtree->n.sym->name;
3305 if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
3308 gfc_error ("Interface mismatch in procedure pointer assignment "
3309 "at %L: %s", &rvalue->where, err);
3316 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3318 gfc_error ("Different types in pointer assignment at %L; attempted "
3319 "assignment of %s to %s", &lvalue->where,
3320 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3324 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
3326 gfc_error ("Different kind type parameters in pointer "
3327 "assignment at %L", &lvalue->where);
3331 if (lvalue->rank != rvalue->rank)
3333 gfc_error ("Different ranks in pointer assignment at %L",
3338 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3339 if (rvalue->expr_type == EXPR_NULL)
3342 if (lvalue->ts.type == BT_CHARACTER)
3344 gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3349 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3350 lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3352 attr = gfc_expr_attr (rvalue);
3353 if (!attr.target && !attr.pointer)
3355 gfc_error ("Pointer assignment target is neither TARGET "
3356 "nor POINTER at %L", &rvalue->where);
3360 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3362 gfc_error ("Bad target in pointer assignment in PURE "
3363 "procedure at %L", &rvalue->where);
3366 if (gfc_has_vector_index (rvalue))
3368 gfc_error ("Pointer assignment with vector subscript "
3369 "on rhs at %L", &rvalue->where);
3373 if (attr.is_protected && attr.use_assoc
3374 && !(attr.pointer || attr.proc_pointer))
3376 gfc_error ("Pointer assignment target has PROTECTED "
3377 "attribute at %L", &rvalue->where);
3385 /* Relative of gfc_check_assign() except that the lvalue is a single
3386 symbol. Used for initialization assignments. */
3389 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3394 memset (&lvalue, '\0', sizeof (gfc_expr));
3396 lvalue.expr_type = EXPR_VARIABLE;
3397 lvalue.ts = sym->ts;
3399 lvalue.rank = sym->as->rank;
3400 lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3401 lvalue.symtree->n.sym = sym;
3402 lvalue.where = sym->declared_at;
3404 if (sym->attr.pointer || sym->attr.proc_pointer
3405 || (sym->ts.type == BT_CLASS
3406 && sym->ts.u.derived->components->attr.pointer
3407 && rvalue->expr_type == EXPR_NULL))
3408 r = gfc_check_pointer_assign (&lvalue, rvalue);
3410 r = gfc_check_assign (&lvalue, rvalue, 1);
3412 gfc_free (lvalue.symtree);
3418 /* Get an expression for a default initializer. */
3421 gfc_default_initializer (gfc_typespec *ts)
3423 gfc_constructor *tail;
3427 /* See if we have a default initializer. */
3428 for (c = ts->u.derived->components; c; c = c->next)
3429 if (c->initializer || c->attr.allocatable)
3435 /* Build the constructor. */
3436 init = gfc_get_expr ();
3437 init->expr_type = EXPR_STRUCTURE;
3439 init->where = ts->u.derived->declared_at;
3442 for (c = ts->u.derived->components; c; c = c->next)
3445 init->value.constructor = tail = gfc_get_constructor ();
3448 tail->next = gfc_get_constructor ();
3453 tail->expr = gfc_copy_expr (c->initializer);
3455 if (c->attr.allocatable)
3457 tail->expr = gfc_get_expr ();
3458 tail->expr->expr_type = EXPR_NULL;
3459 tail->expr->ts = c->ts;
3466 /* Given a symbol, create an expression node with that symbol as a
3467 variable. If the symbol is array valued, setup a reference of the
3471 gfc_get_variable_expr (gfc_symtree *var)
3475 e = gfc_get_expr ();
3476 e->expr_type = EXPR_VARIABLE;
3478 e->ts = var->n.sym->ts;
3480 if (var->n.sym->as != NULL)
3482 e->rank = var->n.sym->as->rank;
3483 e->ref = gfc_get_ref ();
3484 e->ref->type = REF_ARRAY;
3485 e->ref->u.ar.type = AR_FULL;
3492 /* General expression traversal function. */
3495 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3496 bool (*func)(gfc_expr *, gfc_symbol *, int*),
3501 gfc_actual_arglist *args;
3508 if ((*func) (expr, sym, &f))
3511 if (expr->ts.type == BT_CHARACTER
3513 && expr->ts.u.cl->length
3514 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
3515 && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
3518 switch (expr->expr_type)
3521 for (args = expr->value.function.actual; args; args = args->next)
3523 if (gfc_traverse_expr (args->expr, sym, func, f))
3531 case EXPR_SUBSTRING:
3534 case EXPR_STRUCTURE:
3536 for (c = expr->value.constructor; c; c = c->next)
3538 if (gfc_traverse_expr (c->expr, sym, func, f))
3542 if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3544 if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3546 if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3548 if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3555 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3557 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3573 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3575 if (gfc_traverse_expr (ar.start[i], sym, func, f))
3577 if (gfc_traverse_expr (ar.end[i], sym, func, f))
3579 if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3585 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3587 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3592 if (ref->u.c.component->ts.type == BT_CHARACTER
3593 && ref->u.c.component->ts.u.cl
3594 && ref->u.c.component->ts.u.cl->length
3595 && ref->u.c.component->ts.u.cl->length->expr_type
3597 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
3601 if (ref->u.c.component->as)
3602 for (i = 0; i < ref->u.c.component->as->rank; i++)
3604 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3607 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3621 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3624 expr_set_symbols_referenced (gfc_expr *expr,
3625 gfc_symbol *sym ATTRIBUTE_UNUSED,
3626 int *f ATTRIBUTE_UNUSED)
3628 if (expr->expr_type != EXPR_VARIABLE)
3630 gfc_set_sym_referenced (expr->symtree->n.sym);
3635 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3637 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3641 /* Determine if an expression is a procedure pointer component. If yes, the
3642 argument 'comp' will point to the component (provided that 'comp' was
3646 gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
3651 if (!expr || !expr->ref)
3658 if (ref->type == REF_COMPONENT)
3660 ppc = ref->u.c.component->attr.proc_pointer;
3662 *comp = ref->u.c.component;
3669 /* Walk an expression tree and check each variable encountered for being typed.
3670 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3671 mode as is a basic arithmetic expression using those; this is for things in
3674 INTEGER :: arr(n), n
3675 INTEGER :: arr(n + 1), n
3677 The namespace is needed for IMPLICIT typing. */
3679 static gfc_namespace* check_typed_ns;
3682 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3683 int* f ATTRIBUTE_UNUSED)
3687 if (e->expr_type != EXPR_VARIABLE)
3690 gcc_assert (e->symtree);
3691 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3694 return (t == FAILURE);
3698 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3702 /* If this is a top-level variable or EXPR_OP, do the check with strict given
3706 if (e->expr_type == EXPR_VARIABLE && !e->ref)
3707 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3709 if (e->expr_type == EXPR_OP)
3711 gfc_try t = SUCCESS;
3713 gcc_assert (e->value.op.op1);
3714 t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
3716 if (t == SUCCESS && e->value.op.op2)
3717 t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
3723 /* Otherwise, walk the expression and do it strictly. */
3724 check_typed_ns = ns;
3725 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3727 return error_found ? FAILURE : SUCCESS;
3730 /* Walk an expression tree and replace all symbols with a corresponding symbol
3731 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3732 statements. The boolean return value is required by gfc_traverse_expr. */
3735 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3737 if ((expr->expr_type == EXPR_VARIABLE
3738 || (expr->expr_type == EXPR_FUNCTION
3739 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3740 && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
3743 gfc_namespace *ns = sym->formal_ns;
3744 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3745 the symtree rather than create a new one (and probably fail later). */
3746 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3747 expr->symtree->n.sym->name);
3749 stree->n.sym->attr = expr->symtree->n.sym->attr;
3750 expr->symtree = stree;
3756 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
3758 gfc_traverse_expr (expr, dest, &replace_symbol, 0);
3761 /* The following is analogous to 'replace_symbol', and needed for copying
3762 interfaces for procedure pointer components. The argument 'sym' must formally
3763 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
3764 However, it gets actually passed a gfc_component (i.e. the procedure pointer
3765 component in whose formal_ns the arguments have to be). */
3768 replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3770 gfc_component *comp;
3771 comp = (gfc_component *)sym;
3772 if ((expr->expr_type == EXPR_VARIABLE
3773 || (expr->expr_type == EXPR_FUNCTION
3774 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3775 && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
3778 gfc_namespace *ns = comp->formal_ns;
3779 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3780 the symtree rather than create a new one (and probably fail later). */
3781 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3782 expr->symtree->n.sym->name);
3784 stree->n.sym->attr = expr->symtree->n.sym->attr;
3785 expr->symtree = stree;
3791 gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
3793 gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);