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 mpfr_clear (e->value.complex.r);
160 mpfr_clear (e->value.complex.i);
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 /* Copy a shape array. */
332 gfc_copy_shape (mpz_t *shape, int rank)
340 new_shape = gfc_get_shape (rank);
342 for (n = 0; n < rank; n++)
343 mpz_init_set (new_shape[n], shape[n]);
349 /* Copy a shape array excluding dimension N, where N is an integer
350 constant expression. Dimensions are numbered in fortran style --
353 So, if the original shape array contains R elements
354 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
355 the result contains R-1 elements:
356 { s1 ... sN-1 sN+1 ... sR-1}
358 If anything goes wrong -- N is not a constant, its value is out
359 of range -- or anything else, just returns NULL. */
362 gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
364 mpz_t *new_shape, *s;
370 || dim->expr_type != EXPR_CONSTANT
371 || dim->ts.type != BT_INTEGER)
374 n = mpz_get_si (dim->value.integer);
375 n--; /* Convert to zero based index. */
376 if (n < 0 || n >= rank)
379 s = new_shape = gfc_get_shape (rank - 1);
381 for (i = 0; i < rank; i++)
385 mpz_init_set (*s, shape[i]);
393 /* Given an expression pointer, return a copy of the expression. This
394 subroutine is recursive. */
397 gfc_copy_expr (gfc_expr *p)
409 switch (q->expr_type)
412 s = gfc_get_wide_string (p->value.character.length + 1);
413 q->value.character.string = s;
414 memcpy (s, p->value.character.string,
415 (p->value.character.length + 1) * sizeof (gfc_char_t));
419 /* Copy target representation, if it exists. */
420 if (p->representation.string)
422 c = XCNEWVEC (char, p->representation.length + 1);
423 q->representation.string = c;
424 memcpy (c, p->representation.string, (p->representation.length + 1));
427 /* Copy the values of any pointer components of p->value. */
431 mpz_init_set (q->value.integer, p->value.integer);
435 gfc_set_model_kind (q->ts.kind);
436 mpfr_init (q->value.real);
437 mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
441 gfc_set_model_kind (q->ts.kind);
442 mpfr_init (q->value.complex.r);
443 mpfr_init (q->value.complex.i);
444 mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
445 mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
449 if (p->representation.string)
450 q->value.character.string
451 = gfc_char_to_widechar (q->representation.string);
454 s = gfc_get_wide_string (p->value.character.length + 1);
455 q->value.character.string = s;
457 /* This is the case for the C_NULL_CHAR named constant. */
458 if (p->value.character.length == 0
459 && (p->ts.is_c_interop || p->ts.is_iso_c))
462 /* Need to set the length to 1 to make sure the NUL
463 terminator is copied. */
464 q->value.character.length = 1;
467 memcpy (s, p->value.character.string,
468 (p->value.character.length + 1) * sizeof (gfc_char_t));
475 break; /* Already done. */
479 /* Should never be reached. */
481 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
488 switch (q->value.op.op)
491 case INTRINSIC_PARENTHESES:
492 case INTRINSIC_UPLUS:
493 case INTRINSIC_UMINUS:
494 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
497 default: /* Binary operators. */
498 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
499 q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
506 q->value.function.actual =
507 gfc_copy_actual_arglist (p->value.function.actual);
512 q->value.compcall.actual =
513 gfc_copy_actual_arglist (p->value.compcall.actual);
514 q->value.compcall.tbp = p->value.compcall.tbp;
519 q->value.constructor = gfc_copy_constructor (p->value.constructor);
527 q->shape = gfc_copy_shape (p->shape, p->rank);
529 q->ref = gfc_copy_ref (p->ref);
535 /* Return the maximum kind of two expressions. In general, higher
536 kind numbers mean more precision for numeric types. */
539 gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
541 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
545 /* Returns nonzero if the type is numeric, zero otherwise. */
548 numeric_type (bt type)
550 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
554 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
557 gfc_numeric_ts (gfc_typespec *ts)
559 return numeric_type (ts->type);
563 /* Returns an expression node that is an integer constant. */
572 p->expr_type = EXPR_CONSTANT;
573 p->ts.type = BT_INTEGER;
574 p->ts.kind = gfc_default_integer_kind;
576 p->where = gfc_current_locus;
577 mpz_init_set_si (p->value.integer, i);
583 /* Returns an expression node that is a logical constant. */
586 gfc_logical_expr (int i, locus *where)
592 p->expr_type = EXPR_CONSTANT;
593 p->ts.type = BT_LOGICAL;
594 p->ts.kind = gfc_default_logical_kind;
597 where = &gfc_current_locus;
599 p->value.logical = i;
605 /* Return an expression node with an optional argument list attached.
606 A variable number of gfc_expr pointers are strung together in an
607 argument list with a NULL pointer terminating the list. */
610 gfc_build_conversion (gfc_expr *e)
615 p->expr_type = EXPR_FUNCTION;
617 p->value.function.actual = NULL;
619 p->value.function.actual = gfc_get_actual_arglist ();
620 p->value.function.actual->expr = e;
626 /* Given an expression node with some sort of numeric binary
627 expression, insert type conversions required to make the operands
630 The exception is that the operands of an exponential don't have to
631 have the same type. If possible, the base is promoted to the type
632 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
633 1.0**2 stays as it is. */
636 gfc_type_convert_binary (gfc_expr *e)
640 op1 = e->value.op.op1;
641 op2 = e->value.op.op2;
643 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
645 gfc_clear_ts (&e->ts);
649 /* Kind conversions of same type. */
650 if (op1->ts.type == op2->ts.type)
652 if (op1->ts.kind == op2->ts.kind)
654 /* No type conversions. */
659 if (op1->ts.kind > op2->ts.kind)
660 gfc_convert_type (op2, &op1->ts, 2);
662 gfc_convert_type (op1, &op2->ts, 2);
668 /* Integer combined with real or complex. */
669 if (op2->ts.type == BT_INTEGER)
673 /* Special case for ** operator. */
674 if (e->value.op.op == INTRINSIC_POWER)
677 gfc_convert_type (e->value.op.op2, &e->ts, 2);
681 if (op1->ts.type == BT_INTEGER)
684 gfc_convert_type (e->value.op.op1, &e->ts, 2);
688 /* Real combined with complex. */
689 e->ts.type = BT_COMPLEX;
690 if (op1->ts.kind > op2->ts.kind)
691 e->ts.kind = op1->ts.kind;
693 e->ts.kind = op2->ts.kind;
694 if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
695 gfc_convert_type (e->value.op.op1, &e->ts, 2);
696 if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
697 gfc_convert_type (e->value.op.op2, &e->ts, 2);
705 check_specification_function (gfc_expr *e)
712 sym = e->symtree->n.sym;
714 /* F95, 7.1.6.2; F2003, 7.1.7 */
716 && sym->attr.function
718 && !sym->attr.intrinsic
719 && !sym->attr.recursive
720 && sym->attr.proc != PROC_INTERNAL
721 && sym->attr.proc != PROC_ST_FUNCTION
722 && sym->attr.proc != PROC_UNKNOWN
723 && sym->formal == NULL)
729 /* Function to determine if an expression is constant or not. This
730 function expects that the expression has already been simplified. */
733 gfc_is_constant_expr (gfc_expr *e)
736 gfc_actual_arglist *arg;
742 switch (e->expr_type)
745 rv = (gfc_is_constant_expr (e->value.op.op1)
746 && (e->value.op.op2 == NULL
747 || gfc_is_constant_expr (e->value.op.op2)));
755 /* Specification functions are constant. */
756 if (check_specification_function (e) == MATCH_YES)
762 /* Call to intrinsic with at least one argument. */
764 if (e->value.function.isym && e->value.function.actual)
766 for (arg = e->value.function.actual; arg; arg = arg->next)
768 if (!gfc_is_constant_expr (arg->expr))
782 rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
783 && gfc_is_constant_expr (e->ref->u.ss.end));
788 for (c = e->value.constructor; c; c = c->next)
789 if (!gfc_is_constant_expr (c->expr))
797 rv = gfc_constant_ac (e);
801 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
808 /* Is true if an array reference is followed by a component or substring
811 is_subref_array (gfc_expr * e)
816 if (e->expr_type != EXPR_VARIABLE)
819 if (e->symtree->n.sym->attr.subref_array_pointer)
823 for (ref = e->ref; ref; ref = ref->next)
825 if (ref->type == REF_ARRAY
826 && ref->u.ar.type != AR_ELEMENT)
830 && ref->type != REF_ARRAY)
837 /* Try to collapse intrinsic expressions. */
840 simplify_intrinsic_op (gfc_expr *p, int type)
843 gfc_expr *op1, *op2, *result;
845 if (p->value.op.op == INTRINSIC_USER)
848 op1 = p->value.op.op1;
849 op2 = p->value.op.op2;
852 if (gfc_simplify_expr (op1, type) == FAILURE)
854 if (gfc_simplify_expr (op2, type) == FAILURE)
857 if (!gfc_is_constant_expr (op1)
858 || (op2 != NULL && !gfc_is_constant_expr (op2)))
862 p->value.op.op1 = NULL;
863 p->value.op.op2 = NULL;
867 case INTRINSIC_PARENTHESES:
868 result = gfc_parentheses (op1);
871 case INTRINSIC_UPLUS:
872 result = gfc_uplus (op1);
875 case INTRINSIC_UMINUS:
876 result = gfc_uminus (op1);
880 result = gfc_add (op1, op2);
883 case INTRINSIC_MINUS:
884 result = gfc_subtract (op1, op2);
887 case INTRINSIC_TIMES:
888 result = gfc_multiply (op1, op2);
891 case INTRINSIC_DIVIDE:
892 result = gfc_divide (op1, op2);
895 case INTRINSIC_POWER:
896 result = gfc_power (op1, op2);
899 case INTRINSIC_CONCAT:
900 result = gfc_concat (op1, op2);
904 case INTRINSIC_EQ_OS:
905 result = gfc_eq (op1, op2, op);
909 case INTRINSIC_NE_OS:
910 result = gfc_ne (op1, op2, op);
914 case INTRINSIC_GT_OS:
915 result = gfc_gt (op1, op2, op);
919 case INTRINSIC_GE_OS:
920 result = gfc_ge (op1, op2, op);
924 case INTRINSIC_LT_OS:
925 result = gfc_lt (op1, op2, op);
929 case INTRINSIC_LE_OS:
930 result = gfc_le (op1, op2, op);
934 result = gfc_not (op1);
938 result = gfc_and (op1, op2);
942 result = gfc_or (op1, op2);
946 result = gfc_eqv (op1, op2);
950 result = gfc_neqv (op1, op2);
954 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
964 result->rank = p->rank;
965 result->where = p->where;
966 gfc_replace_expr (p, result);
972 /* Subroutine to simplify constructor expressions. Mutually recursive
973 with gfc_simplify_expr(). */
976 simplify_constructor (gfc_constructor *c, int type)
980 for (; c; c = c->next)
983 && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
984 || gfc_simplify_expr (c->iterator->end, type) == FAILURE
985 || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
990 /* Try and simplify a copy. Replace the original if successful
991 but keep going through the constructor at all costs. Not
992 doing so can make a dog's dinner of complicated things. */
993 p = gfc_copy_expr (c->expr);
995 if (gfc_simplify_expr (p, type) == FAILURE)
1001 gfc_replace_expr (c->expr, p);
1009 /* Pull a single array element out of an array constructor. */
1012 find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
1013 gfc_constructor **rval)
1015 unsigned long nelemen;
1027 mpz_init_set_ui (offset, 0);
1030 mpz_init_set_ui (span, 1);
1031 for (i = 0; i < ar->dimen; i++)
1033 if (gfc_reduce_init_expr (ar->as->lower[i]) == FAILURE
1034 || gfc_reduce_init_expr (ar->as->upper[i]) == FAILURE)
1041 e = gfc_copy_expr (ar->start[i]);
1042 if (e->expr_type != EXPR_CONSTANT)
1048 gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
1049 && ar->as->lower[i]->expr_type == EXPR_CONSTANT);
1051 /* Check the bounds. */
1052 if ((ar->as->upper[i]
1053 && mpz_cmp (e->value.integer,
1054 ar->as->upper[i]->value.integer) > 0)
1055 || (mpz_cmp (e->value.integer,
1056 ar->as->lower[i]->value.integer) < 0))
1058 gfc_error ("Index in dimension %d is out of bounds "
1059 "at %L", i + 1, &ar->c_where[i]);
1065 mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1066 mpz_mul (delta, delta, span);
1067 mpz_add (offset, offset, delta);
1069 mpz_set_ui (tmp, 1);
1070 mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1071 mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1072 mpz_mul (span, span, tmp);
1075 for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
1100 /* Find a component of a structure constructor. */
1102 static gfc_constructor *
1103 find_component_ref (gfc_constructor *cons, gfc_ref *ref)
1105 gfc_component *comp;
1106 gfc_component *pick;
1108 comp = ref->u.c.sym->components;
1109 pick = ref->u.c.component;
1110 while (comp != pick)
1120 /* Replace an expression with the contents of a constructor, removing
1121 the subobject reference in the process. */
1124 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1130 e->ref = p->ref->next;
1131 p->ref->next = NULL;
1132 gfc_replace_expr (p, e);
1136 /* Pull an array section out of an array constructor. */
1139 find_array_section (gfc_expr *expr, gfc_ref *ref)
1145 long unsigned one = 1;
1147 mpz_t start[GFC_MAX_DIMENSIONS];
1148 mpz_t end[GFC_MAX_DIMENSIONS];
1149 mpz_t stride[GFC_MAX_DIMENSIONS];
1150 mpz_t delta[GFC_MAX_DIMENSIONS];
1151 mpz_t ctr[GFC_MAX_DIMENSIONS];
1157 gfc_constructor *cons;
1158 gfc_constructor *base;
1164 gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
1169 base = expr->value.constructor;
1170 expr->value.constructor = NULL;
1172 rank = ref->u.ar.as->rank;
1174 if (expr->shape == NULL)
1175 expr->shape = gfc_get_shape (rank);
1177 mpz_init_set_ui (delta_mpz, one);
1178 mpz_init_set_ui (nelts, one);
1181 /* Do the initialization now, so that we can cleanup without
1182 keeping track of where we were. */
1183 for (d = 0; d < rank; d++)
1185 mpz_init (delta[d]);
1186 mpz_init (start[d]);
1189 mpz_init (stride[d]);
1193 /* Build the counters to clock through the array reference. */
1195 for (d = 0; d < rank; d++)
1197 /* Make this stretch of code easier on the eye! */
1198 begin = ref->u.ar.start[d];
1199 finish = ref->u.ar.end[d];
1200 step = ref->u.ar.stride[d];
1201 lower = ref->u.ar.as->lower[d];
1202 upper = ref->u.ar.as->upper[d];
1204 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1208 if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1214 gcc_assert (begin->rank == 1);
1215 /* Zero-sized arrays have no shape and no elements, stop early. */
1218 mpz_init_set_ui (nelts, 0);
1222 vecsub[d] = begin->value.constructor;
1223 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1224 mpz_mul (nelts, nelts, begin->shape[0]);
1225 mpz_set (expr->shape[shape_i++], begin->shape[0]);
1228 for (c = vecsub[d]; c; c = c->next)
1230 if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
1231 || mpz_cmp (c->expr->value.integer,
1232 lower->value.integer) < 0)
1234 gfc_error ("index in dimension %d is out of bounds "
1235 "at %L", d + 1, &ref->u.ar.c_where[d]);
1243 if ((begin && begin->expr_type != EXPR_CONSTANT)
1244 || (finish && finish->expr_type != EXPR_CONSTANT)
1245 || (step && step->expr_type != EXPR_CONSTANT))
1251 /* Obtain the stride. */
1253 mpz_set (stride[d], step->value.integer);
1255 mpz_set_ui (stride[d], one);
1257 if (mpz_cmp_ui (stride[d], 0) == 0)
1258 mpz_set_ui (stride[d], one);
1260 /* Obtain the start value for the index. */
1262 mpz_set (start[d], begin->value.integer);
1264 mpz_set (start[d], lower->value.integer);
1266 mpz_set (ctr[d], start[d]);
1268 /* Obtain the end value for the index. */
1270 mpz_set (end[d], finish->value.integer);
1272 mpz_set (end[d], upper->value.integer);
1274 /* Separate 'if' because elements sometimes arrive with
1276 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1277 mpz_set (end [d], begin->value.integer);
1279 /* Check the bounds. */
1280 if (mpz_cmp (ctr[d], upper->value.integer) > 0
1281 || mpz_cmp (end[d], upper->value.integer) > 0
1282 || mpz_cmp (ctr[d], lower->value.integer) < 0
1283 || mpz_cmp (end[d], lower->value.integer) < 0)
1285 gfc_error ("index in dimension %d is out of bounds "
1286 "at %L", d + 1, &ref->u.ar.c_where[d]);
1291 /* Calculate the number of elements and the shape. */
1292 mpz_set (tmp_mpz, stride[d]);
1293 mpz_add (tmp_mpz, end[d], tmp_mpz);
1294 mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1295 mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1296 mpz_mul (nelts, nelts, tmp_mpz);
1298 /* An element reference reduces the rank of the expression; don't
1299 add anything to the shape array. */
1300 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1301 mpz_set (expr->shape[shape_i++], tmp_mpz);
1304 /* Calculate the 'stride' (=delta) for conversion of the
1305 counter values into the index along the constructor. */
1306 mpz_set (delta[d], delta_mpz);
1307 mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1308 mpz_add_ui (tmp_mpz, tmp_mpz, one);
1309 mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1316 /* Now clock through the array reference, calculating the index in
1317 the source constructor and transferring the elements to the new
1319 for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1321 if (ref->u.ar.offset)
1322 mpz_set (ptr, ref->u.ar.offset->value.integer);
1324 mpz_init_set_ui (ptr, 0);
1327 for (d = 0; d < rank; d++)
1329 mpz_set (tmp_mpz, ctr[d]);
1330 mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1331 mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1332 mpz_add (ptr, ptr, tmp_mpz);
1334 if (!incr_ctr) continue;
1336 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1338 gcc_assert(vecsub[d]);
1340 if (!vecsub[d]->next)
1341 vecsub[d] = ref->u.ar.start[d]->value.constructor;
1344 vecsub[d] = vecsub[d]->next;
1347 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1351 mpz_add (ctr[d], ctr[d], stride[d]);
1353 if (mpz_cmp_ui (stride[d], 0) > 0
1354 ? mpz_cmp (ctr[d], end[d]) > 0
1355 : mpz_cmp (ctr[d], end[d]) < 0)
1356 mpz_set (ctr[d], start[d]);
1362 /* There must be a better way of dealing with negative strides
1363 than resetting the index and the constructor pointer! */
1364 if (mpz_cmp (ptr, index) < 0)
1366 mpz_set_ui (index, 0);
1370 while (cons && cons->next && mpz_cmp (ptr, index) > 0)
1372 mpz_add_ui (index, index, one);
1376 gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
1384 mpz_clear (delta_mpz);
1385 mpz_clear (tmp_mpz);
1387 for (d = 0; d < rank; d++)
1389 mpz_clear (delta[d]);
1390 mpz_clear (start[d]);
1393 mpz_clear (stride[d]);
1395 gfc_free_constructor (base);
1399 /* Pull a substring out of an expression. */
1402 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1409 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1410 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1413 *newp = gfc_copy_expr (p);
1414 gfc_free ((*newp)->value.character.string);
1416 end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1417 start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1418 length = end - start + 1;
1420 chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1421 (*newp)->value.character.length = length;
1422 memcpy (chr, &p->value.character.string[start - 1],
1423 length * sizeof (gfc_char_t));
1430 /* Simplify a subobject reference of a constructor. This occurs when
1431 parameter variable values are substituted. */
1434 simplify_const_ref (gfc_expr *p)
1436 gfc_constructor *cons;
1441 switch (p->ref->type)
1444 switch (p->ref->u.ar.type)
1447 if (find_array_element (p->value.constructor, &p->ref->u.ar,
1454 remove_subobject_ref (p, cons);
1458 if (find_array_section (p, p->ref) == FAILURE)
1460 p->ref->u.ar.type = AR_FULL;
1465 if (p->ref->next != NULL
1466 && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1468 cons = p->value.constructor;
1469 for (; cons; cons = cons->next)
1471 cons->expr->ref = gfc_copy_ref (p->ref->next);
1472 if (simplify_const_ref (cons->expr) == FAILURE)
1476 /* If this is a CHARACTER array and we possibly took a
1477 substring out of it, update the type-spec's character
1478 length according to the first element (as all should have
1479 the same length). */
1480 if (p->ts.type == BT_CHARACTER)
1484 gcc_assert (p->ref->next);
1485 gcc_assert (!p->ref->next->next);
1486 gcc_assert (p->ref->next->type == REF_SUBSTRING);
1488 if (p->value.constructor)
1490 const gfc_expr* first = p->value.constructor->expr;
1491 gcc_assert (first->expr_type == EXPR_CONSTANT);
1492 gcc_assert (first->ts.type == BT_CHARACTER);
1493 string_len = first->value.character.length;
1500 p->ts.cl = gfc_get_charlen ();
1501 p->ts.cl->next = NULL;
1502 p->ts.cl->length = NULL;
1504 gfc_free_expr (p->ts.cl->length);
1505 p->ts.cl->length = gfc_int_expr (string_len);
1508 gfc_free_ref_list (p->ref);
1519 cons = find_component_ref (p->value.constructor, p->ref);
1520 remove_subobject_ref (p, cons);
1524 if (find_substring_ref (p, &newp) == FAILURE)
1527 gfc_replace_expr (p, newp);
1528 gfc_free_ref_list (p->ref);
1538 /* Simplify a chain of references. */
1541 simplify_ref_chain (gfc_ref *ref, int type)
1545 for (; ref; ref = ref->next)
1550 for (n = 0; n < ref->u.ar.dimen; n++)
1552 if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1554 if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1556 if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1562 if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1564 if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1576 /* Try to substitute the value of a parameter variable. */
1579 simplify_parameter_variable (gfc_expr *p, int type)
1584 e = gfc_copy_expr (p->symtree->n.sym->value);
1590 /* Do not copy subobject refs for constant. */
1591 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1592 e->ref = gfc_copy_ref (p->ref);
1593 t = gfc_simplify_expr (e, type);
1595 /* Only use the simplification if it eliminated all subobject references. */
1596 if (t == SUCCESS && !e->ref)
1597 gfc_replace_expr (p, e);
1604 /* Given an expression, simplify it by collapsing constant
1605 expressions. Most simplification takes place when the expression
1606 tree is being constructed. If an intrinsic function is simplified
1607 at some point, we get called again to collapse the result against
1610 We work by recursively simplifying expression nodes, simplifying
1611 intrinsic functions where possible, which can lead to further
1612 constant collapsing. If an operator has constant operand(s), we
1613 rip the expression apart, and rebuild it, hoping that it becomes
1616 The expression type is defined for:
1617 0 Basic expression parsing
1618 1 Simplifying array constructors -- will substitute
1620 Returns FAILURE on error, SUCCESS otherwise.
1621 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1624 gfc_simplify_expr (gfc_expr *p, int type)
1626 gfc_actual_arglist *ap;
1631 switch (p->expr_type)
1638 for (ap = p->value.function.actual; ap; ap = ap->next)
1639 if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1642 if (p->value.function.isym != NULL
1643 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1648 case EXPR_SUBSTRING:
1649 if (simplify_ref_chain (p->ref, type) == FAILURE)
1652 if (gfc_is_constant_expr (p))
1657 if (p->ref && p->ref->u.ss.start)
1659 gfc_extract_int (p->ref->u.ss.start, &start);
1660 start--; /* Convert from one-based to zero-based. */
1665 if (p->ref && p->ref->u.ss.end)
1666 gfc_extract_int (p->ref->u.ss.end, &end);
1668 end = p->value.character.length;
1670 s = gfc_get_wide_string (end - start + 2);
1671 memcpy (s, p->value.character.string + start,
1672 (end - start) * sizeof (gfc_char_t));
1673 s[end - start + 1] = '\0'; /* TODO: C-style string. */
1674 gfc_free (p->value.character.string);
1675 p->value.character.string = s;
1676 p->value.character.length = end - start;
1677 p->ts.cl = gfc_get_charlen ();
1678 p->ts.cl->next = gfc_current_ns->cl_list;
1679 gfc_current_ns->cl_list = p->ts.cl;
1680 p->ts.cl->length = gfc_int_expr (p->value.character.length);
1681 gfc_free_ref_list (p->ref);
1683 p->expr_type = EXPR_CONSTANT;
1688 if (simplify_intrinsic_op (p, type) == FAILURE)
1693 /* Only substitute array parameter variables if we are in an
1694 initialization expression, or we want a subsection. */
1695 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1696 && (gfc_init_expr || p->ref
1697 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1699 if (simplify_parameter_variable (p, type) == FAILURE)
1706 gfc_simplify_iterator_var (p);
1709 /* Simplify subcomponent references. */
1710 if (simplify_ref_chain (p->ref, type) == FAILURE)
1715 case EXPR_STRUCTURE:
1717 if (simplify_ref_chain (p->ref, type) == FAILURE)
1720 if (simplify_constructor (p->value.constructor, type) == FAILURE)
1723 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1724 && p->ref->u.ar.type == AR_FULL)
1725 gfc_expand_constructor (p);
1727 if (simplify_const_ref (p) == FAILURE)
1742 /* Returns the type of an expression with the exception that iterator
1743 variables are automatically integers no matter what else they may
1749 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1756 /* Check an intrinsic arithmetic operation to see if it is consistent
1757 with some type of expression. */
1759 static gfc_try check_init_expr (gfc_expr *);
1762 /* Scalarize an expression for an elemental intrinsic call. */
1765 scalarize_intrinsic_call (gfc_expr *e)
1767 gfc_actual_arglist *a, *b;
1768 gfc_constructor *args[5], *ctor, *new_ctor;
1769 gfc_expr *expr, *old;
1770 int n, i, rank[5], array_arg;
1772 /* Find which, if any, arguments are arrays. Assume that the old
1773 expression carries the type information and that the first arg
1774 that is an array expression carries all the shape information.*/
1776 a = e->value.function.actual;
1777 for (; a; a = a->next)
1780 if (a->expr->expr_type != EXPR_ARRAY)
1783 expr = gfc_copy_expr (a->expr);
1790 old = gfc_copy_expr (e);
1792 gfc_free_constructor (expr->value.constructor);
1793 expr->value.constructor = NULL;
1796 expr->where = old->where;
1797 expr->expr_type = EXPR_ARRAY;
1799 /* Copy the array argument constructors into an array, with nulls
1802 a = old->value.function.actual;
1803 for (; a; a = a->next)
1805 /* Check that this is OK for an initialization expression. */
1806 if (a->expr && check_init_expr (a->expr) == FAILURE)
1810 if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
1812 rank[n] = a->expr->rank;
1813 ctor = a->expr->symtree->n.sym->value->value.constructor;
1814 args[n] = gfc_copy_constructor (ctor);
1816 else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
1819 rank[n] = a->expr->rank;
1822 args[n] = gfc_copy_constructor (a->expr->value.constructor);
1830 /* Using the array argument as the master, step through the array
1831 calling the function for each element and advancing the array
1832 constructors together. */
1833 ctor = args[array_arg - 1];
1835 for (; ctor; ctor = ctor->next)
1837 if (expr->value.constructor == NULL)
1838 expr->value.constructor
1839 = new_ctor = gfc_get_constructor ();
1842 new_ctor->next = gfc_get_constructor ();
1843 new_ctor = new_ctor->next;
1845 new_ctor->expr = gfc_copy_expr (old);
1846 gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
1848 b = old->value.function.actual;
1849 for (i = 0; i < n; i++)
1852 new_ctor->expr->value.function.actual
1853 = a = gfc_get_actual_arglist ();
1856 a->next = gfc_get_actual_arglist ();
1860 a->expr = gfc_copy_expr (args[i]->expr);
1862 a->expr = gfc_copy_expr (b->expr);
1867 /* Simplify the function calls. If the simplification fails, the
1868 error will be flagged up down-stream or the library will deal
1870 gfc_simplify_expr (new_ctor->expr, 0);
1872 for (i = 0; i < n; i++)
1874 args[i] = args[i]->next;
1876 for (i = 1; i < n; i++)
1877 if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
1878 || (args[i] == NULL && args[array_arg - 1] != NULL)))
1884 gfc_free_expr (old);
1888 gfc_error_now ("elemental function arguments at %C are not compliant");
1891 gfc_free_expr (expr);
1892 gfc_free_expr (old);
1898 check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
1900 gfc_expr *op1 = e->value.op.op1;
1901 gfc_expr *op2 = e->value.op.op2;
1903 if ((*check_function) (op1) == FAILURE)
1906 switch (e->value.op.op)
1908 case INTRINSIC_UPLUS:
1909 case INTRINSIC_UMINUS:
1910 if (!numeric_type (et0 (op1)))
1915 case INTRINSIC_EQ_OS:
1917 case INTRINSIC_NE_OS:
1919 case INTRINSIC_GT_OS:
1921 case INTRINSIC_GE_OS:
1923 case INTRINSIC_LT_OS:
1925 case INTRINSIC_LE_OS:
1926 if ((*check_function) (op2) == FAILURE)
1929 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1930 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1932 gfc_error ("Numeric or CHARACTER operands are required in "
1933 "expression at %L", &e->where);
1938 case INTRINSIC_PLUS:
1939 case INTRINSIC_MINUS:
1940 case INTRINSIC_TIMES:
1941 case INTRINSIC_DIVIDE:
1942 case INTRINSIC_POWER:
1943 if ((*check_function) (op2) == FAILURE)
1946 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1951 case INTRINSIC_CONCAT:
1952 if ((*check_function) (op2) == FAILURE)
1955 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
1957 gfc_error ("Concatenation operator in expression at %L "
1958 "must have two CHARACTER operands", &op1->where);
1962 if (op1->ts.kind != op2->ts.kind)
1964 gfc_error ("Concat operator at %L must concatenate strings of the "
1965 "same kind", &e->where);
1972 if (et0 (op1) != BT_LOGICAL)
1974 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1975 "operand", &op1->where);
1984 case INTRINSIC_NEQV:
1985 if ((*check_function) (op2) == FAILURE)
1988 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
1990 gfc_error ("LOGICAL operands are required in expression at %L",
1997 case INTRINSIC_PARENTHESES:
2001 gfc_error ("Only intrinsic operators can be used in expression at %L",
2009 gfc_error ("Numeric operands are required in expression at %L", &e->where);
2016 check_init_expr_arguments (gfc_expr *e)
2018 gfc_actual_arglist *ap;
2020 for (ap = e->value.function.actual; ap; ap = ap->next)
2021 if (check_init_expr (ap->expr) == FAILURE)
2027 static gfc_try check_restricted (gfc_expr *);
2029 /* F95, 7.1.6.1, Initialization expressions, (7)
2030 F2003, 7.1.7 Initialization expression, (8) */
2033 check_inquiry (gfc_expr *e, int not_restricted)
2036 const char *const *functions;
2038 static const char *const inquiry_func_f95[] = {
2039 "lbound", "shape", "size", "ubound",
2040 "bit_size", "len", "kind",
2041 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2042 "precision", "radix", "range", "tiny",
2046 static const char *const inquiry_func_f2003[] = {
2047 "lbound", "shape", "size", "ubound",
2048 "bit_size", "len", "kind",
2049 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2050 "precision", "radix", "range", "tiny",
2055 gfc_actual_arglist *ap;
2057 if (!e->value.function.isym
2058 || !e->value.function.isym->inquiry)
2061 /* An undeclared parameter will get us here (PR25018). */
2062 if (e->symtree == NULL)
2065 name = e->symtree->n.sym->name;
2067 functions = (gfc_option.warn_std & GFC_STD_F2003)
2068 ? inquiry_func_f2003 : inquiry_func_f95;
2070 for (i = 0; functions[i]; i++)
2071 if (strcmp (functions[i], name) == 0)
2074 if (functions[i] == NULL)
2077 /* At this point we have an inquiry function with a variable argument. The
2078 type of the variable might be undefined, but we need it now, because the
2079 arguments of these functions are not allowed to be undefined. */
2081 for (ap = e->value.function.actual; ap; ap = ap->next)
2086 if (ap->expr->ts.type == BT_UNKNOWN)
2088 if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2089 && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)
2093 ap->expr->ts = ap->expr->symtree->n.sym->ts;
2096 /* Assumed character length will not reduce to a constant expression
2097 with LEN, as required by the standard. */
2098 if (i == 5 && not_restricted
2099 && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2100 && ap->expr->symtree->n.sym->ts.cl->length == NULL)
2102 gfc_error ("Assumed character length variable '%s' in constant "
2103 "expression at %L", e->symtree->n.sym->name, &e->where);
2106 else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
2109 if (not_restricted == 0
2110 && ap->expr->expr_type != EXPR_VARIABLE
2111 && check_restricted (ap->expr) == FAILURE)
2119 /* F95, 7.1.6.1, Initialization expressions, (5)
2120 F2003, 7.1.7 Initialization expression, (5) */
2123 check_transformational (gfc_expr *e)
2125 static const char * const trans_func_f95[] = {
2126 "repeat", "reshape", "selected_int_kind",
2127 "selected_real_kind", "transfer", "trim", NULL
2130 static const char * const trans_func_f2003[] = {
2131 "dot_product", "matmul", "null", "pack", "repeat",
2132 "reshape", "selected_char_kind", "selected_int_kind",
2133 "selected_real_kind", "transfer", "transpose", "trim", NULL
2138 const char *const *functions;
2140 if (!e->value.function.isym
2141 || !e->value.function.isym->transformational)
2144 name = e->symtree->n.sym->name;
2146 functions = (gfc_option.allow_std & GFC_STD_F2003)
2147 ? trans_func_f2003 : trans_func_f95;
2149 /* NULL() is dealt with below. */
2150 if (strcmp ("null", name) == 0)
2153 for (i = 0; functions[i]; i++)
2154 if (strcmp (functions[i], name) == 0)
2157 if (functions[i] == NULL)
2159 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2160 "in an initialization expression", name, &e->where);
2164 return check_init_expr_arguments (e);
2168 /* F95, 7.1.6.1, Initialization expressions, (6)
2169 F2003, 7.1.7 Initialization expression, (6) */
2172 check_null (gfc_expr *e)
2174 if (strcmp ("null", e->symtree->n.sym->name) != 0)
2177 return check_init_expr_arguments (e);
2182 check_elemental (gfc_expr *e)
2184 if (!e->value.function.isym
2185 || !e->value.function.isym->elemental)
2188 if (e->ts.type != BT_INTEGER
2189 && e->ts.type != BT_CHARACTER
2190 && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2191 "nonstandard initialization expression at %L",
2192 &e->where) == FAILURE)
2195 return check_init_expr_arguments (e);
2200 check_conversion (gfc_expr *e)
2202 if (!e->value.function.isym
2203 || !e->value.function.isym->conversion)
2206 return check_init_expr_arguments (e);
2210 /* Verify that an expression is an initialization expression. A side
2211 effect is that the expression tree is reduced to a single constant
2212 node if all goes well. This would normally happen when the
2213 expression is constructed but function references are assumed to be
2214 intrinsics in the context of initialization expressions. If
2215 FAILURE is returned an error message has been generated. */
2218 check_init_expr (gfc_expr *e)
2226 switch (e->expr_type)
2229 t = check_intrinsic_op (e, check_init_expr);
2231 t = gfc_simplify_expr (e, 0);
2238 if ((m = check_specification_function (e)) != MATCH_YES)
2240 gfc_intrinsic_sym* isym;
2243 sym = e->symtree->n.sym;
2244 if (!gfc_is_intrinsic (sym, 0, e->where)
2245 || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2247 gfc_error ("Function '%s' in initialization expression at %L "
2248 "must be an intrinsic or a specification function",
2249 e->symtree->n.sym->name, &e->where);
2253 if ((m = check_conversion (e)) == MATCH_NO
2254 && (m = check_inquiry (e, 1)) == MATCH_NO
2255 && (m = check_null (e)) == MATCH_NO
2256 && (m = check_transformational (e)) == MATCH_NO
2257 && (m = check_elemental (e)) == MATCH_NO)
2259 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2260 "in an initialization expression",
2261 e->symtree->n.sym->name, &e->where);
2265 /* Try to scalarize an elemental intrinsic function that has an
2267 isym = gfc_find_function (e->symtree->n.sym->name);
2268 if (isym && isym->elemental
2269 && (t = scalarize_intrinsic_call (e)) == SUCCESS)
2274 t = gfc_simplify_expr (e, 0);
2281 if (gfc_check_iter_variable (e) == SUCCESS)
2284 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2286 /* A PARAMETER shall not be used to define itself, i.e.
2287 REAL, PARAMETER :: x = transfer(0, x)
2289 if (!e->symtree->n.sym->value)
2291 gfc_error("PARAMETER '%s' is used at %L before its definition "
2292 "is complete", e->symtree->n.sym->name, &e->where);
2296 t = simplify_parameter_variable (e, 0);
2301 if (gfc_in_match_data ())
2306 if (e->symtree->n.sym->as)
2308 switch (e->symtree->n.sym->as->type)
2310 case AS_ASSUMED_SIZE:
2311 gfc_error ("Assumed size array '%s' at %L is not permitted "
2312 "in an initialization expression",
2313 e->symtree->n.sym->name, &e->where);
2316 case AS_ASSUMED_SHAPE:
2317 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2318 "in an initialization expression",
2319 e->symtree->n.sym->name, &e->where);
2323 gfc_error ("Deferred array '%s' at %L is not permitted "
2324 "in an initialization expression",
2325 e->symtree->n.sym->name, &e->where);
2329 gfc_error ("Array '%s' at %L is a variable, which does "
2330 "not reduce to a constant expression",
2331 e->symtree->n.sym->name, &e->where);
2339 gfc_error ("Parameter '%s' at %L has not been declared or is "
2340 "a variable, which does not reduce to a constant "
2341 "expression", e->symtree->n.sym->name, &e->where);
2350 case EXPR_SUBSTRING:
2351 t = check_init_expr (e->ref->u.ss.start);
2355 t = check_init_expr (e->ref->u.ss.end);
2357 t = gfc_simplify_expr (e, 0);
2361 case EXPR_STRUCTURE:
2365 t = gfc_check_constructor (e, check_init_expr);
2369 t = gfc_check_constructor (e, check_init_expr);
2373 t = gfc_expand_constructor (e);
2377 t = gfc_check_constructor_type (e);
2381 gfc_internal_error ("check_init_expr(): Unknown expression type");
2387 /* Reduces a general expression to an initialization expression (a constant).
2388 This used to be part of gfc_match_init_expr.
2389 Note that this function doesn't free the given expression on FAILURE. */
2392 gfc_reduce_init_expr (gfc_expr *expr)
2397 t = gfc_resolve_expr (expr);
2399 t = check_init_expr (expr);
2405 if (expr->expr_type == EXPR_ARRAY
2406 && (gfc_check_constructor_type (expr) == FAILURE
2407 || gfc_expand_constructor (expr) == FAILURE))
2410 /* Not all inquiry functions are simplified to constant expressions
2411 so it is necessary to call check_inquiry again. */
2412 if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) != MATCH_YES
2413 && !gfc_in_match_data ())
2415 gfc_error ("Initialization expression didn't reduce %C");
2423 /* Match an initialization expression. We work by first matching an
2424 expression, then reducing it to a constant. The reducing it to
2425 constant part requires a global variable to flag the prohibition
2426 of a non-integer exponent in -std=f95 mode. */
2428 bool init_flag = false;
2431 gfc_match_init_expr (gfc_expr **result)
2441 m = gfc_match_expr (&expr);
2448 t = gfc_reduce_init_expr (expr);
2451 gfc_free_expr (expr);
2463 /* Given an actual argument list, test to see that each argument is a
2464 restricted expression and optionally if the expression type is
2465 integer or character. */
2468 restricted_args (gfc_actual_arglist *a)
2470 for (; a; a = a->next)
2472 if (check_restricted (a->expr) == FAILURE)
2480 /************* Restricted/specification expressions *************/
2483 /* Make sure a non-intrinsic function is a specification function. */
2486 external_spec_function (gfc_expr *e)
2490 f = e->value.function.esym;
2492 if (f->attr.proc == PROC_ST_FUNCTION)
2494 gfc_error ("Specification function '%s' at %L cannot be a statement "
2495 "function", f->name, &e->where);
2499 if (f->attr.proc == PROC_INTERNAL)
2501 gfc_error ("Specification function '%s' at %L cannot be an internal "
2502 "function", f->name, &e->where);
2506 if (!f->attr.pure && !f->attr.elemental)
2508 gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2513 if (f->attr.recursive)
2515 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2516 f->name, &e->where);
2520 return restricted_args (e->value.function.actual);
2524 /* Check to see that a function reference to an intrinsic is a
2525 restricted expression. */
2528 restricted_intrinsic (gfc_expr *e)
2530 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2531 if (check_inquiry (e, 0) == MATCH_YES)
2534 return restricted_args (e->value.function.actual);
2538 /* Check the expressions of an actual arglist. Used by check_restricted. */
2541 check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
2543 for (; arg; arg = arg->next)
2544 if (checker (arg->expr) == FAILURE)
2551 /* Check the subscription expressions of a reference chain with a checking
2552 function; used by check_restricted. */
2555 check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
2565 for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2567 if (checker (ref->u.ar.start[dim]) == FAILURE)
2569 if (checker (ref->u.ar.end[dim]) == FAILURE)
2571 if (checker (ref->u.ar.stride[dim]) == FAILURE)
2577 /* Nothing needed, just proceed to next reference. */
2581 if (checker (ref->u.ss.start) == FAILURE)
2583 if (checker (ref->u.ss.end) == FAILURE)
2592 return check_references (ref->next, checker);
2596 /* Verify that an expression is a restricted expression. Like its
2597 cousin check_init_expr(), an error message is generated if we
2601 check_restricted (gfc_expr *e)
2609 switch (e->expr_type)
2612 t = check_intrinsic_op (e, check_restricted);
2614 t = gfc_simplify_expr (e, 0);
2619 if (e->value.function.esym)
2621 t = check_arglist (e->value.function.actual, &check_restricted);
2623 t = external_spec_function (e);
2627 if (e->value.function.isym && e->value.function.isym->inquiry)
2630 t = check_arglist (e->value.function.actual, &check_restricted);
2633 t = restricted_intrinsic (e);
2638 sym = e->symtree->n.sym;
2641 /* If a dummy argument appears in a context that is valid for a
2642 restricted expression in an elemental procedure, it will have
2643 already been simplified away once we get here. Therefore we
2644 don't need to jump through hoops to distinguish valid from
2646 if (sym->attr.dummy && sym->ns == gfc_current_ns
2647 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2649 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2650 sym->name, &e->where);
2654 if (sym->attr.optional)
2656 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2657 sym->name, &e->where);
2661 if (sym->attr.intent == INTENT_OUT)
2663 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2664 sym->name, &e->where);
2668 /* Check reference chain if any. */
2669 if (check_references (e->ref, &check_restricted) == FAILURE)
2672 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2673 processed in resolve.c(resolve_formal_arglist). This is done so
2674 that host associated dummy array indices are accepted (PR23446).
2675 This mechanism also does the same for the specification expressions
2676 of array-valued functions. */
2678 || sym->attr.in_common
2679 || sym->attr.use_assoc
2681 || sym->attr.implied_index
2682 || sym->attr.flavor == FL_PARAMETER
2683 || (sym->ns && sym->ns == gfc_current_ns->parent)
2684 || (sym->ns && gfc_current_ns->parent
2685 && sym->ns == gfc_current_ns->parent->parent)
2686 || (sym->ns->proc_name != NULL
2687 && sym->ns->proc_name->attr.flavor == FL_MODULE)
2688 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2694 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2695 sym->name, &e->where);
2696 /* Prevent a repetition of the error. */
2705 case EXPR_SUBSTRING:
2706 t = gfc_specification_expr (e->ref->u.ss.start);
2710 t = gfc_specification_expr (e->ref->u.ss.end);
2712 t = gfc_simplify_expr (e, 0);
2716 case EXPR_STRUCTURE:
2717 t = gfc_check_constructor (e, check_restricted);
2721 t = gfc_check_constructor (e, check_restricted);
2725 gfc_internal_error ("check_restricted(): Unknown expression type");
2732 /* Check to see that an expression is a specification expression. If
2733 we return FAILURE, an error has been generated. */
2736 gfc_specification_expr (gfc_expr *e)
2742 if (e->ts.type != BT_INTEGER)
2744 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2745 &e->where, gfc_basic_typename (e->ts.type));
2749 if (e->expr_type == EXPR_FUNCTION
2750 && !e->value.function.isym
2751 && !e->value.function.esym
2752 && !gfc_pure (e->symtree->n.sym))
2754 gfc_error ("Function '%s' at %L must be PURE",
2755 e->symtree->n.sym->name, &e->where);
2756 /* Prevent repeat error messages. */
2757 e->symtree->n.sym->attr.pure = 1;
2763 gfc_error ("Expression at %L must be scalar", &e->where);
2767 if (gfc_simplify_expr (e, 0) == FAILURE)
2770 return check_restricted (e);
2774 /************** Expression conformance checks. *************/
2776 /* Given two expressions, make sure that the arrays are conformable. */
2779 gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
2781 int op1_flag, op2_flag, d;
2782 mpz_t op1_size, op2_size;
2788 if (op1->rank == 0 || op2->rank == 0)
2791 va_start (argp, optype_msgid);
2792 vsnprintf (buffer, 240, optype_msgid, argp);
2795 if (op1->rank != op2->rank)
2797 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
2798 op1->rank, op2->rank, &op1->where);
2804 for (d = 0; d < op1->rank; d++)
2806 op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
2807 op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
2809 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
2811 gfc_error ("Different shape for %s at %L on dimension %d "
2812 "(%d and %d)", _(buffer), &op1->where, d + 1,
2813 (int) mpz_get_si (op1_size),
2814 (int) mpz_get_si (op2_size));
2820 mpz_clear (op1_size);
2822 mpz_clear (op2_size);
2832 /* Given an assignable expression and an arbitrary expression, make
2833 sure that the assignment can take place. */
2836 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
2842 sym = lvalue->symtree->n.sym;
2844 /* Check INTENT(IN), unless the object itself is the component or
2845 sub-component of a pointer. */
2846 has_pointer = sym->attr.pointer;
2848 for (ref = lvalue->ref; ref; ref = ref->next)
2849 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
2855 if (!has_pointer && sym->attr.intent == INTENT_IN)
2857 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2858 sym->name, &lvalue->where);
2862 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2863 variable local to a function subprogram. Its existence begins when
2864 execution of the function is initiated and ends when execution of the
2865 function is terminated...
2866 Therefore, the left hand side is no longer a variable, when it is: */
2867 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
2868 && !sym->attr.external)
2873 /* (i) Use associated; */
2874 if (sym->attr.use_assoc)
2877 /* (ii) The assignment is in the main program; or */
2878 if (gfc_current_ns->proc_name->attr.is_main_program)
2881 /* (iii) A module or internal procedure... */
2882 if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
2883 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
2884 && gfc_current_ns->parent
2885 && (!(gfc_current_ns->parent->proc_name->attr.function
2886 || gfc_current_ns->parent->proc_name->attr.subroutine)
2887 || gfc_current_ns->parent->proc_name->attr.is_main_program))
2889 /* ... that is not a function... */
2890 if (!gfc_current_ns->proc_name->attr.function)
2893 /* ... or is not an entry and has a different name. */
2894 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
2898 /* (iv) Host associated and not the function symbol or the
2899 parent result. This picks up sibling references, which
2900 cannot be entries. */
2901 if (!sym->attr.entry
2902 && sym->ns == gfc_current_ns->parent
2903 && sym != gfc_current_ns->proc_name
2904 && sym != gfc_current_ns->parent->proc_name->result)
2909 gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
2914 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
2916 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2917 lvalue->rank, rvalue->rank, &lvalue->where);
2921 if (lvalue->ts.type == BT_UNKNOWN)
2923 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2928 if (rvalue->expr_type == EXPR_NULL)
2930 if (has_pointer && (ref == NULL || ref->next == NULL)
2931 && lvalue->symtree->n.sym->attr.data)
2935 gfc_error ("NULL appears on right-hand side in assignment at %L",
2941 if (sym->attr.cray_pointee
2942 && lvalue->ref != NULL
2943 && lvalue->ref->u.ar.type == AR_FULL
2944 && lvalue->ref->u.ar.as->cp_was_assumed)
2946 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2947 "is illegal", &lvalue->where);
2951 /* This is possibly a typo: x = f() instead of x => f(). */
2952 if (gfc_option.warn_surprising
2953 && rvalue->expr_type == EXPR_FUNCTION
2954 && rvalue->symtree->n.sym->attr.pointer)
2955 gfc_warning ("POINTER valued function appears on right-hand side of "
2956 "assignment at %L", &rvalue->where);
2958 /* Check size of array assignments. */
2959 if (lvalue->rank != 0 && rvalue->rank != 0
2960 && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
2963 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
2964 && lvalue->symtree->n.sym->attr.data
2965 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
2966 "initialize non-integer variable '%s'",
2967 &rvalue->where, lvalue->symtree->n.sym->name)
2970 else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
2971 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
2972 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
2973 &rvalue->where) == FAILURE)
2976 /* Handle the case of a BOZ literal on the RHS. */
2977 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
2980 if (gfc_option.warn_surprising)
2981 gfc_warning ("BOZ literal at %L is bitwise transferred "
2982 "non-integer symbol '%s'", &rvalue->where,
2983 lvalue->symtree->n.sym->name);
2984 if (!gfc_convert_boz (rvalue, &lvalue->ts))
2986 if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
2988 if (rc == ARITH_UNDERFLOW)
2989 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
2990 ". This check can be disabled with the option "
2991 "-fno-range-check", &rvalue->where);
2992 else if (rc == ARITH_OVERFLOW)
2993 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
2994 ". This check can be disabled with the option "
2995 "-fno-range-check", &rvalue->where);
2996 else if (rc == ARITH_NAN)
2997 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
2998 ". This check can be disabled with the option "
2999 "-fno-range-check", &rvalue->where);
3004 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
3007 /* Only DATA Statements come here. */
3010 /* Numeric can be converted to any other numeric. And Hollerith can be
3011 converted to any other type. */
3012 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3013 || rvalue->ts.type == BT_HOLLERITH)
3016 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3019 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3020 "conversion of %s to %s", &lvalue->where,
3021 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3026 /* Assignment is the only case where character variables of different
3027 kind values can be converted into one another. */
3028 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3030 if (lvalue->ts.kind != rvalue->ts.kind)
3031 gfc_convert_chartype (rvalue, &lvalue->ts);
3036 return gfc_convert_type (rvalue, &lvalue->ts, 1);
3040 /* Check that a pointer assignment is OK. We first check lvalue, and
3041 we only check rvalue if it's not an assignment to NULL() or a
3042 NULLIFY statement. */
3045 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3047 symbol_attribute attr;
3050 int pointer, check_intent_in, proc_pointer;
3052 if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3053 && !lvalue->symtree->n.sym->attr.proc_pointer)
3055 gfc_error ("Pointer assignment target is not a POINTER at %L",
3060 if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3061 && lvalue->symtree->n.sym->attr.use_assoc
3062 && !lvalue->symtree->n.sym->attr.proc_pointer)
3064 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3065 "l-value since it is a procedure",
3066 lvalue->symtree->n.sym->name, &lvalue->where);
3071 /* Check INTENT(IN), unless the object itself is the component or
3072 sub-component of a pointer. */
3073 check_intent_in = 1;
3074 pointer = lvalue->symtree->n.sym->attr.pointer;
3075 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3077 for (ref = lvalue->ref; ref; ref = ref->next)
3080 check_intent_in = 0;
3082 if (ref->type == REF_COMPONENT)
3084 pointer = ref->u.c.component->attr.pointer;
3085 proc_pointer = ref->u.c.component->attr.proc_pointer;
3088 if (ref->type == REF_ARRAY && ref->next == NULL)
3090 if (ref->u.ar.type == AR_FULL)
3093 if (ref->u.ar.type != AR_SECTION)
3095 gfc_error ("Expected bounds specification for '%s' at %L",
3096 lvalue->symtree->n.sym->name, &lvalue->where);
3100 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3101 "specification for '%s' in pointer assignment "
3102 "at %L", lvalue->symtree->n.sym->name,
3103 &lvalue->where) == FAILURE)
3106 gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3107 "in gfortran", &lvalue->where);
3108 /* TODO: See PR 29785. Add checks that all lbounds are specified and
3109 either never or always the upper-bound; strides shall not be
3115 if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
3117 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3118 lvalue->symtree->n.sym->name, &lvalue->where);
3122 if (!pointer && !proc_pointer)
3124 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
3128 is_pure = gfc_pure (NULL);
3130 if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
3131 && lvalue->symtree->n.sym->value != rvalue)
3133 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
3137 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3138 kind, etc for lvalue and rvalue must match, and rvalue must be a
3139 pure variable if we're in a pure function. */
3140 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3143 /* Checks on rvalue for procedure pointer assignments. */
3146 attr = gfc_expr_attr (rvalue);
3147 if (!((rvalue->expr_type == EXPR_NULL)
3148 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3149 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
3150 || (rvalue->expr_type == EXPR_VARIABLE
3151 && attr.flavor == FL_PROCEDURE)))
3153 gfc_error ("Invalid procedure pointer assignment at %L",
3159 gfc_error ("Abstract interface '%s' is invalid "
3160 "in procedure pointer assignment at %L",
3161 rvalue->symtree->name, &rvalue->where);
3164 /* Check for C727. */
3165 if (attr.flavor == FL_PROCEDURE)
3167 if (attr.proc == PROC_ST_FUNCTION)
3169 gfc_error ("Statement function '%s' is invalid "
3170 "in procedure pointer assignment at %L",
3171 rvalue->symtree->name, &rvalue->where);
3174 if (attr.proc == PROC_INTERNAL &&
3175 gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
3176 "invalid in procedure pointer assignment at %L",
3177 rvalue->symtree->name, &rvalue->where) == FAILURE)
3180 /* TODO: Enable interface check for PPCs. */
3181 if (is_proc_ptr_comp (rvalue, NULL))
3183 if (rvalue->expr_type == EXPR_VARIABLE
3184 && !gfc_compare_interfaces (lvalue->symtree->n.sym,
3185 rvalue->symtree->n.sym, 0, 1))
3187 gfc_error ("Interfaces don't match "
3188 "in procedure pointer assignment at %L", &rvalue->where);
3194 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3196 gfc_error ("Different types in pointer assignment at %L; attempted "
3197 "assignment of %s to %s", &lvalue->where,
3198 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3202 if (lvalue->ts.kind != rvalue->ts.kind)
3204 gfc_error ("Different kind type parameters in pointer "
3205 "assignment at %L", &lvalue->where);
3209 if (lvalue->rank != rvalue->rank)
3211 gfc_error ("Different ranks in pointer assignment at %L",
3216 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3217 if (rvalue->expr_type == EXPR_NULL)
3220 if (lvalue->ts.type == BT_CHARACTER)
3222 gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3227 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3228 lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3230 attr = gfc_expr_attr (rvalue);
3231 if (!attr.target && !attr.pointer)
3233 gfc_error ("Pointer assignment target is neither TARGET "
3234 "nor POINTER at %L", &rvalue->where);
3238 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3240 gfc_error ("Bad target in pointer assignment in PURE "
3241 "procedure at %L", &rvalue->where);
3244 if (gfc_has_vector_index (rvalue))
3246 gfc_error ("Pointer assignment with vector subscript "
3247 "on rhs at %L", &rvalue->where);
3251 if (attr.is_protected && attr.use_assoc
3252 && !(attr.pointer || attr.proc_pointer))
3254 gfc_error ("Pointer assignment target has PROTECTED "
3255 "attribute at %L", &rvalue->where);
3263 /* Relative of gfc_check_assign() except that the lvalue is a single
3264 symbol. Used for initialization assignments. */
3267 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3272 memset (&lvalue, '\0', sizeof (gfc_expr));
3274 lvalue.expr_type = EXPR_VARIABLE;
3275 lvalue.ts = sym->ts;
3277 lvalue.rank = sym->as->rank;
3278 lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3279 lvalue.symtree->n.sym = sym;
3280 lvalue.where = sym->declared_at;
3282 if (sym->attr.pointer || sym->attr.proc_pointer)
3283 r = gfc_check_pointer_assign (&lvalue, rvalue);
3285 r = gfc_check_assign (&lvalue, rvalue, 1);
3287 gfc_free (lvalue.symtree);
3293 /* Get an expression for a default initializer. */
3296 gfc_default_initializer (gfc_typespec *ts)
3298 gfc_constructor *tail;
3302 /* See if we have a default initializer. */
3303 for (c = ts->derived->components; c; c = c->next)
3304 if (c->initializer || c->attr.allocatable)
3310 /* Build the constructor. */
3311 init = gfc_get_expr ();
3312 init->expr_type = EXPR_STRUCTURE;
3314 init->where = ts->derived->declared_at;
3317 for (c = ts->derived->components; c; c = c->next)
3320 init->value.constructor = tail = gfc_get_constructor ();
3323 tail->next = gfc_get_constructor ();
3328 tail->expr = gfc_copy_expr (c->initializer);
3330 if (c->attr.allocatable)
3332 tail->expr = gfc_get_expr ();
3333 tail->expr->expr_type = EXPR_NULL;
3334 tail->expr->ts = c->ts;
3341 /* Given a symbol, create an expression node with that symbol as a
3342 variable. If the symbol is array valued, setup a reference of the
3346 gfc_get_variable_expr (gfc_symtree *var)
3350 e = gfc_get_expr ();
3351 e->expr_type = EXPR_VARIABLE;
3353 e->ts = var->n.sym->ts;
3355 if (var->n.sym->as != NULL)
3357 e->rank = var->n.sym->as->rank;
3358 e->ref = gfc_get_ref ();
3359 e->ref->type = REF_ARRAY;
3360 e->ref->u.ar.type = AR_FULL;
3367 /* General expression traversal function. */
3370 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3371 bool (*func)(gfc_expr *, gfc_symbol *, int*),
3376 gfc_actual_arglist *args;
3383 if ((*func) (expr, sym, &f))
3386 if (expr->ts.type == BT_CHARACTER
3388 && expr->ts.cl->length
3389 && expr->ts.cl->length->expr_type != EXPR_CONSTANT
3390 && gfc_traverse_expr (expr->ts.cl->length, sym, func, f))
3393 switch (expr->expr_type)
3396 for (args = expr->value.function.actual; args; args = args->next)
3398 if (gfc_traverse_expr (args->expr, sym, func, f))
3406 case EXPR_SUBSTRING:
3409 case EXPR_STRUCTURE:
3411 for (c = expr->value.constructor; c; c = c->next)
3413 if (gfc_traverse_expr (c->expr, sym, func, f))
3417 if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3419 if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3421 if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3423 if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3430 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3432 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3448 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3450 if (gfc_traverse_expr (ar.start[i], sym, func, f))
3452 if (gfc_traverse_expr (ar.end[i], sym, func, f))
3454 if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3460 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3462 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3467 if (ref->u.c.component->ts.type == BT_CHARACTER
3468 && ref->u.c.component->ts.cl
3469 && ref->u.c.component->ts.cl->length
3470 && ref->u.c.component->ts.cl->length->expr_type
3472 && gfc_traverse_expr (ref->u.c.component->ts.cl->length,
3476 if (ref->u.c.component->as)
3477 for (i = 0; i < ref->u.c.component->as->rank; i++)
3479 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3482 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3496 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3499 expr_set_symbols_referenced (gfc_expr *expr,
3500 gfc_symbol *sym ATTRIBUTE_UNUSED,
3501 int *f ATTRIBUTE_UNUSED)
3503 if (expr->expr_type != EXPR_VARIABLE)
3505 gfc_set_sym_referenced (expr->symtree->n.sym);
3510 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3512 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3516 /* Determine if an expression is a procedure pointer component. If yes, the
3517 argument 'comp' will point to the component (provided that 'comp' was
3521 is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
3526 if (!expr || !expr->ref)
3533 if (ref->type == REF_COMPONENT)
3535 ppc = ref->u.c.component->attr.proc_pointer;
3537 *comp = ref->u.c.component;
3544 /* Walk an expression tree and check each variable encountered for being typed.
3545 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3546 mode as is a basic arithmetic expression using those; this is for things in
3549 INTEGER :: arr(n), n
3550 INTEGER :: arr(n + 1), n
3552 The namespace is needed for IMPLICIT typing. */
3554 static gfc_namespace* check_typed_ns;
3557 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3558 int* f ATTRIBUTE_UNUSED)
3562 if (e->expr_type != EXPR_VARIABLE)
3565 gcc_assert (e->symtree);
3566 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3569 return (t == FAILURE);
3573 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3577 /* If this is a top-level variable or EXPR_OP, do the check with strict given
3581 if (e->expr_type == EXPR_VARIABLE && !e->ref)
3582 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3584 if (e->expr_type == EXPR_OP)
3586 gfc_try t = SUCCESS;
3588 gcc_assert (e->value.op.op1);
3589 t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
3591 if (t == SUCCESS && e->value.op.op2)
3592 t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
3598 /* Otherwise, walk the expression and do it strictly. */
3599 check_typed_ns = ns;
3600 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3602 return error_found ? FAILURE : SUCCESS;
3605 /* Walk an expression tree and replace all symbols with a corresponding symbol
3606 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3607 statements. The boolean return value is required by gfc_traverse_expr. */
3610 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3612 if ((expr->expr_type == EXPR_VARIABLE
3613 || (expr->expr_type == EXPR_FUNCTION
3614 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3615 && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
3618 gfc_namespace *ns = sym->formal_ns;
3619 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3620 the symtree rather than create a new one (and probably fail later). */
3621 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3622 expr->symtree->n.sym->name);
3624 stree->n.sym->attr = expr->symtree->n.sym->attr;
3625 expr->symtree = stree;
3631 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
3633 gfc_traverse_expr (expr, dest, &replace_symbol, 0);