1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
28 #include "target-memory.h" /* for gfc_convert_boz */
30 /* Get a new expr node. */
38 gfc_clear_ts (&e->ts);
42 e->con_by_offset = NULL;
47 /* Free an argument list and everything below it. */
50 gfc_free_actual_arglist (gfc_actual_arglist *a1)
52 gfc_actual_arglist *a2;
57 gfc_free_expr (a1->expr);
64 /* Copy an arglist structure and all of the arguments. */
67 gfc_copy_actual_arglist (gfc_actual_arglist *p)
69 gfc_actual_arglist *head, *tail, *new_arg;
73 for (; p; p = p->next)
75 new_arg = gfc_get_actual_arglist ();
78 new_arg->expr = gfc_copy_expr (p->expr);
93 /* Free a list of reference structures. */
96 gfc_free_ref_list (gfc_ref *p)
108 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
110 gfc_free_expr (p->u.ar.start[i]);
111 gfc_free_expr (p->u.ar.end[i]);
112 gfc_free_expr (p->u.ar.stride[i]);
118 gfc_free_expr (p->u.ss.start);
119 gfc_free_expr (p->u.ss.end);
131 /* Workhorse function for gfc_free_expr() that frees everything
132 beneath an expression node, but not the node itself. This is
133 useful when we want to simplify a node and replace it with
134 something else or the expression node belongs to another structure. */
137 free_expr0 (gfc_expr *e)
141 switch (e->expr_type)
144 /* Free any parts of the value that need freeing. */
148 mpz_clear (e->value.integer);
152 mpfr_clear (e->value.real);
156 gfc_free (e->value.character.string);
160 mpc_clear (e->value.complex);
167 /* Free the representation. */
168 if (e->representation.string)
169 gfc_free (e->representation.string);
174 if (e->value.op.op1 != NULL)
175 gfc_free_expr (e->value.op.op1);
176 if (e->value.op.op2 != NULL)
177 gfc_free_expr (e->value.op.op2);
181 gfc_free_actual_arglist (e->value.function.actual);
186 gfc_free_actual_arglist (e->value.compcall.actual);
194 gfc_free_constructor (e->value.constructor);
198 gfc_free (e->value.character.string);
205 gfc_internal_error ("free_expr0(): Bad expr type");
208 /* Free a shape array. */
209 if (e->shape != NULL)
211 for (n = 0; n < e->rank; n++)
212 mpz_clear (e->shape[n]);
217 gfc_free_ref_list (e->ref);
219 memset (e, '\0', sizeof (gfc_expr));
223 /* Free an expression node and everything beneath it. */
226 gfc_free_expr (gfc_expr *e)
230 if (e->con_by_offset)
231 splay_tree_delete (e->con_by_offset);
237 /* Graft the *src expression onto the *dest subexpression. */
240 gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
248 /* Try to extract an integer constant from the passed expression node.
249 Returns an error message or NULL if the result is set. It is
250 tempting to generate an error and return SUCCESS or FAILURE, but
251 failure is OK for some callers. */
254 gfc_extract_int (gfc_expr *expr, int *result)
256 if (expr->expr_type != EXPR_CONSTANT)
257 return _("Constant expression required at %C");
259 if (expr->ts.type != BT_INTEGER)
260 return _("Integer expression required at %C");
262 if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
263 || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
265 return _("Integer value too large in expression at %C");
268 *result = (int) mpz_get_si (expr->value.integer);
274 /* Recursively copy a list of reference structures. */
277 gfc_copy_ref (gfc_ref *src)
285 dest = gfc_get_ref ();
286 dest->type = src->type;
291 ar = gfc_copy_array_ref (&src->u.ar);
297 dest->u.c = src->u.c;
301 dest->u.ss = src->u.ss;
302 dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
303 dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
307 dest->next = gfc_copy_ref (src->next);
313 /* Detect whether an expression has any vector index array references. */
316 gfc_has_vector_index (gfc_expr *e)
320 for (ref = e->ref; ref; ref = ref->next)
321 if (ref->type == REF_ARRAY)
322 for (i = 0; i < ref->u.ar.dimen; i++)
323 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
329 /* Insert a reference to the component of the given name.
330 Only to be used with CLASS containers. */
333 gfc_add_component_ref (gfc_expr *e, const char *name)
335 gfc_ref **tail = &(e->ref);
336 gfc_ref *next = NULL;
337 gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
338 while (*tail != NULL)
340 if ((*tail)->type == REF_COMPONENT)
341 derived = (*tail)->u.c.component->ts.u.derived;
342 if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
344 tail = &((*tail)->next);
346 if (*tail != NULL && strcmp (name, "$data") == 0)
348 (*tail) = gfc_get_ref();
349 (*tail)->next = next;
350 (*tail)->type = REF_COMPONENT;
351 (*tail)->u.c.sym = derived;
352 (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
353 gcc_assert((*tail)->u.c.component);
355 e->ts = (*tail)->u.c.component->ts;
359 /* Copy a shape array. */
362 gfc_copy_shape (mpz_t *shape, int rank)
370 new_shape = gfc_get_shape (rank);
372 for (n = 0; n < rank; n++)
373 mpz_init_set (new_shape[n], shape[n]);
379 /* Copy a shape array excluding dimension N, where N is an integer
380 constant expression. Dimensions are numbered in fortran style --
383 So, if the original shape array contains R elements
384 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
385 the result contains R-1 elements:
386 { s1 ... sN-1 sN+1 ... sR-1}
388 If anything goes wrong -- N is not a constant, its value is out
389 of range -- or anything else, just returns NULL. */
392 gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
394 mpz_t *new_shape, *s;
400 || dim->expr_type != EXPR_CONSTANT
401 || dim->ts.type != BT_INTEGER)
404 n = mpz_get_si (dim->value.integer);
405 n--; /* Convert to zero based index. */
406 if (n < 0 || n >= rank)
409 s = new_shape = gfc_get_shape (rank - 1);
411 for (i = 0; i < rank; i++)
415 mpz_init_set (*s, shape[i]);
423 /* Given an expression pointer, return a copy of the expression. This
424 subroutine is recursive. */
427 gfc_copy_expr (gfc_expr *p)
439 switch (q->expr_type)
442 s = gfc_get_wide_string (p->value.character.length + 1);
443 q->value.character.string = s;
444 memcpy (s, p->value.character.string,
445 (p->value.character.length + 1) * sizeof (gfc_char_t));
449 /* Copy target representation, if it exists. */
450 if (p->representation.string)
452 c = XCNEWVEC (char, p->representation.length + 1);
453 q->representation.string = c;
454 memcpy (c, p->representation.string, (p->representation.length + 1));
457 /* Copy the values of any pointer components of p->value. */
461 mpz_init_set (q->value.integer, p->value.integer);
465 gfc_set_model_kind (q->ts.kind);
466 mpfr_init (q->value.real);
467 mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
471 gfc_set_model_kind (q->ts.kind);
472 mpc_init2 (q->value.complex, mpfr_get_default_prec());
473 mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
477 if (p->representation.string)
478 q->value.character.string
479 = gfc_char_to_widechar (q->representation.string);
482 s = gfc_get_wide_string (p->value.character.length + 1);
483 q->value.character.string = s;
485 /* This is the case for the C_NULL_CHAR named constant. */
486 if (p->value.character.length == 0
487 && (p->ts.is_c_interop || p->ts.is_iso_c))
490 /* Need to set the length to 1 to make sure the NUL
491 terminator is copied. */
492 q->value.character.length = 1;
495 memcpy (s, p->value.character.string,
496 (p->value.character.length + 1) * sizeof (gfc_char_t));
504 break; /* Already done. */
508 /* Should never be reached. */
510 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
517 switch (q->value.op.op)
520 case INTRINSIC_PARENTHESES:
521 case INTRINSIC_UPLUS:
522 case INTRINSIC_UMINUS:
523 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
526 default: /* Binary operators. */
527 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
528 q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
535 q->value.function.actual =
536 gfc_copy_actual_arglist (p->value.function.actual);
541 q->value.compcall.actual =
542 gfc_copy_actual_arglist (p->value.compcall.actual);
543 q->value.compcall.tbp = p->value.compcall.tbp;
548 q->value.constructor = gfc_copy_constructor (p->value.constructor);
556 q->shape = gfc_copy_shape (p->shape, p->rank);
558 q->ref = gfc_copy_ref (p->ref);
564 /* Return the maximum kind of two expressions. In general, higher
565 kind numbers mean more precision for numeric types. */
568 gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
570 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
574 /* Returns nonzero if the type is numeric, zero otherwise. */
577 numeric_type (bt type)
579 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
583 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
586 gfc_numeric_ts (gfc_typespec *ts)
588 return numeric_type (ts->type);
592 /* Returns an expression node that is an integer constant. */
601 p->expr_type = EXPR_CONSTANT;
602 p->ts.type = BT_INTEGER;
603 p->ts.kind = gfc_default_integer_kind;
605 p->where = gfc_current_locus;
606 mpz_init_set_si (p->value.integer, i);
612 /* Returns an expression node that is a logical constant. */
615 gfc_logical_expr (int i, locus *where)
621 p->expr_type = EXPR_CONSTANT;
622 p->ts.type = BT_LOGICAL;
623 p->ts.kind = gfc_default_logical_kind;
626 where = &gfc_current_locus;
628 p->value.logical = i;
634 /* Return an expression node with an optional argument list attached.
635 A variable number of gfc_expr pointers are strung together in an
636 argument list with a NULL pointer terminating the list. */
639 gfc_build_conversion (gfc_expr *e)
644 p->expr_type = EXPR_FUNCTION;
646 p->value.function.actual = NULL;
648 p->value.function.actual = gfc_get_actual_arglist ();
649 p->value.function.actual->expr = e;
655 /* Given an expression node with some sort of numeric binary
656 expression, insert type conversions required to make the operands
657 have the same type. Conversion warnings are disabled if wconversion
660 The exception is that the operands of an exponential don't have to
661 have the same type. If possible, the base is promoted to the type
662 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
663 1.0**2 stays as it is. */
666 gfc_type_convert_binary (gfc_expr *e, int wconversion)
670 op1 = e->value.op.op1;
671 op2 = e->value.op.op2;
673 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
675 gfc_clear_ts (&e->ts);
679 /* Kind conversions of same type. */
680 if (op1->ts.type == op2->ts.type)
682 if (op1->ts.kind == op2->ts.kind)
684 /* No type conversions. */
689 if (op1->ts.kind > op2->ts.kind)
690 gfc_convert_type_warn (op2, &op1->ts, 2, wconversion);
692 gfc_convert_type_warn (op1, &op2->ts, 2, wconversion);
698 /* Integer combined with real or complex. */
699 if (op2->ts.type == BT_INTEGER)
703 /* Special case for ** operator. */
704 if (e->value.op.op == INTRINSIC_POWER)
707 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
711 if (op1->ts.type == BT_INTEGER)
714 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
718 /* Real combined with complex. */
719 e->ts.type = BT_COMPLEX;
720 if (op1->ts.kind > op2->ts.kind)
721 e->ts.kind = op1->ts.kind;
723 e->ts.kind = op2->ts.kind;
724 if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
725 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
726 if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
727 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
735 check_specification_function (gfc_expr *e)
742 sym = e->symtree->n.sym;
744 /* F95, 7.1.6.2; F2003, 7.1.7 */
746 && sym->attr.function
748 && !sym->attr.intrinsic
749 && !sym->attr.recursive
750 && sym->attr.proc != PROC_INTERNAL
751 && sym->attr.proc != PROC_ST_FUNCTION
752 && sym->attr.proc != PROC_UNKNOWN
753 && sym->formal == NULL)
759 /* Function to determine if an expression is constant or not. This
760 function expects that the expression has already been simplified. */
763 gfc_is_constant_expr (gfc_expr *e)
766 gfc_actual_arglist *arg;
772 switch (e->expr_type)
775 rv = (gfc_is_constant_expr (e->value.op.op1)
776 && (e->value.op.op2 == NULL
777 || gfc_is_constant_expr (e->value.op.op2)));
785 /* Specification functions are constant. */
786 if (check_specification_function (e) == MATCH_YES)
792 /* Call to intrinsic with at least one argument. */
794 if (e->value.function.isym && e->value.function.actual)
796 for (arg = e->value.function.actual; arg; arg = arg->next)
798 if (!gfc_is_constant_expr (arg->expr))
812 rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
813 && gfc_is_constant_expr (e->ref->u.ss.end));
818 for (c = e->value.constructor; c; c = c->next)
819 if (!gfc_is_constant_expr (c->expr))
827 rv = gfc_constant_ac (e);
831 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
838 /* Is true if an array reference is followed by a component or substring
841 is_subref_array (gfc_expr * e)
846 if (e->expr_type != EXPR_VARIABLE)
849 if (e->symtree->n.sym->attr.subref_array_pointer)
853 for (ref = e->ref; ref; ref = ref->next)
855 if (ref->type == REF_ARRAY
856 && ref->u.ar.type != AR_ELEMENT)
860 && ref->type != REF_ARRAY)
867 /* Try to collapse intrinsic expressions. */
870 simplify_intrinsic_op (gfc_expr *p, int type)
873 gfc_expr *op1, *op2, *result;
875 if (p->value.op.op == INTRINSIC_USER)
878 op1 = p->value.op.op1;
879 op2 = p->value.op.op2;
882 if (gfc_simplify_expr (op1, type) == FAILURE)
884 if (gfc_simplify_expr (op2, type) == FAILURE)
887 if (!gfc_is_constant_expr (op1)
888 || (op2 != NULL && !gfc_is_constant_expr (op2)))
892 p->value.op.op1 = NULL;
893 p->value.op.op2 = NULL;
897 case INTRINSIC_PARENTHESES:
898 result = gfc_parentheses (op1);
901 case INTRINSIC_UPLUS:
902 result = gfc_uplus (op1);
905 case INTRINSIC_UMINUS:
906 result = gfc_uminus (op1);
910 result = gfc_add (op1, op2);
913 case INTRINSIC_MINUS:
914 result = gfc_subtract (op1, op2);
917 case INTRINSIC_TIMES:
918 result = gfc_multiply (op1, op2);
921 case INTRINSIC_DIVIDE:
922 result = gfc_divide (op1, op2);
925 case INTRINSIC_POWER:
926 result = gfc_power (op1, op2);
929 case INTRINSIC_CONCAT:
930 result = gfc_concat (op1, op2);
934 case INTRINSIC_EQ_OS:
935 result = gfc_eq (op1, op2, op);
939 case INTRINSIC_NE_OS:
940 result = gfc_ne (op1, op2, op);
944 case INTRINSIC_GT_OS:
945 result = gfc_gt (op1, op2, op);
949 case INTRINSIC_GE_OS:
950 result = gfc_ge (op1, op2, op);
954 case INTRINSIC_LT_OS:
955 result = gfc_lt (op1, op2, op);
959 case INTRINSIC_LE_OS:
960 result = gfc_le (op1, op2, op);
964 result = gfc_not (op1);
968 result = gfc_and (op1, op2);
972 result = gfc_or (op1, op2);
976 result = gfc_eqv (op1, op2);
980 result = gfc_neqv (op1, op2);
984 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
994 result->rank = p->rank;
995 result->where = p->where;
996 gfc_replace_expr (p, result);
1002 /* Subroutine to simplify constructor expressions. Mutually recursive
1003 with gfc_simplify_expr(). */
1006 simplify_constructor (gfc_constructor *c, int type)
1010 for (; c; c = c->next)
1013 && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
1014 || gfc_simplify_expr (c->iterator->end, type) == FAILURE
1015 || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
1020 /* Try and simplify a copy. Replace the original if successful
1021 but keep going through the constructor at all costs. Not
1022 doing so can make a dog's dinner of complicated things. */
1023 p = gfc_copy_expr (c->expr);
1025 if (gfc_simplify_expr (p, type) == FAILURE)
1031 gfc_replace_expr (c->expr, p);
1039 /* Pull a single array element out of an array constructor. */
1042 find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
1043 gfc_constructor **rval)
1045 unsigned long nelemen;
1057 mpz_init_set_ui (offset, 0);
1060 mpz_init_set_ui (span, 1);
1061 for (i = 0; i < ar->dimen; i++)
1063 if (gfc_reduce_init_expr (ar->as->lower[i]) == FAILURE
1064 || gfc_reduce_init_expr (ar->as->upper[i]) == FAILURE)
1071 e = gfc_copy_expr (ar->start[i]);
1072 if (e->expr_type != EXPR_CONSTANT)
1078 gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
1079 && ar->as->lower[i]->expr_type == EXPR_CONSTANT);
1081 /* Check the bounds. */
1082 if ((ar->as->upper[i]
1083 && mpz_cmp (e->value.integer,
1084 ar->as->upper[i]->value.integer) > 0)
1085 || (mpz_cmp (e->value.integer,
1086 ar->as->lower[i]->value.integer) < 0))
1088 gfc_error ("Index in dimension %d is out of bounds "
1089 "at %L", i + 1, &ar->c_where[i]);
1095 mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1096 mpz_mul (delta, delta, span);
1097 mpz_add (offset, offset, delta);
1099 mpz_set_ui (tmp, 1);
1100 mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1101 mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1102 mpz_mul (span, span, tmp);
1105 for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
1130 /* Find a component of a structure constructor. */
1132 static gfc_constructor *
1133 find_component_ref (gfc_constructor *cons, gfc_ref *ref)
1135 gfc_component *comp;
1136 gfc_component *pick;
1138 comp = ref->u.c.sym->components;
1139 pick = ref->u.c.component;
1140 while (comp != pick)
1150 /* Replace an expression with the contents of a constructor, removing
1151 the subobject reference in the process. */
1154 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1164 e = gfc_copy_expr (p);
1165 e->ref = p->ref->next;
1166 p->ref->next = NULL;
1167 gfc_replace_expr (p, e);
1171 /* Pull an array section out of an array constructor. */
1174 find_array_section (gfc_expr *expr, gfc_ref *ref)
1180 long unsigned one = 1;
1182 mpz_t start[GFC_MAX_DIMENSIONS];
1183 mpz_t end[GFC_MAX_DIMENSIONS];
1184 mpz_t stride[GFC_MAX_DIMENSIONS];
1185 mpz_t delta[GFC_MAX_DIMENSIONS];
1186 mpz_t ctr[GFC_MAX_DIMENSIONS];
1192 gfc_constructor *cons;
1193 gfc_constructor *base;
1199 gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
1204 base = expr->value.constructor;
1205 expr->value.constructor = NULL;
1207 rank = ref->u.ar.as->rank;
1209 if (expr->shape == NULL)
1210 expr->shape = gfc_get_shape (rank);
1212 mpz_init_set_ui (delta_mpz, one);
1213 mpz_init_set_ui (nelts, one);
1216 /* Do the initialization now, so that we can cleanup without
1217 keeping track of where we were. */
1218 for (d = 0; d < rank; d++)
1220 mpz_init (delta[d]);
1221 mpz_init (start[d]);
1224 mpz_init (stride[d]);
1228 /* Build the counters to clock through the array reference. */
1230 for (d = 0; d < rank; d++)
1232 /* Make this stretch of code easier on the eye! */
1233 begin = ref->u.ar.start[d];
1234 finish = ref->u.ar.end[d];
1235 step = ref->u.ar.stride[d];
1236 lower = ref->u.ar.as->lower[d];
1237 upper = ref->u.ar.as->upper[d];
1239 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1243 if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1249 gcc_assert (begin->rank == 1);
1250 /* Zero-sized arrays have no shape and no elements, stop early. */
1253 mpz_init_set_ui (nelts, 0);
1257 vecsub[d] = begin->value.constructor;
1258 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1259 mpz_mul (nelts, nelts, begin->shape[0]);
1260 mpz_set (expr->shape[shape_i++], begin->shape[0]);
1263 for (c = vecsub[d]; c; c = c->next)
1265 if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
1266 || mpz_cmp (c->expr->value.integer,
1267 lower->value.integer) < 0)
1269 gfc_error ("index in dimension %d is out of bounds "
1270 "at %L", d + 1, &ref->u.ar.c_where[d]);
1278 if ((begin && begin->expr_type != EXPR_CONSTANT)
1279 || (finish && finish->expr_type != EXPR_CONSTANT)
1280 || (step && step->expr_type != EXPR_CONSTANT))
1286 /* Obtain the stride. */
1288 mpz_set (stride[d], step->value.integer);
1290 mpz_set_ui (stride[d], one);
1292 if (mpz_cmp_ui (stride[d], 0) == 0)
1293 mpz_set_ui (stride[d], one);
1295 /* Obtain the start value for the index. */
1297 mpz_set (start[d], begin->value.integer);
1299 mpz_set (start[d], lower->value.integer);
1301 mpz_set (ctr[d], start[d]);
1303 /* Obtain the end value for the index. */
1305 mpz_set (end[d], finish->value.integer);
1307 mpz_set (end[d], upper->value.integer);
1309 /* Separate 'if' because elements sometimes arrive with
1311 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1312 mpz_set (end [d], begin->value.integer);
1314 /* Check the bounds. */
1315 if (mpz_cmp (ctr[d], upper->value.integer) > 0
1316 || mpz_cmp (end[d], upper->value.integer) > 0
1317 || mpz_cmp (ctr[d], lower->value.integer) < 0
1318 || mpz_cmp (end[d], lower->value.integer) < 0)
1320 gfc_error ("index in dimension %d is out of bounds "
1321 "at %L", d + 1, &ref->u.ar.c_where[d]);
1326 /* Calculate the number of elements and the shape. */
1327 mpz_set (tmp_mpz, stride[d]);
1328 mpz_add (tmp_mpz, end[d], tmp_mpz);
1329 mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1330 mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1331 mpz_mul (nelts, nelts, tmp_mpz);
1333 /* An element reference reduces the rank of the expression; don't
1334 add anything to the shape array. */
1335 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1336 mpz_set (expr->shape[shape_i++], tmp_mpz);
1339 /* Calculate the 'stride' (=delta) for conversion of the
1340 counter values into the index along the constructor. */
1341 mpz_set (delta[d], delta_mpz);
1342 mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1343 mpz_add_ui (tmp_mpz, tmp_mpz, one);
1344 mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1351 /* Now clock through the array reference, calculating the index in
1352 the source constructor and transferring the elements to the new
1354 for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1356 if (ref->u.ar.offset)
1357 mpz_set (ptr, ref->u.ar.offset->value.integer);
1359 mpz_init_set_ui (ptr, 0);
1362 for (d = 0; d < rank; d++)
1364 mpz_set (tmp_mpz, ctr[d]);
1365 mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1366 mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1367 mpz_add (ptr, ptr, tmp_mpz);
1369 if (!incr_ctr) continue;
1371 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1373 gcc_assert(vecsub[d]);
1375 if (!vecsub[d]->next)
1376 vecsub[d] = ref->u.ar.start[d]->value.constructor;
1379 vecsub[d] = vecsub[d]->next;
1382 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1386 mpz_add (ctr[d], ctr[d], stride[d]);
1388 if (mpz_cmp_ui (stride[d], 0) > 0
1389 ? mpz_cmp (ctr[d], end[d]) > 0
1390 : mpz_cmp (ctr[d], end[d]) < 0)
1391 mpz_set (ctr[d], start[d]);
1397 /* There must be a better way of dealing with negative strides
1398 than resetting the index and the constructor pointer! */
1399 if (mpz_cmp (ptr, index) < 0)
1401 mpz_set_ui (index, 0);
1405 while (cons && cons->next && mpz_cmp (ptr, index) > 0)
1407 mpz_add_ui (index, index, one);
1411 gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
1419 mpz_clear (delta_mpz);
1420 mpz_clear (tmp_mpz);
1422 for (d = 0; d < rank; d++)
1424 mpz_clear (delta[d]);
1425 mpz_clear (start[d]);
1428 mpz_clear (stride[d]);
1430 gfc_free_constructor (base);
1434 /* Pull a substring out of an expression. */
1437 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1444 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1445 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1448 *newp = gfc_copy_expr (p);
1449 gfc_free ((*newp)->value.character.string);
1451 end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1452 start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1453 length = end - start + 1;
1455 chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1456 (*newp)->value.character.length = length;
1457 memcpy (chr, &p->value.character.string[start - 1],
1458 length * sizeof (gfc_char_t));
1465 /* Simplify a subobject reference of a constructor. This occurs when
1466 parameter variable values are substituted. */
1469 simplify_const_ref (gfc_expr *p)
1471 gfc_constructor *cons;
1477 switch (p->ref->type)
1480 switch (p->ref->u.ar.type)
1483 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1484 will generate this. */
1485 if (p->expr_type != EXPR_ARRAY)
1487 remove_subobject_ref (p, NULL);
1490 if (find_array_element (p->value.constructor, &p->ref->u.ar,
1497 remove_subobject_ref (p, cons);
1501 if (find_array_section (p, p->ref) == FAILURE)
1503 p->ref->u.ar.type = AR_FULL;
1508 if (p->ref->next != NULL
1509 && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1511 cons = p->value.constructor;
1512 for (; cons; cons = cons->next)
1514 cons->expr->ref = gfc_copy_ref (p->ref->next);
1515 if (simplify_const_ref (cons->expr) == FAILURE)
1519 if (p->ts.type == BT_DERIVED
1521 && p->value.constructor)
1523 /* There may have been component references. */
1524 p->ts = p->value.constructor->expr->ts;
1528 for (; last_ref->next; last_ref = last_ref->next) {};
1530 if (p->ts.type == BT_CHARACTER
1531 && last_ref->type == REF_SUBSTRING)
1533 /* If this is a CHARACTER array and we possibly took
1534 a substring out of it, update the type-spec's
1535 character length according to the first element
1536 (as all should have the same length). */
1538 if (p->value.constructor)
1540 const gfc_expr* first = p->value.constructor->expr;
1541 gcc_assert (first->expr_type == EXPR_CONSTANT);
1542 gcc_assert (first->ts.type == BT_CHARACTER);
1543 string_len = first->value.character.length;
1549 p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
1552 gfc_free_expr (p->ts.u.cl->length);
1554 p->ts.u.cl->length = gfc_int_expr (string_len);
1557 gfc_free_ref_list (p->ref);
1568 cons = find_component_ref (p->value.constructor, p->ref);
1569 remove_subobject_ref (p, cons);
1573 if (find_substring_ref (p, &newp) == FAILURE)
1576 gfc_replace_expr (p, newp);
1577 gfc_free_ref_list (p->ref);
1587 /* Simplify a chain of references. */
1590 simplify_ref_chain (gfc_ref *ref, int type)
1594 for (; ref; ref = ref->next)
1599 for (n = 0; n < ref->u.ar.dimen; n++)
1601 if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1603 if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1605 if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1611 if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1613 if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1625 /* Try to substitute the value of a parameter variable. */
1628 simplify_parameter_variable (gfc_expr *p, int type)
1633 e = gfc_copy_expr (p->symtree->n.sym->value);
1639 /* Do not copy subobject refs for constant. */
1640 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1641 e->ref = gfc_copy_ref (p->ref);
1642 t = gfc_simplify_expr (e, type);
1644 /* Only use the simplification if it eliminated all subobject references. */
1645 if (t == SUCCESS && !e->ref)
1646 gfc_replace_expr (p, e);
1653 /* Given an expression, simplify it by collapsing constant
1654 expressions. Most simplification takes place when the expression
1655 tree is being constructed. If an intrinsic function is simplified
1656 at some point, we get called again to collapse the result against
1659 We work by recursively simplifying expression nodes, simplifying
1660 intrinsic functions where possible, which can lead to further
1661 constant collapsing. If an operator has constant operand(s), we
1662 rip the expression apart, and rebuild it, hoping that it becomes
1665 The expression type is defined for:
1666 0 Basic expression parsing
1667 1 Simplifying array constructors -- will substitute
1669 Returns FAILURE on error, SUCCESS otherwise.
1670 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1673 gfc_simplify_expr (gfc_expr *p, int type)
1675 gfc_actual_arglist *ap;
1680 switch (p->expr_type)
1687 for (ap = p->value.function.actual; ap; ap = ap->next)
1688 if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1691 if (p->value.function.isym != NULL
1692 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1697 case EXPR_SUBSTRING:
1698 if (simplify_ref_chain (p->ref, type) == FAILURE)
1701 if (gfc_is_constant_expr (p))
1707 if (p->ref && p->ref->u.ss.start)
1709 gfc_extract_int (p->ref->u.ss.start, &start);
1710 start--; /* Convert from one-based to zero-based. */
1713 end = p->value.character.length;
1714 if (p->ref && p->ref->u.ss.end)
1715 gfc_extract_int (p->ref->u.ss.end, &end);
1717 s = gfc_get_wide_string (end - start + 2);
1718 memcpy (s, p->value.character.string + start,
1719 (end - start) * sizeof (gfc_char_t));
1720 s[end - start + 1] = '\0'; /* TODO: C-style string. */
1721 gfc_free (p->value.character.string);
1722 p->value.character.string = s;
1723 p->value.character.length = end - start;
1724 p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1725 p->ts.u.cl->length = gfc_int_expr (p->value.character.length);
1726 gfc_free_ref_list (p->ref);
1728 p->expr_type = EXPR_CONSTANT;
1733 if (simplify_intrinsic_op (p, type) == FAILURE)
1738 /* Only substitute array parameter variables if we are in an
1739 initialization expression, or we want a subsection. */
1740 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1741 && (gfc_init_expr || p->ref
1742 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1744 if (simplify_parameter_variable (p, type) == FAILURE)
1751 gfc_simplify_iterator_var (p);
1754 /* Simplify subcomponent references. */
1755 if (simplify_ref_chain (p->ref, type) == FAILURE)
1760 case EXPR_STRUCTURE:
1762 if (simplify_ref_chain (p->ref, type) == FAILURE)
1765 if (simplify_constructor (p->value.constructor, type) == FAILURE)
1768 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1769 && p->ref->u.ar.type == AR_FULL)
1770 gfc_expand_constructor (p);
1772 if (simplify_const_ref (p) == FAILURE)
1787 /* Returns the type of an expression with the exception that iterator
1788 variables are automatically integers no matter what else they may
1794 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1801 /* Check an intrinsic arithmetic operation to see if it is consistent
1802 with some type of expression. */
1804 static gfc_try check_init_expr (gfc_expr *);
1807 /* Scalarize an expression for an elemental intrinsic call. */
1810 scalarize_intrinsic_call (gfc_expr *e)
1812 gfc_actual_arglist *a, *b;
1813 gfc_constructor *args[5], *ctor, *new_ctor;
1814 gfc_expr *expr, *old;
1815 int n, i, rank[5], array_arg;
1817 /* Find which, if any, arguments are arrays. Assume that the old
1818 expression carries the type information and that the first arg
1819 that is an array expression carries all the shape information.*/
1821 a = e->value.function.actual;
1822 for (; a; a = a->next)
1825 if (a->expr->expr_type != EXPR_ARRAY)
1828 expr = gfc_copy_expr (a->expr);
1835 old = gfc_copy_expr (e);
1837 gfc_free_constructor (expr->value.constructor);
1838 expr->value.constructor = NULL;
1841 expr->where = old->where;
1842 expr->expr_type = EXPR_ARRAY;
1844 /* Copy the array argument constructors into an array, with nulls
1847 a = old->value.function.actual;
1848 for (; a; a = a->next)
1850 /* Check that this is OK for an initialization expression. */
1851 if (a->expr && check_init_expr (a->expr) == FAILURE)
1855 if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
1857 rank[n] = a->expr->rank;
1858 ctor = a->expr->symtree->n.sym->value->value.constructor;
1859 args[n] = gfc_copy_constructor (ctor);
1861 else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
1864 rank[n] = a->expr->rank;
1867 args[n] = gfc_copy_constructor (a->expr->value.constructor);
1875 /* Using the array argument as the master, step through the array
1876 calling the function for each element and advancing the array
1877 constructors together. */
1878 ctor = args[array_arg - 1];
1880 for (; ctor; ctor = ctor->next)
1882 if (expr->value.constructor == NULL)
1883 expr->value.constructor
1884 = new_ctor = gfc_get_constructor ();
1887 new_ctor->next = gfc_get_constructor ();
1888 new_ctor = new_ctor->next;
1890 new_ctor->expr = gfc_copy_expr (old);
1891 gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
1893 b = old->value.function.actual;
1894 for (i = 0; i < n; i++)
1897 new_ctor->expr->value.function.actual
1898 = a = gfc_get_actual_arglist ();
1901 a->next = gfc_get_actual_arglist ();
1905 a->expr = gfc_copy_expr (args[i]->expr);
1907 a->expr = gfc_copy_expr (b->expr);
1912 /* Simplify the function calls. If the simplification fails, the
1913 error will be flagged up down-stream or the library will deal
1915 gfc_simplify_expr (new_ctor->expr, 0);
1917 for (i = 0; i < n; i++)
1919 args[i] = args[i]->next;
1921 for (i = 1; i < n; i++)
1922 if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
1923 || (args[i] == NULL && args[array_arg - 1] != NULL)))
1929 gfc_free_expr (old);
1933 gfc_error_now ("elemental function arguments at %C are not compliant");
1936 gfc_free_expr (expr);
1937 gfc_free_expr (old);
1943 check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
1945 gfc_expr *op1 = e->value.op.op1;
1946 gfc_expr *op2 = e->value.op.op2;
1948 if ((*check_function) (op1) == FAILURE)
1951 switch (e->value.op.op)
1953 case INTRINSIC_UPLUS:
1954 case INTRINSIC_UMINUS:
1955 if (!numeric_type (et0 (op1)))
1960 case INTRINSIC_EQ_OS:
1962 case INTRINSIC_NE_OS:
1964 case INTRINSIC_GT_OS:
1966 case INTRINSIC_GE_OS:
1968 case INTRINSIC_LT_OS:
1970 case INTRINSIC_LE_OS:
1971 if ((*check_function) (op2) == FAILURE)
1974 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1975 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1977 gfc_error ("Numeric or CHARACTER operands are required in "
1978 "expression at %L", &e->where);
1983 case INTRINSIC_PLUS:
1984 case INTRINSIC_MINUS:
1985 case INTRINSIC_TIMES:
1986 case INTRINSIC_DIVIDE:
1987 case INTRINSIC_POWER:
1988 if ((*check_function) (op2) == FAILURE)
1991 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1996 case INTRINSIC_CONCAT:
1997 if ((*check_function) (op2) == FAILURE)
2000 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
2002 gfc_error ("Concatenation operator in expression at %L "
2003 "must have two CHARACTER operands", &op1->where);
2007 if (op1->ts.kind != op2->ts.kind)
2009 gfc_error ("Concat operator at %L must concatenate strings of the "
2010 "same kind", &e->where);
2017 if (et0 (op1) != BT_LOGICAL)
2019 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2020 "operand", &op1->where);
2029 case INTRINSIC_NEQV:
2030 if ((*check_function) (op2) == FAILURE)
2033 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
2035 gfc_error ("LOGICAL operands are required in expression at %L",
2042 case INTRINSIC_PARENTHESES:
2046 gfc_error ("Only intrinsic operators can be used in expression at %L",
2054 gfc_error ("Numeric operands are required in expression at %L", &e->where);
2059 /* F2003, 7.1.7 (3): In init expression, allocatable components
2060 must not be data-initialized. */
2062 check_alloc_comp_init (gfc_expr *e)
2065 gfc_constructor *ctor;
2067 gcc_assert (e->expr_type == EXPR_STRUCTURE);
2068 gcc_assert (e->ts.type == BT_DERIVED);
2070 for (c = e->ts.u.derived->components, ctor = e->value.constructor;
2071 c; c = c->next, ctor = ctor->next)
2073 if (c->attr.allocatable
2074 && ctor->expr->expr_type != EXPR_NULL)
2076 gfc_error("Invalid initialization expression for ALLOCATABLE "
2077 "component '%s' in structure constructor at %L",
2078 c->name, &ctor->expr->where);
2087 check_init_expr_arguments (gfc_expr *e)
2089 gfc_actual_arglist *ap;
2091 for (ap = e->value.function.actual; ap; ap = ap->next)
2092 if (check_init_expr (ap->expr) == FAILURE)
2098 static gfc_try check_restricted (gfc_expr *);
2100 /* F95, 7.1.6.1, Initialization expressions, (7)
2101 F2003, 7.1.7 Initialization expression, (8) */
2104 check_inquiry (gfc_expr *e, int not_restricted)
2107 const char *const *functions;
2109 static const char *const inquiry_func_f95[] = {
2110 "lbound", "shape", "size", "ubound",
2111 "bit_size", "len", "kind",
2112 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2113 "precision", "radix", "range", "tiny",
2117 static const char *const inquiry_func_f2003[] = {
2118 "lbound", "shape", "size", "ubound",
2119 "bit_size", "len", "kind",
2120 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2121 "precision", "radix", "range", "tiny",
2126 gfc_actual_arglist *ap;
2128 if (!e->value.function.isym
2129 || !e->value.function.isym->inquiry)
2132 /* An undeclared parameter will get us here (PR25018). */
2133 if (e->symtree == NULL)
2136 name = e->symtree->n.sym->name;
2138 functions = (gfc_option.warn_std & GFC_STD_F2003)
2139 ? inquiry_func_f2003 : inquiry_func_f95;
2141 for (i = 0; functions[i]; i++)
2142 if (strcmp (functions[i], name) == 0)
2145 if (functions[i] == NULL)
2148 /* At this point we have an inquiry function with a variable argument. The
2149 type of the variable might be undefined, but we need it now, because the
2150 arguments of these functions are not allowed to be undefined. */
2152 for (ap = e->value.function.actual; ap; ap = ap->next)
2157 if (ap->expr->ts.type == BT_UNKNOWN)
2159 if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2160 && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)
2164 ap->expr->ts = ap->expr->symtree->n.sym->ts;
2167 /* Assumed character length will not reduce to a constant expression
2168 with LEN, as required by the standard. */
2169 if (i == 5 && not_restricted
2170 && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2171 && ap->expr->symtree->n.sym->ts.u.cl->length == NULL)
2173 gfc_error ("Assumed character length variable '%s' in constant "
2174 "expression at %L", e->symtree->n.sym->name, &e->where);
2177 else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
2180 if (not_restricted == 0
2181 && ap->expr->expr_type != EXPR_VARIABLE
2182 && check_restricted (ap->expr) == FAILURE)
2190 /* F95, 7.1.6.1, Initialization expressions, (5)
2191 F2003, 7.1.7 Initialization expression, (5) */
2194 check_transformational (gfc_expr *e)
2196 static const char * const trans_func_f95[] = {
2197 "repeat", "reshape", "selected_int_kind",
2198 "selected_real_kind", "transfer", "trim", NULL
2201 static const char * const trans_func_f2003[] = {
2202 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2203 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2204 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2205 "trim", "unpack", NULL
2210 const char *const *functions;
2212 if (!e->value.function.isym
2213 || !e->value.function.isym->transformational)
2216 name = e->symtree->n.sym->name;
2218 functions = (gfc_option.allow_std & GFC_STD_F2003)
2219 ? trans_func_f2003 : trans_func_f95;
2221 /* NULL() is dealt with below. */
2222 if (strcmp ("null", name) == 0)
2225 for (i = 0; functions[i]; i++)
2226 if (strcmp (functions[i], name) == 0)
2229 if (functions[i] == NULL)
2231 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2232 "in an initialization expression", name, &e->where);
2236 return check_init_expr_arguments (e);
2240 /* F95, 7.1.6.1, Initialization expressions, (6)
2241 F2003, 7.1.7 Initialization expression, (6) */
2244 check_null (gfc_expr *e)
2246 if (strcmp ("null", e->symtree->n.sym->name) != 0)
2249 return check_init_expr_arguments (e);
2254 check_elemental (gfc_expr *e)
2256 if (!e->value.function.isym
2257 || !e->value.function.isym->elemental)
2260 if (e->ts.type != BT_INTEGER
2261 && e->ts.type != BT_CHARACTER
2262 && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2263 "nonstandard initialization expression at %L",
2264 &e->where) == FAILURE)
2267 return check_init_expr_arguments (e);
2272 check_conversion (gfc_expr *e)
2274 if (!e->value.function.isym
2275 || !e->value.function.isym->conversion)
2278 return check_init_expr_arguments (e);
2282 /* Verify that an expression is an initialization expression. A side
2283 effect is that the expression tree is reduced to a single constant
2284 node if all goes well. This would normally happen when the
2285 expression is constructed but function references are assumed to be
2286 intrinsics in the context of initialization expressions. If
2287 FAILURE is returned an error message has been generated. */
2290 check_init_expr (gfc_expr *e)
2298 switch (e->expr_type)
2301 t = check_intrinsic_op (e, check_init_expr);
2303 t = gfc_simplify_expr (e, 0);
2311 gfc_intrinsic_sym* isym;
2314 sym = e->symtree->n.sym;
2315 if (!gfc_is_intrinsic (sym, 0, e->where)
2316 || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2318 gfc_error ("Function '%s' in initialization expression at %L "
2319 "must be an intrinsic function",
2320 e->symtree->n.sym->name, &e->where);
2324 if ((m = check_conversion (e)) == MATCH_NO
2325 && (m = check_inquiry (e, 1)) == MATCH_NO
2326 && (m = check_null (e)) == MATCH_NO
2327 && (m = check_transformational (e)) == MATCH_NO
2328 && (m = check_elemental (e)) == MATCH_NO)
2330 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2331 "in an initialization expression",
2332 e->symtree->n.sym->name, &e->where);
2336 /* Try to scalarize an elemental intrinsic function that has an
2338 isym = gfc_find_function (e->symtree->n.sym->name);
2339 if (isym && isym->elemental
2340 && (t = scalarize_intrinsic_call (e)) == SUCCESS)
2345 t = gfc_simplify_expr (e, 0);
2352 if (gfc_check_iter_variable (e) == SUCCESS)
2355 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2357 /* A PARAMETER shall not be used to define itself, i.e.
2358 REAL, PARAMETER :: x = transfer(0, x)
2360 if (!e->symtree->n.sym->value)
2362 gfc_error("PARAMETER '%s' is used at %L before its definition "
2363 "is complete", e->symtree->n.sym->name, &e->where);
2367 t = simplify_parameter_variable (e, 0);
2372 if (gfc_in_match_data ())
2377 if (e->symtree->n.sym->as)
2379 switch (e->symtree->n.sym->as->type)
2381 case AS_ASSUMED_SIZE:
2382 gfc_error ("Assumed size array '%s' at %L is not permitted "
2383 "in an initialization expression",
2384 e->symtree->n.sym->name, &e->where);
2387 case AS_ASSUMED_SHAPE:
2388 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2389 "in an initialization expression",
2390 e->symtree->n.sym->name, &e->where);
2394 gfc_error ("Deferred array '%s' at %L is not permitted "
2395 "in an initialization expression",
2396 e->symtree->n.sym->name, &e->where);
2400 gfc_error ("Array '%s' at %L is a variable, which does "
2401 "not reduce to a constant expression",
2402 e->symtree->n.sym->name, &e->where);
2410 gfc_error ("Parameter '%s' at %L has not been declared or is "
2411 "a variable, which does not reduce to a constant "
2412 "expression", e->symtree->n.sym->name, &e->where);
2421 case EXPR_SUBSTRING:
2422 t = check_init_expr (e->ref->u.ss.start);
2426 t = check_init_expr (e->ref->u.ss.end);
2428 t = gfc_simplify_expr (e, 0);
2432 case EXPR_STRUCTURE:
2433 t = e->ts.is_iso_c ? SUCCESS : FAILURE;
2437 t = check_alloc_comp_init (e);
2441 t = gfc_check_constructor (e, check_init_expr);
2448 t = gfc_check_constructor (e, check_init_expr);
2452 t = gfc_expand_constructor (e);
2456 t = gfc_check_constructor_type (e);
2460 gfc_internal_error ("check_init_expr(): Unknown expression type");
2466 /* Reduces a general expression to an initialization expression (a constant).
2467 This used to be part of gfc_match_init_expr.
2468 Note that this function doesn't free the given expression on FAILURE. */
2471 gfc_reduce_init_expr (gfc_expr *expr)
2476 t = gfc_resolve_expr (expr);
2478 t = check_init_expr (expr);
2484 if (expr->expr_type == EXPR_ARRAY)
2486 if (gfc_check_constructor_type (expr) == FAILURE)
2488 if (gfc_expand_constructor (expr) == FAILURE)
2496 /* Match an initialization expression. We work by first matching an
2497 expression, then reducing it to a constant. The reducing it to
2498 constant part requires a global variable to flag the prohibition
2499 of a non-integer exponent in -std=f95 mode. */
2501 bool init_flag = false;
2504 gfc_match_init_expr (gfc_expr **result)
2514 m = gfc_match_expr (&expr);
2521 t = gfc_reduce_init_expr (expr);
2524 gfc_free_expr (expr);
2536 /* Given an actual argument list, test to see that each argument is a
2537 restricted expression and optionally if the expression type is
2538 integer or character. */
2541 restricted_args (gfc_actual_arglist *a)
2543 for (; a; a = a->next)
2545 if (check_restricted (a->expr) == FAILURE)
2553 /************* Restricted/specification expressions *************/
2556 /* Make sure a non-intrinsic function is a specification function. */
2559 external_spec_function (gfc_expr *e)
2563 f = e->value.function.esym;
2565 if (f->attr.proc == PROC_ST_FUNCTION)
2567 gfc_error ("Specification function '%s' at %L cannot be a statement "
2568 "function", f->name, &e->where);
2572 if (f->attr.proc == PROC_INTERNAL)
2574 gfc_error ("Specification function '%s' at %L cannot be an internal "
2575 "function", f->name, &e->where);
2579 if (!f->attr.pure && !f->attr.elemental)
2581 gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2586 if (f->attr.recursive)
2588 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2589 f->name, &e->where);
2593 return restricted_args (e->value.function.actual);
2597 /* Check to see that a function reference to an intrinsic is a
2598 restricted expression. */
2601 restricted_intrinsic (gfc_expr *e)
2603 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2604 if (check_inquiry (e, 0) == MATCH_YES)
2607 return restricted_args (e->value.function.actual);
2611 /* Check the expressions of an actual arglist. Used by check_restricted. */
2614 check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
2616 for (; arg; arg = arg->next)
2617 if (checker (arg->expr) == FAILURE)
2624 /* Check the subscription expressions of a reference chain with a checking
2625 function; used by check_restricted. */
2628 check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
2638 for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2640 if (checker (ref->u.ar.start[dim]) == FAILURE)
2642 if (checker (ref->u.ar.end[dim]) == FAILURE)
2644 if (checker (ref->u.ar.stride[dim]) == FAILURE)
2650 /* Nothing needed, just proceed to next reference. */
2654 if (checker (ref->u.ss.start) == FAILURE)
2656 if (checker (ref->u.ss.end) == FAILURE)
2665 return check_references (ref->next, checker);
2669 /* Verify that an expression is a restricted expression. Like its
2670 cousin check_init_expr(), an error message is generated if we
2674 check_restricted (gfc_expr *e)
2682 switch (e->expr_type)
2685 t = check_intrinsic_op (e, check_restricted);
2687 t = gfc_simplify_expr (e, 0);
2692 if (e->value.function.esym)
2694 t = check_arglist (e->value.function.actual, &check_restricted);
2696 t = external_spec_function (e);
2700 if (e->value.function.isym && e->value.function.isym->inquiry)
2703 t = check_arglist (e->value.function.actual, &check_restricted);
2706 t = restricted_intrinsic (e);
2711 sym = e->symtree->n.sym;
2714 /* If a dummy argument appears in a context that is valid for a
2715 restricted expression in an elemental procedure, it will have
2716 already been simplified away once we get here. Therefore we
2717 don't need to jump through hoops to distinguish valid from
2719 if (sym->attr.dummy && sym->ns == gfc_current_ns
2720 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2722 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2723 sym->name, &e->where);
2727 if (sym->attr.optional)
2729 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2730 sym->name, &e->where);
2734 if (sym->attr.intent == INTENT_OUT)
2736 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2737 sym->name, &e->where);
2741 /* Check reference chain if any. */
2742 if (check_references (e->ref, &check_restricted) == FAILURE)
2745 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2746 processed in resolve.c(resolve_formal_arglist). This is done so
2747 that host associated dummy array indices are accepted (PR23446).
2748 This mechanism also does the same for the specification expressions
2749 of array-valued functions. */
2751 || sym->attr.in_common
2752 || sym->attr.use_assoc
2754 || sym->attr.implied_index
2755 || sym->attr.flavor == FL_PARAMETER
2756 || (sym->ns && sym->ns == gfc_current_ns->parent)
2757 || (sym->ns && gfc_current_ns->parent
2758 && sym->ns == gfc_current_ns->parent->parent)
2759 || (sym->ns->proc_name != NULL
2760 && sym->ns->proc_name->attr.flavor == FL_MODULE)
2761 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2767 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2768 sym->name, &e->where);
2769 /* Prevent a repetition of the error. */
2778 case EXPR_SUBSTRING:
2779 t = gfc_specification_expr (e->ref->u.ss.start);
2783 t = gfc_specification_expr (e->ref->u.ss.end);
2785 t = gfc_simplify_expr (e, 0);
2789 case EXPR_STRUCTURE:
2790 t = gfc_check_constructor (e, check_restricted);
2794 t = gfc_check_constructor (e, check_restricted);
2798 gfc_internal_error ("check_restricted(): Unknown expression type");
2805 /* Check to see that an expression is a specification expression. If
2806 we return FAILURE, an error has been generated. */
2809 gfc_specification_expr (gfc_expr *e)
2815 if (e->ts.type != BT_INTEGER)
2817 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2818 &e->where, gfc_basic_typename (e->ts.type));
2822 if (e->expr_type == EXPR_FUNCTION
2823 && !e->value.function.isym
2824 && !e->value.function.esym
2825 && !gfc_pure (e->symtree->n.sym))
2827 gfc_error ("Function '%s' at %L must be PURE",
2828 e->symtree->n.sym->name, &e->where);
2829 /* Prevent repeat error messages. */
2830 e->symtree->n.sym->attr.pure = 1;
2836 gfc_error ("Expression at %L must be scalar", &e->where);
2840 if (gfc_simplify_expr (e, 0) == FAILURE)
2843 return check_restricted (e);
2847 /************** Expression conformance checks. *************/
2849 /* Given two expressions, make sure that the arrays are conformable. */
2852 gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
2854 int op1_flag, op2_flag, d;
2855 mpz_t op1_size, op2_size;
2861 if (op1->rank == 0 || op2->rank == 0)
2864 va_start (argp, optype_msgid);
2865 vsnprintf (buffer, 240, optype_msgid, argp);
2868 if (op1->rank != op2->rank)
2870 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
2871 op1->rank, op2->rank, &op1->where);
2877 for (d = 0; d < op1->rank; d++)
2879 op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
2880 op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
2882 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
2884 gfc_error ("Different shape for %s at %L on dimension %d "
2885 "(%d and %d)", _(buffer), &op1->where, d + 1,
2886 (int) mpz_get_si (op1_size),
2887 (int) mpz_get_si (op2_size));
2893 mpz_clear (op1_size);
2895 mpz_clear (op2_size);
2905 /* Given an assignable expression and an arbitrary expression, make
2906 sure that the assignment can take place. */
2909 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
2915 sym = lvalue->symtree->n.sym;
2917 /* Check INTENT(IN), unless the object itself is the component or
2918 sub-component of a pointer. */
2919 has_pointer = sym->attr.pointer;
2921 for (ref = lvalue->ref; ref; ref = ref->next)
2922 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
2928 if (!has_pointer && sym->attr.intent == INTENT_IN)
2930 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2931 sym->name, &lvalue->where);
2935 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2936 variable local to a function subprogram. Its existence begins when
2937 execution of the function is initiated and ends when execution of the
2938 function is terminated...
2939 Therefore, the left hand side is no longer a variable, when it is: */
2940 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
2941 && !sym->attr.external)
2946 /* (i) Use associated; */
2947 if (sym->attr.use_assoc)
2950 /* (ii) The assignment is in the main program; or */
2951 if (gfc_current_ns->proc_name->attr.is_main_program)
2954 /* (iii) A module or internal procedure... */
2955 if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
2956 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
2957 && gfc_current_ns->parent
2958 && (!(gfc_current_ns->parent->proc_name->attr.function
2959 || gfc_current_ns->parent->proc_name->attr.subroutine)
2960 || gfc_current_ns->parent->proc_name->attr.is_main_program))
2962 /* ... that is not a function... */
2963 if (!gfc_current_ns->proc_name->attr.function)
2966 /* ... or is not an entry and has a different name. */
2967 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
2971 /* (iv) Host associated and not the function symbol or the
2972 parent result. This picks up sibling references, which
2973 cannot be entries. */
2974 if (!sym->attr.entry
2975 && sym->ns == gfc_current_ns->parent
2976 && sym != gfc_current_ns->proc_name
2977 && sym != gfc_current_ns->parent->proc_name->result)
2982 gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
2987 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
2989 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2990 lvalue->rank, rvalue->rank, &lvalue->where);
2994 if (lvalue->ts.type == BT_UNKNOWN)
2996 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3001 if (rvalue->expr_type == EXPR_NULL)
3003 if (has_pointer && (ref == NULL || ref->next == NULL)
3004 && lvalue->symtree->n.sym->attr.data)
3008 gfc_error ("NULL appears on right-hand side in assignment at %L",
3014 /* This is possibly a typo: x = f() instead of x => f(). */
3015 if (gfc_option.warn_surprising
3016 && rvalue->expr_type == EXPR_FUNCTION
3017 && rvalue->symtree->n.sym->attr.pointer)
3018 gfc_warning ("POINTER valued function appears on right-hand side of "
3019 "assignment at %L", &rvalue->where);
3021 /* Check size of array assignments. */
3022 if (lvalue->rank != 0 && rvalue->rank != 0
3023 && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
3026 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
3027 && lvalue->symtree->n.sym->attr.data
3028 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
3029 "initialize non-integer variable '%s'",
3030 &rvalue->where, lvalue->symtree->n.sym->name)
3033 else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
3034 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
3035 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3036 &rvalue->where) == FAILURE)
3039 /* Handle the case of a BOZ literal on the RHS. */
3040 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
3043 if (gfc_option.warn_surprising)
3044 gfc_warning ("BOZ literal at %L is bitwise transferred "
3045 "non-integer symbol '%s'", &rvalue->where,
3046 lvalue->symtree->n.sym->name);
3047 if (!gfc_convert_boz (rvalue, &lvalue->ts))
3049 if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
3051 if (rc == ARITH_UNDERFLOW)
3052 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3053 ". This check can be disabled with the option "
3054 "-fno-range-check", &rvalue->where);
3055 else if (rc == ARITH_OVERFLOW)
3056 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3057 ". This check can be disabled with the option "
3058 "-fno-range-check", &rvalue->where);
3059 else if (rc == ARITH_NAN)
3060 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3061 ". This check can be disabled with the option "
3062 "-fno-range-check", &rvalue->where);
3067 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
3070 /* Only DATA Statements come here. */
3073 /* Numeric can be converted to any other numeric. And Hollerith can be
3074 converted to any other type. */
3075 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3076 || rvalue->ts.type == BT_HOLLERITH)
3079 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3082 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3083 "conversion of %s to %s", &lvalue->where,
3084 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3089 /* Assignment is the only case where character variables of different
3090 kind values can be converted into one another. */
3091 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3093 if (lvalue->ts.kind != rvalue->ts.kind)
3094 gfc_convert_chartype (rvalue, &lvalue->ts);
3099 return gfc_convert_type (rvalue, &lvalue->ts, 1);
3103 /* Check that a pointer assignment is OK. We first check lvalue, and
3104 we only check rvalue if it's not an assignment to NULL() or a
3105 NULLIFY statement. */
3108 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3110 symbol_attribute attr;
3113 int pointer, check_intent_in, proc_pointer;
3115 if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3116 && !lvalue->symtree->n.sym->attr.proc_pointer)
3118 gfc_error ("Pointer assignment target is not a POINTER at %L",
3123 if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3124 && lvalue->symtree->n.sym->attr.use_assoc
3125 && !lvalue->symtree->n.sym->attr.proc_pointer)
3127 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3128 "l-value since it is a procedure",
3129 lvalue->symtree->n.sym->name, &lvalue->where);
3134 /* Check INTENT(IN), unless the object itself is the component or
3135 sub-component of a pointer. */
3136 check_intent_in = 1;
3137 pointer = lvalue->symtree->n.sym->attr.pointer;
3138 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3140 for (ref = lvalue->ref; ref; ref = ref->next)
3143 check_intent_in = 0;
3145 if (ref->type == REF_COMPONENT)
3147 pointer = ref->u.c.component->attr.pointer;
3148 proc_pointer = ref->u.c.component->attr.proc_pointer;
3151 if (ref->type == REF_ARRAY && ref->next == NULL)
3153 if (ref->u.ar.type == AR_FULL)
3156 if (ref->u.ar.type != AR_SECTION)
3158 gfc_error ("Expected bounds specification for '%s' at %L",
3159 lvalue->symtree->n.sym->name, &lvalue->where);
3163 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3164 "specification for '%s' in pointer assignment "
3165 "at %L", lvalue->symtree->n.sym->name,
3166 &lvalue->where) == FAILURE)
3169 gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3170 "in gfortran", &lvalue->where);
3171 /* TODO: See PR 29785. Add checks that all lbounds are specified and
3172 either never or always the upper-bound; strides shall not be
3178 if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
3180 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3181 lvalue->symtree->n.sym->name, &lvalue->where);
3185 if (!pointer && !proc_pointer
3186 && !(lvalue->ts.type == BT_CLASS
3187 && lvalue->ts.u.derived->components->attr.pointer))
3189 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
3193 is_pure = gfc_pure (NULL);
3195 if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
3196 && lvalue->symtree->n.sym->value != rvalue)
3198 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
3202 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3203 kind, etc for lvalue and rvalue must match, and rvalue must be a
3204 pure variable if we're in a pure function. */
3205 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3208 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3209 if (lvalue->expr_type == EXPR_VARIABLE
3210 && gfc_is_coindexed (lvalue))
3213 for (ref = lvalue->ref; ref; ref = ref->next)
3214 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3216 gfc_error ("Pointer object at %L shall not have a coindex",
3222 /* Checks on rvalue for procedure pointer assignments. */
3227 gfc_component *comp;
3230 attr = gfc_expr_attr (rvalue);
3231 if (!((rvalue->expr_type == EXPR_NULL)
3232 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3233 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
3234 || (rvalue->expr_type == EXPR_VARIABLE
3235 && attr.flavor == FL_PROCEDURE)))
3237 gfc_error ("Invalid procedure pointer assignment at %L",
3243 gfc_error ("Abstract interface '%s' is invalid "
3244 "in procedure pointer assignment at %L",
3245 rvalue->symtree->name, &rvalue->where);
3248 /* Check for C727. */
3249 if (attr.flavor == FL_PROCEDURE)
3251 if (attr.proc == PROC_ST_FUNCTION)
3253 gfc_error ("Statement function '%s' is invalid "
3254 "in procedure pointer assignment at %L",
3255 rvalue->symtree->name, &rvalue->where);
3258 if (attr.proc == PROC_INTERNAL &&
3259 gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
3260 "invalid in procedure pointer assignment at %L",
3261 rvalue->symtree->name, &rvalue->where) == FAILURE)
3265 /* Ensure that the calling convention is the same. As other attributes
3266 such as DLLEXPORT may differ, one explicitly only tests for the
3267 calling conventions. */
3268 if (rvalue->expr_type == EXPR_VARIABLE
3269 && lvalue->symtree->n.sym->attr.ext_attr
3270 != rvalue->symtree->n.sym->attr.ext_attr)
3272 symbol_attribute calls;
3275 gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
3276 gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
3277 gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
3279 if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
3280 != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
3282 gfc_error ("Mismatch in the procedure pointer assignment "
3283 "at %L: mismatch in the calling convention",
3289 if (gfc_is_proc_ptr_comp (lvalue, &comp))
3290 s1 = comp->ts.interface;
3292 s1 = lvalue->symtree->n.sym;
3294 if (gfc_is_proc_ptr_comp (rvalue, &comp))
3296 s2 = comp->ts.interface;
3299 else if (rvalue->expr_type == EXPR_FUNCTION)
3301 s2 = rvalue->symtree->n.sym->result;
3302 name = rvalue->symtree->n.sym->result->name;
3306 s2 = rvalue->symtree->n.sym;
3307 name = rvalue->symtree->n.sym->name;
3310 if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
3313 gfc_error ("Interface mismatch in procedure pointer assignment "
3314 "at %L: %s", &rvalue->where, err);
3321 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3323 gfc_error ("Different types in pointer assignment at %L; attempted "
3324 "assignment of %s to %s", &lvalue->where,
3325 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3329 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
3331 gfc_error ("Different kind type parameters in pointer "
3332 "assignment at %L", &lvalue->where);
3336 if (lvalue->rank != rvalue->rank)
3338 gfc_error ("Different ranks in pointer assignment at %L",
3343 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3344 if (rvalue->expr_type == EXPR_NULL)
3347 if (lvalue->ts.type == BT_CHARACTER)
3349 gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3354 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3355 lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3357 attr = gfc_expr_attr (rvalue);
3358 if (!attr.target && !attr.pointer)
3360 gfc_error ("Pointer assignment target is neither TARGET "
3361 "nor POINTER at %L", &rvalue->where);
3365 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3367 gfc_error ("Bad target in pointer assignment in PURE "
3368 "procedure at %L", &rvalue->where);
3371 if (gfc_has_vector_index (rvalue))
3373 gfc_error ("Pointer assignment with vector subscript "
3374 "on rhs at %L", &rvalue->where);
3378 if (attr.is_protected && attr.use_assoc
3379 && !(attr.pointer || attr.proc_pointer))
3381 gfc_error ("Pointer assignment target has PROTECTED "
3382 "attribute at %L", &rvalue->where);
3386 /* F2008, C725. For PURE also C1283. */
3387 if (rvalue->expr_type == EXPR_VARIABLE
3388 && gfc_is_coindexed (rvalue))
3391 for (ref = rvalue->ref; ref; ref = ref->next)
3392 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3394 gfc_error ("Data target at %L shall not have a coindex",
3404 /* Relative of gfc_check_assign() except that the lvalue is a single
3405 symbol. Used for initialization assignments. */
3408 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3413 memset (&lvalue, '\0', sizeof (gfc_expr));
3415 lvalue.expr_type = EXPR_VARIABLE;
3416 lvalue.ts = sym->ts;
3418 lvalue.rank = sym->as->rank;
3419 lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3420 lvalue.symtree->n.sym = sym;
3421 lvalue.where = sym->declared_at;
3423 if (sym->attr.pointer || sym->attr.proc_pointer
3424 || (sym->ts.type == BT_CLASS
3425 && sym->ts.u.derived->components->attr.pointer
3426 && rvalue->expr_type == EXPR_NULL))
3427 r = gfc_check_pointer_assign (&lvalue, rvalue);
3429 r = gfc_check_assign (&lvalue, rvalue, 1);
3431 gfc_free (lvalue.symtree);
3437 /* Get an expression for a default initializer. */
3440 gfc_default_initializer (gfc_typespec *ts)
3442 gfc_constructor *tail;
3446 /* See if we have a default initializer. */
3447 for (c = ts->u.derived->components; c; c = c->next)
3448 if (c->initializer || c->attr.allocatable)
3454 /* Build the constructor. */
3455 init = gfc_get_expr ();
3456 init->expr_type = EXPR_STRUCTURE;
3458 init->where = ts->u.derived->declared_at;
3461 for (c = ts->u.derived->components; c; c = c->next)
3464 init->value.constructor = tail = gfc_get_constructor ();
3467 tail->next = gfc_get_constructor ();
3472 tail->expr = gfc_copy_expr (c->initializer);
3474 if (c->attr.allocatable)
3476 tail->expr = gfc_get_expr ();
3477 tail->expr->expr_type = EXPR_NULL;
3478 tail->expr->ts = c->ts;
3485 /* Given a symbol, create an expression node with that symbol as a
3486 variable. If the symbol is array valued, setup a reference of the
3490 gfc_get_variable_expr (gfc_symtree *var)
3494 e = gfc_get_expr ();
3495 e->expr_type = EXPR_VARIABLE;
3497 e->ts = var->n.sym->ts;
3499 if (var->n.sym->as != NULL)
3501 e->rank = var->n.sym->as->rank;
3502 e->ref = gfc_get_ref ();
3503 e->ref->type = REF_ARRAY;
3504 e->ref->u.ar.type = AR_FULL;
3511 /* Returns the array_spec of a full array expression. A NULL is
3512 returned otherwise. */
3514 gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
3519 if (expr->rank == 0)
3522 /* Follow any component references. */
3523 if (expr->expr_type == EXPR_VARIABLE
3524 || expr->expr_type == EXPR_CONSTANT)
3526 as = expr->symtree->n.sym->as;
3527 for (ref = expr->ref; ref; ref = ref->next)
3532 as = ref->u.c.component->as;
3540 switch (ref->u.ar.type)
3563 /* General expression traversal function. */
3566 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3567 bool (*func)(gfc_expr *, gfc_symbol *, int*),
3572 gfc_actual_arglist *args;
3579 if ((*func) (expr, sym, &f))
3582 if (expr->ts.type == BT_CHARACTER
3584 && expr->ts.u.cl->length
3585 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
3586 && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
3589 switch (expr->expr_type)
3592 for (args = expr->value.function.actual; args; args = args->next)
3594 if (gfc_traverse_expr (args->expr, sym, func, f))
3602 case EXPR_SUBSTRING:
3605 case EXPR_STRUCTURE:
3607 for (c = expr->value.constructor; c; c = c->next)
3609 if (gfc_traverse_expr (c->expr, sym, func, f))
3613 if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3615 if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3617 if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3619 if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3626 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3628 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3644 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3646 if (gfc_traverse_expr (ar.start[i], sym, func, f))
3648 if (gfc_traverse_expr (ar.end[i], sym, func, f))
3650 if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3656 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3658 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3663 if (ref->u.c.component->ts.type == BT_CHARACTER
3664 && ref->u.c.component->ts.u.cl
3665 && ref->u.c.component->ts.u.cl->length
3666 && ref->u.c.component->ts.u.cl->length->expr_type
3668 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
3672 if (ref->u.c.component->as)
3673 for (i = 0; i < ref->u.c.component->as->rank
3674 + ref->u.c.component->as->corank; i++)
3676 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3679 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3693 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3696 expr_set_symbols_referenced (gfc_expr *expr,
3697 gfc_symbol *sym ATTRIBUTE_UNUSED,
3698 int *f ATTRIBUTE_UNUSED)
3700 if (expr->expr_type != EXPR_VARIABLE)
3702 gfc_set_sym_referenced (expr->symtree->n.sym);
3707 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3709 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3713 /* Determine if an expression is a procedure pointer component. If yes, the
3714 argument 'comp' will point to the component (provided that 'comp' was
3718 gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
3723 if (!expr || !expr->ref)
3730 if (ref->type == REF_COMPONENT)
3732 ppc = ref->u.c.component->attr.proc_pointer;
3734 *comp = ref->u.c.component;
3741 /* Walk an expression tree and check each variable encountered for being typed.
3742 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3743 mode as is a basic arithmetic expression using those; this is for things in
3746 INTEGER :: arr(n), n
3747 INTEGER :: arr(n + 1), n
3749 The namespace is needed for IMPLICIT typing. */
3751 static gfc_namespace* check_typed_ns;
3754 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3755 int* f ATTRIBUTE_UNUSED)
3759 if (e->expr_type != EXPR_VARIABLE)
3762 gcc_assert (e->symtree);
3763 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3766 return (t == FAILURE);
3770 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3774 /* If this is a top-level variable or EXPR_OP, do the check with strict given
3778 if (e->expr_type == EXPR_VARIABLE && !e->ref)
3779 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3781 if (e->expr_type == EXPR_OP)
3783 gfc_try t = SUCCESS;
3785 gcc_assert (e->value.op.op1);
3786 t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
3788 if (t == SUCCESS && e->value.op.op2)
3789 t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
3795 /* Otherwise, walk the expression and do it strictly. */
3796 check_typed_ns = ns;
3797 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3799 return error_found ? FAILURE : SUCCESS;
3802 /* Walk an expression tree and replace all symbols with a corresponding symbol
3803 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3804 statements. The boolean return value is required by gfc_traverse_expr. */
3807 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3809 if ((expr->expr_type == EXPR_VARIABLE
3810 || (expr->expr_type == EXPR_FUNCTION
3811 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3812 && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
3815 gfc_namespace *ns = sym->formal_ns;
3816 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3817 the symtree rather than create a new one (and probably fail later). */
3818 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3819 expr->symtree->n.sym->name);
3821 stree->n.sym->attr = expr->symtree->n.sym->attr;
3822 expr->symtree = stree;
3828 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
3830 gfc_traverse_expr (expr, dest, &replace_symbol, 0);
3833 /* The following is analogous to 'replace_symbol', and needed for copying
3834 interfaces for procedure pointer components. The argument 'sym' must formally
3835 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
3836 However, it gets actually passed a gfc_component (i.e. the procedure pointer
3837 component in whose formal_ns the arguments have to be). */
3840 replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3842 gfc_component *comp;
3843 comp = (gfc_component *)sym;
3844 if ((expr->expr_type == EXPR_VARIABLE
3845 || (expr->expr_type == EXPR_FUNCTION
3846 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3847 && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
3850 gfc_namespace *ns = comp->formal_ns;
3851 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3852 the symtree rather than create a new one (and probably fail later). */
3853 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3854 expr->symtree->n.sym->name);
3856 stree->n.sym->attr = expr->symtree->n.sym->attr;
3857 expr->symtree = stree;
3863 gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
3865 gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
3870 gfc_is_coindexed (gfc_expr *e)
3874 for (ref = e->ref; ref; ref = ref->next)
3875 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
3882 /* Check whether the expression has an ultimate allocatable component.
3883 Being itself allocatable does not count. */
3885 gfc_has_ultimate_allocatable (gfc_expr *e)
3887 gfc_ref *ref, *last = NULL;
3889 if (e->expr_type != EXPR_VARIABLE)
3892 for (ref = e->ref; ref; ref = ref->next)
3893 if (ref->type == REF_COMPONENT)
3896 if (last && last->u.c.component->ts.type == BT_CLASS)
3897 return last->u.c.component->ts.u.derived->components->attr.alloc_comp;
3898 else if (last && last->u.c.component->ts.type == BT_DERIVED)
3899 return last->u.c.component->ts.u.derived->attr.alloc_comp;
3903 if (e->ts.type == BT_CLASS)
3904 return e->ts.u.derived->components->attr.alloc_comp;
3905 else if (e->ts.type == BT_DERIVED)
3906 return e->ts.u.derived->attr.alloc_comp;
3912 /* Check whether the expression has an pointer component.
3913 Being itself a pointer does not count. */
3915 gfc_has_ultimate_pointer (gfc_expr *e)
3917 gfc_ref *ref, *last = NULL;
3919 if (e->expr_type != EXPR_VARIABLE)
3922 for (ref = e->ref; ref; ref = ref->next)
3923 if (ref->type == REF_COMPONENT)
3926 if (last && last->u.c.component->ts.type == BT_CLASS)
3927 return last->u.c.component->ts.u.derived->components->attr.pointer_comp;
3928 else if (last && last->u.c.component->ts.type == BT_DERIVED)
3929 return last->u.c.component->ts.u.derived->attr.pointer_comp;
3933 if (e->ts.type == BT_CLASS)
3934 return e->ts.u.derived->components->attr.pointer_comp;
3935 else if (e->ts.type == BT_DERIVED)
3936 return e->ts.u.derived->attr.pointer_comp;