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 */
29 #include "constructor.h"
32 /* The following set of functions provide access to gfc_expr* of
33 various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
35 There are two functions available elsewhere that provide
36 slightly different flavours of variables. Namely:
37 expr.c (gfc_get_variable_expr)
38 symbol.c (gfc_lval_expr_from_sym)
39 TODO: Merge these functions, if possible. */
41 /* Get a new expression node. */
49 gfc_clear_ts (&e->ts);
57 /* Get a new expression node that is an array constructor
58 of given type and kind. */
61 gfc_get_array_expr (bt type, int kind, locus *where)
66 e->expr_type = EXPR_ARRAY;
67 e->value.constructor = NULL;
80 /* Get a new expression node that is the NULL expression. */
83 gfc_get_null_expr (locus *where)
88 e->expr_type = EXPR_NULL;
89 e->ts.type = BT_UNKNOWN;
98 /* Get a new expression node that is an operator expression node. */
101 gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
102 gfc_expr *op1, gfc_expr *op2)
107 e->expr_type = EXPR_OP;
109 e->value.op.op1 = op1;
110 e->value.op.op2 = op2;
119 /* Get a new expression node that is an structure constructor
120 of given type and kind. */
123 gfc_get_structure_constructor_expr (bt type, int kind, locus *where)
128 e->expr_type = EXPR_STRUCTURE;
129 e->value.constructor = NULL;
140 /* Get a new expression node that is an constant of given type and kind. */
143 gfc_get_constant_expr (bt type, int kind, locus *where)
148 gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL");
152 e->expr_type = EXPR_CONSTANT;
160 mpz_init (e->value.integer);
164 gfc_set_model_kind (kind);
165 mpfr_init (e->value.real);
169 gfc_set_model_kind (kind);
170 mpc_init2 (e->value.complex, mpfr_get_default_prec());
181 /* Get a new expression node that is an string constant.
182 If no string is passed, a string of len is allocated,
183 blanked and null-terminated. */
186 gfc_get_character_expr (int kind, locus *where, const char *src, int len)
193 dest = gfc_get_wide_string (len + 1);
194 gfc_wide_memset (dest, ' ', len);
198 dest = gfc_char_to_widechar (src);
200 e = gfc_get_constant_expr (BT_CHARACTER, kind,
201 where ? where : &gfc_current_locus);
202 e->value.character.string = dest;
203 e->value.character.length = len;
209 /* Get a new expression node that is an integer constant. */
212 gfc_get_int_expr (int kind, locus *where, int value)
215 p = gfc_get_constant_expr (BT_INTEGER, kind,
216 where ? where : &gfc_current_locus);
218 mpz_init_set_si (p->value.integer, value);
224 /* Get a new expression node that is a logical constant. */
227 gfc_get_logical_expr (int kind, locus *where, bool value)
230 p = gfc_get_constant_expr (BT_LOGICAL, kind,
231 where ? where : &gfc_current_locus);
233 p->value.logical = value;
240 gfc_get_iokind_expr (locus *where, io_kind k)
244 /* Set the types to something compatible with iokind. This is needed to
245 get through gfc_free_expr later since iokind really has no Basic Type,
249 e->expr_type = EXPR_CONSTANT;
250 e->ts.type = BT_LOGICAL;
258 /* Given an expression pointer, return a copy of the expression. This
259 subroutine is recursive. */
262 gfc_copy_expr (gfc_expr *p)
274 switch (q->expr_type)
277 s = gfc_get_wide_string (p->value.character.length + 1);
278 q->value.character.string = s;
279 memcpy (s, p->value.character.string,
280 (p->value.character.length + 1) * sizeof (gfc_char_t));
284 /* Copy target representation, if it exists. */
285 if (p->representation.string)
287 c = XCNEWVEC (char, p->representation.length + 1);
288 q->representation.string = c;
289 memcpy (c, p->representation.string, (p->representation.length + 1));
292 /* Copy the values of any pointer components of p->value. */
296 mpz_init_set (q->value.integer, p->value.integer);
300 gfc_set_model_kind (q->ts.kind);
301 mpfr_init (q->value.real);
302 mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
306 gfc_set_model_kind (q->ts.kind);
307 mpc_init2 (q->value.complex, mpfr_get_default_prec());
308 mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
312 if (p->representation.string)
313 q->value.character.string
314 = gfc_char_to_widechar (q->representation.string);
317 s = gfc_get_wide_string (p->value.character.length + 1);
318 q->value.character.string = s;
320 /* This is the case for the C_NULL_CHAR named constant. */
321 if (p->value.character.length == 0
322 && (p->ts.is_c_interop || p->ts.is_iso_c))
325 /* Need to set the length to 1 to make sure the NUL
326 terminator is copied. */
327 q->value.character.length = 1;
330 memcpy (s, p->value.character.string,
331 (p->value.character.length + 1) * sizeof (gfc_char_t));
339 break; /* Already done. */
343 /* Should never be reached. */
345 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
352 switch (q->value.op.op)
355 case INTRINSIC_PARENTHESES:
356 case INTRINSIC_UPLUS:
357 case INTRINSIC_UMINUS:
358 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
361 default: /* Binary operators. */
362 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
363 q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
370 q->value.function.actual =
371 gfc_copy_actual_arglist (p->value.function.actual);
376 q->value.compcall.actual =
377 gfc_copy_actual_arglist (p->value.compcall.actual);
378 q->value.compcall.tbp = p->value.compcall.tbp;
383 q->value.constructor = gfc_constructor_copy (p->value.constructor);
391 q->shape = gfc_copy_shape (p->shape, p->rank);
393 q->ref = gfc_copy_ref (p->ref);
399 /* Workhorse function for gfc_free_expr() that frees everything
400 beneath an expression node, but not the node itself. This is
401 useful when we want to simplify a node and replace it with
402 something else or the expression node belongs to another structure. */
405 free_expr0 (gfc_expr *e)
409 switch (e->expr_type)
412 /* Free any parts of the value that need freeing. */
416 mpz_clear (e->value.integer);
420 mpfr_clear (e->value.real);
424 gfc_free (e->value.character.string);
428 mpc_clear (e->value.complex);
435 /* Free the representation. */
436 if (e->representation.string)
437 gfc_free (e->representation.string);
442 if (e->value.op.op1 != NULL)
443 gfc_free_expr (e->value.op.op1);
444 if (e->value.op.op2 != NULL)
445 gfc_free_expr (e->value.op.op2);
449 gfc_free_actual_arglist (e->value.function.actual);
454 gfc_free_actual_arglist (e->value.compcall.actual);
462 gfc_constructor_free (e->value.constructor);
466 gfc_free (e->value.character.string);
473 gfc_internal_error ("free_expr0(): Bad expr type");
476 /* Free a shape array. */
477 if (e->shape != NULL)
479 for (n = 0; n < e->rank; n++)
480 mpz_clear (e->shape[n]);
485 gfc_free_ref_list (e->ref);
487 memset (e, '\0', sizeof (gfc_expr));
491 /* Free an expression node and everything beneath it. */
494 gfc_free_expr (gfc_expr *e)
503 /* Free an argument list and everything below it. */
506 gfc_free_actual_arglist (gfc_actual_arglist *a1)
508 gfc_actual_arglist *a2;
513 gfc_free_expr (a1->expr);
520 /* Copy an arglist structure and all of the arguments. */
523 gfc_copy_actual_arglist (gfc_actual_arglist *p)
525 gfc_actual_arglist *head, *tail, *new_arg;
529 for (; p; p = p->next)
531 new_arg = gfc_get_actual_arglist ();
534 new_arg->expr = gfc_copy_expr (p->expr);
535 new_arg->next = NULL;
540 tail->next = new_arg;
549 /* Free a list of reference structures. */
552 gfc_free_ref_list (gfc_ref *p)
564 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
566 gfc_free_expr (p->u.ar.start[i]);
567 gfc_free_expr (p->u.ar.end[i]);
568 gfc_free_expr (p->u.ar.stride[i]);
574 gfc_free_expr (p->u.ss.start);
575 gfc_free_expr (p->u.ss.end);
587 /* Graft the *src expression onto the *dest subexpression. */
590 gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
598 /* Try to extract an integer constant from the passed expression node.
599 Returns an error message or NULL if the result is set. It is
600 tempting to generate an error and return SUCCESS or FAILURE, but
601 failure is OK for some callers. */
604 gfc_extract_int (gfc_expr *expr, int *result)
606 if (expr->expr_type != EXPR_CONSTANT)
607 return _("Constant expression required at %C");
609 if (expr->ts.type != BT_INTEGER)
610 return _("Integer expression required at %C");
612 if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
613 || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
615 return _("Integer value too large in expression at %C");
618 *result = (int) mpz_get_si (expr->value.integer);
624 /* Recursively copy a list of reference structures. */
627 gfc_copy_ref (gfc_ref *src)
635 dest = gfc_get_ref ();
636 dest->type = src->type;
641 ar = gfc_copy_array_ref (&src->u.ar);
647 dest->u.c = src->u.c;
651 dest->u.ss = src->u.ss;
652 dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
653 dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
657 dest->next = gfc_copy_ref (src->next);
663 /* Detect whether an expression has any vector index array references. */
666 gfc_has_vector_index (gfc_expr *e)
670 for (ref = e->ref; ref; ref = ref->next)
671 if (ref->type == REF_ARRAY)
672 for (i = 0; i < ref->u.ar.dimen; i++)
673 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
679 /* Insert a reference to the component of the given name.
680 Only to be used with CLASS containers. */
683 gfc_add_component_ref (gfc_expr *e, const char *name)
685 gfc_ref **tail = &(e->ref);
686 gfc_ref *next = NULL;
687 gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
688 while (*tail != NULL)
690 if ((*tail)->type == REF_COMPONENT)
691 derived = (*tail)->u.c.component->ts.u.derived;
692 if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
694 tail = &((*tail)->next);
696 if (*tail != NULL && strcmp (name, "$data") == 0)
698 (*tail) = gfc_get_ref();
699 (*tail)->next = next;
700 (*tail)->type = REF_COMPONENT;
701 (*tail)->u.c.sym = derived;
702 (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
703 gcc_assert((*tail)->u.c.component);
705 e->ts = (*tail)->u.c.component->ts;
709 /* Copy a shape array. */
712 gfc_copy_shape (mpz_t *shape, int rank)
720 new_shape = gfc_get_shape (rank);
722 for (n = 0; n < rank; n++)
723 mpz_init_set (new_shape[n], shape[n]);
729 /* Copy a shape array excluding dimension N, where N is an integer
730 constant expression. Dimensions are numbered in fortran style --
733 So, if the original shape array contains R elements
734 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
735 the result contains R-1 elements:
736 { s1 ... sN-1 sN+1 ... sR-1}
738 If anything goes wrong -- N is not a constant, its value is out
739 of range -- or anything else, just returns NULL. */
742 gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
744 mpz_t *new_shape, *s;
750 || dim->expr_type != EXPR_CONSTANT
751 || dim->ts.type != BT_INTEGER)
754 n = mpz_get_si (dim->value.integer);
755 n--; /* Convert to zero based index. */
756 if (n < 0 || n >= rank)
759 s = new_shape = gfc_get_shape (rank - 1);
761 for (i = 0; i < rank; i++)
765 mpz_init_set (*s, shape[i]);
773 /* Return the maximum kind of two expressions. In general, higher
774 kind numbers mean more precision for numeric types. */
777 gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
779 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
783 /* Returns nonzero if the type is numeric, zero otherwise. */
786 numeric_type (bt type)
788 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
792 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
795 gfc_numeric_ts (gfc_typespec *ts)
797 return numeric_type (ts->type);
801 /* Return an expression node with an optional argument list attached.
802 A variable number of gfc_expr pointers are strung together in an
803 argument list with a NULL pointer terminating the list. */
806 gfc_build_conversion (gfc_expr *e)
811 p->expr_type = EXPR_FUNCTION;
813 p->value.function.actual = NULL;
815 p->value.function.actual = gfc_get_actual_arglist ();
816 p->value.function.actual->expr = e;
822 /* Given an expression node with some sort of numeric binary
823 expression, insert type conversions required to make the operands
824 have the same type. Conversion warnings are disabled if wconversion
827 The exception is that the operands of an exponential don't have to
828 have the same type. If possible, the base is promoted to the type
829 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
830 1.0**2 stays as it is. */
833 gfc_type_convert_binary (gfc_expr *e, int wconversion)
837 op1 = e->value.op.op1;
838 op2 = e->value.op.op2;
840 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
842 gfc_clear_ts (&e->ts);
846 /* Kind conversions of same type. */
847 if (op1->ts.type == op2->ts.type)
849 if (op1->ts.kind == op2->ts.kind)
851 /* No type conversions. */
856 if (op1->ts.kind > op2->ts.kind)
857 gfc_convert_type_warn (op2, &op1->ts, 2, wconversion);
859 gfc_convert_type_warn (op1, &op2->ts, 2, wconversion);
865 /* Integer combined with real or complex. */
866 if (op2->ts.type == BT_INTEGER)
870 /* Special case for ** operator. */
871 if (e->value.op.op == INTRINSIC_POWER)
874 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
878 if (op1->ts.type == BT_INTEGER)
881 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
885 /* Real combined with complex. */
886 e->ts.type = BT_COMPLEX;
887 if (op1->ts.kind > op2->ts.kind)
888 e->ts.kind = op1->ts.kind;
890 e->ts.kind = op2->ts.kind;
891 if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
892 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
893 if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
894 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
902 check_specification_function (gfc_expr *e)
909 sym = e->symtree->n.sym;
911 /* F95, 7.1.6.2; F2003, 7.1.7 */
913 && sym->attr.function
915 && !sym->attr.intrinsic
916 && !sym->attr.recursive
917 && sym->attr.proc != PROC_INTERNAL
918 && sym->attr.proc != PROC_ST_FUNCTION
919 && sym->attr.proc != PROC_UNKNOWN
920 && sym->formal == NULL)
926 /* Function to determine if an expression is constant or not. This
927 function expects that the expression has already been simplified. */
930 gfc_is_constant_expr (gfc_expr *e)
933 gfc_actual_arglist *arg;
938 switch (e->expr_type)
941 return (gfc_is_constant_expr (e->value.op.op1)
942 && (e->value.op.op2 == NULL
943 || gfc_is_constant_expr (e->value.op.op2)));
951 /* Specification functions are constant. */
952 if (check_specification_function (e) == MATCH_YES)
955 /* Call to intrinsic with at least one argument. */
956 if (e->value.function.isym && e->value.function.actual)
958 for (arg = e->value.function.actual; arg; arg = arg->next)
959 if (!gfc_is_constant_expr (arg->expr))
972 return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
973 && gfc_is_constant_expr (e->ref->u.ss.end));
976 for (c = gfc_constructor_first (e->value.constructor);
977 c; c = gfc_constructor_next (c))
978 if (!gfc_is_constant_expr (c->expr))
984 return gfc_constant_ac (e);
987 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
993 /* Is true if an array reference is followed by a component or substring
996 is_subref_array (gfc_expr * e)
1001 if (e->expr_type != EXPR_VARIABLE)
1004 if (e->symtree->n.sym->attr.subref_array_pointer)
1008 for (ref = e->ref; ref; ref = ref->next)
1010 if (ref->type == REF_ARRAY
1011 && ref->u.ar.type != AR_ELEMENT)
1015 && ref->type != REF_ARRAY)
1022 /* Try to collapse intrinsic expressions. */
1025 simplify_intrinsic_op (gfc_expr *p, int type)
1027 gfc_intrinsic_op op;
1028 gfc_expr *op1, *op2, *result;
1030 if (p->value.op.op == INTRINSIC_USER)
1033 op1 = p->value.op.op1;
1034 op2 = p->value.op.op2;
1035 op = p->value.op.op;
1037 if (gfc_simplify_expr (op1, type) == FAILURE)
1039 if (gfc_simplify_expr (op2, type) == FAILURE)
1042 if (!gfc_is_constant_expr (op1)
1043 || (op2 != NULL && !gfc_is_constant_expr (op2)))
1047 p->value.op.op1 = NULL;
1048 p->value.op.op2 = NULL;
1052 case INTRINSIC_PARENTHESES:
1053 result = gfc_parentheses (op1);
1056 case INTRINSIC_UPLUS:
1057 result = gfc_uplus (op1);
1060 case INTRINSIC_UMINUS:
1061 result = gfc_uminus (op1);
1064 case INTRINSIC_PLUS:
1065 result = gfc_add (op1, op2);
1068 case INTRINSIC_MINUS:
1069 result = gfc_subtract (op1, op2);
1072 case INTRINSIC_TIMES:
1073 result = gfc_multiply (op1, op2);
1076 case INTRINSIC_DIVIDE:
1077 result = gfc_divide (op1, op2);
1080 case INTRINSIC_POWER:
1081 result = gfc_power (op1, op2);
1084 case INTRINSIC_CONCAT:
1085 result = gfc_concat (op1, op2);
1089 case INTRINSIC_EQ_OS:
1090 result = gfc_eq (op1, op2, op);
1094 case INTRINSIC_NE_OS:
1095 result = gfc_ne (op1, op2, op);
1099 case INTRINSIC_GT_OS:
1100 result = gfc_gt (op1, op2, op);
1104 case INTRINSIC_GE_OS:
1105 result = gfc_ge (op1, op2, op);
1109 case INTRINSIC_LT_OS:
1110 result = gfc_lt (op1, op2, op);
1114 case INTRINSIC_LE_OS:
1115 result = gfc_le (op1, op2, op);
1119 result = gfc_not (op1);
1123 result = gfc_and (op1, op2);
1127 result = gfc_or (op1, op2);
1131 result = gfc_eqv (op1, op2);
1134 case INTRINSIC_NEQV:
1135 result = gfc_neqv (op1, op2);
1139 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1144 gfc_free_expr (op1);
1145 gfc_free_expr (op2);
1149 result->rank = p->rank;
1150 result->where = p->where;
1151 gfc_replace_expr (p, result);
1157 /* Subroutine to simplify constructor expressions. Mutually recursive
1158 with gfc_simplify_expr(). */
1161 simplify_constructor (gfc_constructor_base base, int type)
1166 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1169 && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
1170 || gfc_simplify_expr (c->iterator->end, type) == FAILURE
1171 || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
1176 /* Try and simplify a copy. Replace the original if successful
1177 but keep going through the constructor at all costs. Not
1178 doing so can make a dog's dinner of complicated things. */
1179 p = gfc_copy_expr (c->expr);
1181 if (gfc_simplify_expr (p, type) == FAILURE)
1187 gfc_replace_expr (c->expr, p);
1195 /* Pull a single array element out of an array constructor. */
1198 find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
1199 gfc_constructor **rval)
1201 unsigned long nelemen;
1207 gfc_constructor *cons;
1214 mpz_init_set_ui (offset, 0);
1217 mpz_init_set_ui (span, 1);
1218 for (i = 0; i < ar->dimen; i++)
1220 if (gfc_reduce_init_expr (ar->as->lower[i]) == FAILURE
1221 || gfc_reduce_init_expr (ar->as->upper[i]) == FAILURE)
1228 e = gfc_copy_expr (ar->start[i]);
1229 if (e->expr_type != EXPR_CONSTANT)
1235 gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
1236 && ar->as->lower[i]->expr_type == EXPR_CONSTANT);
1238 /* Check the bounds. */
1239 if ((ar->as->upper[i]
1240 && mpz_cmp (e->value.integer,
1241 ar->as->upper[i]->value.integer) > 0)
1242 || (mpz_cmp (e->value.integer,
1243 ar->as->lower[i]->value.integer) < 0))
1245 gfc_error ("Index in dimension %d is out of bounds "
1246 "at %L", i + 1, &ar->c_where[i]);
1252 mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1253 mpz_mul (delta, delta, span);
1254 mpz_add (offset, offset, delta);
1256 mpz_set_ui (tmp, 1);
1257 mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1258 mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1259 mpz_mul (span, span, tmp);
1262 for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset);
1263 cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
1284 /* Find a component of a structure constructor. */
1286 static gfc_constructor *
1287 find_component_ref (gfc_constructor_base base, gfc_ref *ref)
1289 gfc_component *comp;
1290 gfc_component *pick;
1291 gfc_constructor *c = gfc_constructor_first (base);
1293 comp = ref->u.c.sym->components;
1294 pick = ref->u.c.component;
1295 while (comp != pick)
1298 c = gfc_constructor_next (c);
1305 /* Replace an expression with the contents of a constructor, removing
1306 the subobject reference in the process. */
1309 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1319 e = gfc_copy_expr (p);
1320 e->ref = p->ref->next;
1321 p->ref->next = NULL;
1322 gfc_replace_expr (p, e);
1326 /* Pull an array section out of an array constructor. */
1329 find_array_section (gfc_expr *expr, gfc_ref *ref)
1335 long unsigned one = 1;
1337 mpz_t start[GFC_MAX_DIMENSIONS];
1338 mpz_t end[GFC_MAX_DIMENSIONS];
1339 mpz_t stride[GFC_MAX_DIMENSIONS];
1340 mpz_t delta[GFC_MAX_DIMENSIONS];
1341 mpz_t ctr[GFC_MAX_DIMENSIONS];
1346 gfc_constructor_base base;
1347 gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS];
1357 base = expr->value.constructor;
1358 expr->value.constructor = NULL;
1360 rank = ref->u.ar.as->rank;
1362 if (expr->shape == NULL)
1363 expr->shape = gfc_get_shape (rank);
1365 mpz_init_set_ui (delta_mpz, one);
1366 mpz_init_set_ui (nelts, one);
1369 /* Do the initialization now, so that we can cleanup without
1370 keeping track of where we were. */
1371 for (d = 0; d < rank; d++)
1373 mpz_init (delta[d]);
1374 mpz_init (start[d]);
1377 mpz_init (stride[d]);
1381 /* Build the counters to clock through the array reference. */
1383 for (d = 0; d < rank; d++)
1385 /* Make this stretch of code easier on the eye! */
1386 begin = ref->u.ar.start[d];
1387 finish = ref->u.ar.end[d];
1388 step = ref->u.ar.stride[d];
1389 lower = ref->u.ar.as->lower[d];
1390 upper = ref->u.ar.as->upper[d];
1392 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1394 gfc_constructor *ci;
1397 if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1403 gcc_assert (begin->rank == 1);
1404 /* Zero-sized arrays have no shape and no elements, stop early. */
1407 mpz_init_set_ui (nelts, 0);
1411 vecsub[d] = gfc_constructor_first (begin->value.constructor);
1412 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1413 mpz_mul (nelts, nelts, begin->shape[0]);
1414 mpz_set (expr->shape[shape_i++], begin->shape[0]);
1417 for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci))
1419 if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
1420 || mpz_cmp (ci->expr->value.integer,
1421 lower->value.integer) < 0)
1423 gfc_error ("index in dimension %d is out of bounds "
1424 "at %L", d + 1, &ref->u.ar.c_where[d]);
1432 if ((begin && begin->expr_type != EXPR_CONSTANT)
1433 || (finish && finish->expr_type != EXPR_CONSTANT)
1434 || (step && step->expr_type != EXPR_CONSTANT))
1440 /* Obtain the stride. */
1442 mpz_set (stride[d], step->value.integer);
1444 mpz_set_ui (stride[d], one);
1446 if (mpz_cmp_ui (stride[d], 0) == 0)
1447 mpz_set_ui (stride[d], one);
1449 /* Obtain the start value for the index. */
1451 mpz_set (start[d], begin->value.integer);
1453 mpz_set (start[d], lower->value.integer);
1455 mpz_set (ctr[d], start[d]);
1457 /* Obtain the end value for the index. */
1459 mpz_set (end[d], finish->value.integer);
1461 mpz_set (end[d], upper->value.integer);
1463 /* Separate 'if' because elements sometimes arrive with
1465 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1466 mpz_set (end [d], begin->value.integer);
1468 /* Check the bounds. */
1469 if (mpz_cmp (ctr[d], upper->value.integer) > 0
1470 || mpz_cmp (end[d], upper->value.integer) > 0
1471 || mpz_cmp (ctr[d], lower->value.integer) < 0
1472 || mpz_cmp (end[d], lower->value.integer) < 0)
1474 gfc_error ("index in dimension %d is out of bounds "
1475 "at %L", d + 1, &ref->u.ar.c_where[d]);
1480 /* Calculate the number of elements and the shape. */
1481 mpz_set (tmp_mpz, stride[d]);
1482 mpz_add (tmp_mpz, end[d], tmp_mpz);
1483 mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1484 mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1485 mpz_mul (nelts, nelts, tmp_mpz);
1487 /* An element reference reduces the rank of the expression; don't
1488 add anything to the shape array. */
1489 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1490 mpz_set (expr->shape[shape_i++], tmp_mpz);
1493 /* Calculate the 'stride' (=delta) for conversion of the
1494 counter values into the index along the constructor. */
1495 mpz_set (delta[d], delta_mpz);
1496 mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1497 mpz_add_ui (tmp_mpz, tmp_mpz, one);
1498 mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1502 cons = gfc_constructor_first (base);
1504 /* Now clock through the array reference, calculating the index in
1505 the source constructor and transferring the elements to the new
1507 for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1509 if (ref->u.ar.offset)
1510 mpz_set (ptr, ref->u.ar.offset->value.integer);
1512 mpz_init_set_ui (ptr, 0);
1515 for (d = 0; d < rank; d++)
1517 mpz_set (tmp_mpz, ctr[d]);
1518 mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1519 mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1520 mpz_add (ptr, ptr, tmp_mpz);
1522 if (!incr_ctr) continue;
1524 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1526 gcc_assert(vecsub[d]);
1528 if (!gfc_constructor_next (vecsub[d]))
1529 vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor);
1532 vecsub[d] = gfc_constructor_next (vecsub[d]);
1535 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1539 mpz_add (ctr[d], ctr[d], stride[d]);
1541 if (mpz_cmp_ui (stride[d], 0) > 0
1542 ? mpz_cmp (ctr[d], end[d]) > 0
1543 : mpz_cmp (ctr[d], end[d]) < 0)
1544 mpz_set (ctr[d], start[d]);
1550 cons = gfc_constructor_lookup (base, mpz_get_ui (ptr));
1552 gfc_constructor_append_expr (&expr->value.constructor,
1553 gfc_copy_expr (cons->expr), NULL);
1560 mpz_clear (delta_mpz);
1561 mpz_clear (tmp_mpz);
1563 for (d = 0; d < rank; d++)
1565 mpz_clear (delta[d]);
1566 mpz_clear (start[d]);
1569 mpz_clear (stride[d]);
1571 gfc_constructor_free (base);
1575 /* Pull a substring out of an expression. */
1578 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1585 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1586 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1589 *newp = gfc_copy_expr (p);
1590 gfc_free ((*newp)->value.character.string);
1592 end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1593 start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1594 length = end - start + 1;
1596 chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1597 (*newp)->value.character.length = length;
1598 memcpy (chr, &p->value.character.string[start - 1],
1599 length * sizeof (gfc_char_t));
1606 /* Simplify a subobject reference of a constructor. This occurs when
1607 parameter variable values are substituted. */
1610 simplify_const_ref (gfc_expr *p)
1612 gfc_constructor *cons, *c;
1618 switch (p->ref->type)
1621 switch (p->ref->u.ar.type)
1624 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1625 will generate this. */
1626 if (p->expr_type != EXPR_ARRAY)
1628 remove_subobject_ref (p, NULL);
1631 if (find_array_element (p->value.constructor, &p->ref->u.ar,
1638 remove_subobject_ref (p, cons);
1642 if (find_array_section (p, p->ref) == FAILURE)
1644 p->ref->u.ar.type = AR_FULL;
1649 if (p->ref->next != NULL
1650 && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1652 for (c = gfc_constructor_first (p->value.constructor);
1653 c; c = gfc_constructor_next (c))
1655 c->expr->ref = gfc_copy_ref (p->ref->next);
1656 if (simplify_const_ref (c->expr) == FAILURE)
1660 if (p->ts.type == BT_DERIVED
1662 && (c = gfc_constructor_first (p->value.constructor)))
1664 /* There may have been component references. */
1665 p->ts = c->expr->ts;
1669 for (; last_ref->next; last_ref = last_ref->next) {};
1671 if (p->ts.type == BT_CHARACTER
1672 && last_ref->type == REF_SUBSTRING)
1674 /* If this is a CHARACTER array and we possibly took
1675 a substring out of it, update the type-spec's
1676 character length according to the first element
1677 (as all should have the same length). */
1679 if ((c = gfc_constructor_first (p->value.constructor)))
1681 const gfc_expr* first = c->expr;
1682 gcc_assert (first->expr_type == EXPR_CONSTANT);
1683 gcc_assert (first->ts.type == BT_CHARACTER);
1684 string_len = first->value.character.length;
1690 p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
1693 gfc_free_expr (p->ts.u.cl->length);
1696 = gfc_get_int_expr (gfc_default_integer_kind,
1700 gfc_free_ref_list (p->ref);
1711 cons = find_component_ref (p->value.constructor, p->ref);
1712 remove_subobject_ref (p, cons);
1716 if (find_substring_ref (p, &newp) == FAILURE)
1719 gfc_replace_expr (p, newp);
1720 gfc_free_ref_list (p->ref);
1730 /* Simplify a chain of references. */
1733 simplify_ref_chain (gfc_ref *ref, int type)
1737 for (; ref; ref = ref->next)
1742 for (n = 0; n < ref->u.ar.dimen; n++)
1744 if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1746 if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1748 if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1754 if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1756 if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1768 /* Try to substitute the value of a parameter variable. */
1771 simplify_parameter_variable (gfc_expr *p, int type)
1776 e = gfc_copy_expr (p->symtree->n.sym->value);
1782 /* Do not copy subobject refs for constant. */
1783 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1784 e->ref = gfc_copy_ref (p->ref);
1785 t = gfc_simplify_expr (e, type);
1787 /* Only use the simplification if it eliminated all subobject references. */
1788 if (t == SUCCESS && !e->ref)
1789 gfc_replace_expr (p, e);
1796 /* Given an expression, simplify it by collapsing constant
1797 expressions. Most simplification takes place when the expression
1798 tree is being constructed. If an intrinsic function is simplified
1799 at some point, we get called again to collapse the result against
1802 We work by recursively simplifying expression nodes, simplifying
1803 intrinsic functions where possible, which can lead to further
1804 constant collapsing. If an operator has constant operand(s), we
1805 rip the expression apart, and rebuild it, hoping that it becomes
1808 The expression type is defined for:
1809 0 Basic expression parsing
1810 1 Simplifying array constructors -- will substitute
1812 Returns FAILURE on error, SUCCESS otherwise.
1813 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1816 gfc_simplify_expr (gfc_expr *p, int type)
1818 gfc_actual_arglist *ap;
1823 switch (p->expr_type)
1830 for (ap = p->value.function.actual; ap; ap = ap->next)
1831 if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1834 if (p->value.function.isym != NULL
1835 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1840 case EXPR_SUBSTRING:
1841 if (simplify_ref_chain (p->ref, type) == FAILURE)
1844 if (gfc_is_constant_expr (p))
1850 if (p->ref && p->ref->u.ss.start)
1852 gfc_extract_int (p->ref->u.ss.start, &start);
1853 start--; /* Convert from one-based to zero-based. */
1856 end = p->value.character.length;
1857 if (p->ref && p->ref->u.ss.end)
1858 gfc_extract_int (p->ref->u.ss.end, &end);
1860 s = gfc_get_wide_string (end - start + 2);
1861 memcpy (s, p->value.character.string + start,
1862 (end - start) * sizeof (gfc_char_t));
1863 s[end - start + 1] = '\0'; /* TODO: C-style string. */
1864 gfc_free (p->value.character.string);
1865 p->value.character.string = s;
1866 p->value.character.length = end - start;
1867 p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1868 p->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
1870 p->value.character.length);
1871 gfc_free_ref_list (p->ref);
1873 p->expr_type = EXPR_CONSTANT;
1878 if (simplify_intrinsic_op (p, type) == FAILURE)
1883 /* Only substitute array parameter variables if we are in an
1884 initialization expression, or we want a subsection. */
1885 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1886 && (gfc_init_expr || p->ref
1887 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1889 if (simplify_parameter_variable (p, type) == FAILURE)
1896 gfc_simplify_iterator_var (p);
1899 /* Simplify subcomponent references. */
1900 if (simplify_ref_chain (p->ref, type) == FAILURE)
1905 case EXPR_STRUCTURE:
1907 if (simplify_ref_chain (p->ref, type) == FAILURE)
1910 if (simplify_constructor (p->value.constructor, type) == FAILURE)
1913 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1914 && p->ref->u.ar.type == AR_FULL)
1915 gfc_expand_constructor (p);
1917 if (simplify_const_ref (p) == FAILURE)
1932 /* Returns the type of an expression with the exception that iterator
1933 variables are automatically integers no matter what else they may
1939 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1946 /* Check an intrinsic arithmetic operation to see if it is consistent
1947 with some type of expression. */
1949 static gfc_try check_init_expr (gfc_expr *);
1952 /* Scalarize an expression for an elemental intrinsic call. */
1955 scalarize_intrinsic_call (gfc_expr *e)
1957 gfc_actual_arglist *a, *b;
1958 gfc_constructor_base ctor;
1959 gfc_constructor *args[5];
1960 gfc_constructor *ci, *new_ctor;
1961 gfc_expr *expr, *old;
1962 int n, i, rank[5], array_arg;
1964 /* Find which, if any, arguments are arrays. Assume that the old
1965 expression carries the type information and that the first arg
1966 that is an array expression carries all the shape information.*/
1968 a = e->value.function.actual;
1969 for (; a; a = a->next)
1972 if (a->expr->expr_type != EXPR_ARRAY)
1975 expr = gfc_copy_expr (a->expr);
1982 old = gfc_copy_expr (e);
1984 gfc_constructor_free (expr->value.constructor);
1985 expr->value.constructor = NULL;
1987 expr->where = old->where;
1988 expr->expr_type = EXPR_ARRAY;
1990 /* Copy the array argument constructors into an array, with nulls
1993 a = old->value.function.actual;
1994 for (; a; a = a->next)
1996 /* Check that this is OK for an initialization expression. */
1997 if (a->expr && check_init_expr (a->expr) == FAILURE)
2001 if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
2003 rank[n] = a->expr->rank;
2004 ctor = a->expr->symtree->n.sym->value->value.constructor;
2005 args[n] = gfc_constructor_first (ctor);
2007 else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
2010 rank[n] = a->expr->rank;
2013 ctor = gfc_constructor_copy (a->expr->value.constructor);
2014 args[n] = gfc_constructor_first (ctor);
2023 /* Using the array argument as the master, step through the array
2024 calling the function for each element and advancing the array
2025 constructors together. */
2026 for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
2028 new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
2029 gfc_copy_expr (old), NULL);
2031 gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
2033 b = old->value.function.actual;
2034 for (i = 0; i < n; i++)
2037 new_ctor->expr->value.function.actual
2038 = a = gfc_get_actual_arglist ();
2041 a->next = gfc_get_actual_arglist ();
2046 a->expr = gfc_copy_expr (args[i]->expr);
2048 a->expr = gfc_copy_expr (b->expr);
2053 /* Simplify the function calls. If the simplification fails, the
2054 error will be flagged up down-stream or the library will deal
2056 gfc_simplify_expr (new_ctor->expr, 0);
2058 for (i = 0; i < n; i++)
2060 args[i] = gfc_constructor_next (args[i]);
2062 for (i = 1; i < n; i++)
2063 if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
2064 || (args[i] == NULL && args[array_arg - 1] != NULL)))
2070 gfc_free_expr (old);
2074 gfc_error_now ("elemental function arguments at %C are not compliant");
2077 gfc_free_expr (expr);
2078 gfc_free_expr (old);
2084 check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
2086 gfc_expr *op1 = e->value.op.op1;
2087 gfc_expr *op2 = e->value.op.op2;
2089 if ((*check_function) (op1) == FAILURE)
2092 switch (e->value.op.op)
2094 case INTRINSIC_UPLUS:
2095 case INTRINSIC_UMINUS:
2096 if (!numeric_type (et0 (op1)))
2101 case INTRINSIC_EQ_OS:
2103 case INTRINSIC_NE_OS:
2105 case INTRINSIC_GT_OS:
2107 case INTRINSIC_GE_OS:
2109 case INTRINSIC_LT_OS:
2111 case INTRINSIC_LE_OS:
2112 if ((*check_function) (op2) == FAILURE)
2115 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
2116 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
2118 gfc_error ("Numeric or CHARACTER operands are required in "
2119 "expression at %L", &e->where);
2124 case INTRINSIC_PLUS:
2125 case INTRINSIC_MINUS:
2126 case INTRINSIC_TIMES:
2127 case INTRINSIC_DIVIDE:
2128 case INTRINSIC_POWER:
2129 if ((*check_function) (op2) == FAILURE)
2132 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
2137 case INTRINSIC_CONCAT:
2138 if ((*check_function) (op2) == FAILURE)
2141 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
2143 gfc_error ("Concatenation operator in expression at %L "
2144 "must have two CHARACTER operands", &op1->where);
2148 if (op1->ts.kind != op2->ts.kind)
2150 gfc_error ("Concat operator at %L must concatenate strings of the "
2151 "same kind", &e->where);
2158 if (et0 (op1) != BT_LOGICAL)
2160 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2161 "operand", &op1->where);
2170 case INTRINSIC_NEQV:
2171 if ((*check_function) (op2) == FAILURE)
2174 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
2176 gfc_error ("LOGICAL operands are required in expression at %L",
2183 case INTRINSIC_PARENTHESES:
2187 gfc_error ("Only intrinsic operators can be used in expression at %L",
2195 gfc_error ("Numeric operands are required in expression at %L", &e->where);
2200 /* F2003, 7.1.7 (3): In init expression, allocatable components
2201 must not be data-initialized. */
2203 check_alloc_comp_init (gfc_expr *e)
2205 gfc_component *comp;
2206 gfc_constructor *ctor;
2208 gcc_assert (e->expr_type == EXPR_STRUCTURE);
2209 gcc_assert (e->ts.type == BT_DERIVED);
2211 for (comp = e->ts.u.derived->components,
2212 ctor = gfc_constructor_first (e->value.constructor);
2213 comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
2215 if (comp->attr.allocatable
2216 && ctor->expr->expr_type != EXPR_NULL)
2218 gfc_error("Invalid initialization expression for ALLOCATABLE "
2219 "component '%s' in structure constructor at %L",
2220 comp->name, &ctor->expr->where);
2229 check_init_expr_arguments (gfc_expr *e)
2231 gfc_actual_arglist *ap;
2233 for (ap = e->value.function.actual; ap; ap = ap->next)
2234 if (check_init_expr (ap->expr) == FAILURE)
2240 static gfc_try check_restricted (gfc_expr *);
2242 /* F95, 7.1.6.1, Initialization expressions, (7)
2243 F2003, 7.1.7 Initialization expression, (8) */
2246 check_inquiry (gfc_expr *e, int not_restricted)
2249 const char *const *functions;
2251 static const char *const inquiry_func_f95[] = {
2252 "lbound", "shape", "size", "ubound",
2253 "bit_size", "len", "kind",
2254 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2255 "precision", "radix", "range", "tiny",
2259 static const char *const inquiry_func_f2003[] = {
2260 "lbound", "shape", "size", "ubound",
2261 "bit_size", "len", "kind",
2262 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2263 "precision", "radix", "range", "tiny",
2268 gfc_actual_arglist *ap;
2270 if (!e->value.function.isym
2271 || !e->value.function.isym->inquiry)
2274 /* An undeclared parameter will get us here (PR25018). */
2275 if (e->symtree == NULL)
2278 name = e->symtree->n.sym->name;
2280 functions = (gfc_option.warn_std & GFC_STD_F2003)
2281 ? inquiry_func_f2003 : inquiry_func_f95;
2283 for (i = 0; functions[i]; i++)
2284 if (strcmp (functions[i], name) == 0)
2287 if (functions[i] == NULL)
2290 /* At this point we have an inquiry function with a variable argument. The
2291 type of the variable might be undefined, but we need it now, because the
2292 arguments of these functions are not allowed to be undefined. */
2294 for (ap = e->value.function.actual; ap; ap = ap->next)
2299 if (ap->expr->ts.type == BT_UNKNOWN)
2301 if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2302 && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)
2306 ap->expr->ts = ap->expr->symtree->n.sym->ts;
2309 /* Assumed character length will not reduce to a constant expression
2310 with LEN, as required by the standard. */
2311 if (i == 5 && not_restricted
2312 && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2313 && ap->expr->symtree->n.sym->ts.u.cl->length == NULL)
2315 gfc_error ("Assumed character length variable '%s' in constant "
2316 "expression at %L", e->symtree->n.sym->name, &e->where);
2319 else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
2322 if (not_restricted == 0
2323 && ap->expr->expr_type != EXPR_VARIABLE
2324 && check_restricted (ap->expr) == FAILURE)
2332 /* F95, 7.1.6.1, Initialization expressions, (5)
2333 F2003, 7.1.7 Initialization expression, (5) */
2336 check_transformational (gfc_expr *e)
2338 static const char * const trans_func_f95[] = {
2339 "repeat", "reshape", "selected_int_kind",
2340 "selected_real_kind", "transfer", "trim", NULL
2343 static const char * const trans_func_f2003[] = {
2344 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2345 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2346 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2347 "trim", "unpack", NULL
2352 const char *const *functions;
2354 if (!e->value.function.isym
2355 || !e->value.function.isym->transformational)
2358 name = e->symtree->n.sym->name;
2360 functions = (gfc_option.allow_std & GFC_STD_F2003)
2361 ? trans_func_f2003 : trans_func_f95;
2363 /* NULL() is dealt with below. */
2364 if (strcmp ("null", name) == 0)
2367 for (i = 0; functions[i]; i++)
2368 if (strcmp (functions[i], name) == 0)
2371 if (functions[i] == NULL)
2373 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2374 "in an initialization expression", name, &e->where);
2378 return check_init_expr_arguments (e);
2382 /* F95, 7.1.6.1, Initialization expressions, (6)
2383 F2003, 7.1.7 Initialization expression, (6) */
2386 check_null (gfc_expr *e)
2388 if (strcmp ("null", e->symtree->n.sym->name) != 0)
2391 return check_init_expr_arguments (e);
2396 check_elemental (gfc_expr *e)
2398 if (!e->value.function.isym
2399 || !e->value.function.isym->elemental)
2402 if (e->ts.type != BT_INTEGER
2403 && e->ts.type != BT_CHARACTER
2404 && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2405 "nonstandard initialization expression at %L",
2406 &e->where) == FAILURE)
2409 return check_init_expr_arguments (e);
2414 check_conversion (gfc_expr *e)
2416 if (!e->value.function.isym
2417 || !e->value.function.isym->conversion)
2420 return check_init_expr_arguments (e);
2424 /* Verify that an expression is an initialization expression. A side
2425 effect is that the expression tree is reduced to a single constant
2426 node if all goes well. This would normally happen when the
2427 expression is constructed but function references are assumed to be
2428 intrinsics in the context of initialization expressions. If
2429 FAILURE is returned an error message has been generated. */
2432 check_init_expr (gfc_expr *e)
2440 switch (e->expr_type)
2443 t = check_intrinsic_op (e, check_init_expr);
2445 t = gfc_simplify_expr (e, 0);
2453 gfc_intrinsic_sym* isym;
2456 sym = e->symtree->n.sym;
2457 if (!gfc_is_intrinsic (sym, 0, e->where)
2458 || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2460 gfc_error ("Function '%s' in initialization expression at %L "
2461 "must be an intrinsic function",
2462 e->symtree->n.sym->name, &e->where);
2466 if ((m = check_conversion (e)) == MATCH_NO
2467 && (m = check_inquiry (e, 1)) == MATCH_NO
2468 && (m = check_null (e)) == MATCH_NO
2469 && (m = check_transformational (e)) == MATCH_NO
2470 && (m = check_elemental (e)) == MATCH_NO)
2472 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2473 "in an initialization expression",
2474 e->symtree->n.sym->name, &e->where);
2478 /* Try to scalarize an elemental intrinsic function that has an
2480 isym = gfc_find_function (e->symtree->n.sym->name);
2481 if (isym && isym->elemental
2482 && (t = scalarize_intrinsic_call (e)) == SUCCESS)
2487 t = gfc_simplify_expr (e, 0);
2494 if (gfc_check_iter_variable (e) == SUCCESS)
2497 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2499 /* A PARAMETER shall not be used to define itself, i.e.
2500 REAL, PARAMETER :: x = transfer(0, x)
2502 if (!e->symtree->n.sym->value)
2504 gfc_error("PARAMETER '%s' is used at %L before its definition "
2505 "is complete", e->symtree->n.sym->name, &e->where);
2509 t = simplify_parameter_variable (e, 0);
2514 if (gfc_in_match_data ())
2519 if (e->symtree->n.sym->as)
2521 switch (e->symtree->n.sym->as->type)
2523 case AS_ASSUMED_SIZE:
2524 gfc_error ("Assumed size array '%s' at %L is not permitted "
2525 "in an initialization expression",
2526 e->symtree->n.sym->name, &e->where);
2529 case AS_ASSUMED_SHAPE:
2530 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2531 "in an initialization expression",
2532 e->symtree->n.sym->name, &e->where);
2536 gfc_error ("Deferred array '%s' at %L is not permitted "
2537 "in an initialization expression",
2538 e->symtree->n.sym->name, &e->where);
2542 gfc_error ("Array '%s' at %L is a variable, which does "
2543 "not reduce to a constant expression",
2544 e->symtree->n.sym->name, &e->where);
2552 gfc_error ("Parameter '%s' at %L has not been declared or is "
2553 "a variable, which does not reduce to a constant "
2554 "expression", e->symtree->n.sym->name, &e->where);
2563 case EXPR_SUBSTRING:
2564 t = check_init_expr (e->ref->u.ss.start);
2568 t = check_init_expr (e->ref->u.ss.end);
2570 t = gfc_simplify_expr (e, 0);
2574 case EXPR_STRUCTURE:
2575 t = e->ts.is_iso_c ? SUCCESS : FAILURE;
2579 t = check_alloc_comp_init (e);
2583 t = gfc_check_constructor (e, check_init_expr);
2590 t = gfc_check_constructor (e, check_init_expr);
2594 t = gfc_expand_constructor (e);
2598 t = gfc_check_constructor_type (e);
2602 gfc_internal_error ("check_init_expr(): Unknown expression type");
2608 /* Reduces a general expression to an initialization expression (a constant).
2609 This used to be part of gfc_match_init_expr.
2610 Note that this function doesn't free the given expression on FAILURE. */
2613 gfc_reduce_init_expr (gfc_expr *expr)
2618 t = gfc_resolve_expr (expr);
2620 t = check_init_expr (expr);
2626 if (expr->expr_type == EXPR_ARRAY)
2628 if (gfc_check_constructor_type (expr) == FAILURE)
2630 if (gfc_expand_constructor (expr) == FAILURE)
2638 /* Match an initialization expression. We work by first matching an
2639 expression, then reducing it to a constant. The reducing it to
2640 constant part requires a global variable to flag the prohibition
2641 of a non-integer exponent in -std=f95 mode. */
2643 bool init_flag = false;
2646 gfc_match_init_expr (gfc_expr **result)
2656 m = gfc_match_expr (&expr);
2663 t = gfc_reduce_init_expr (expr);
2666 gfc_free_expr (expr);
2678 /* Given an actual argument list, test to see that each argument is a
2679 restricted expression and optionally if the expression type is
2680 integer or character. */
2683 restricted_args (gfc_actual_arglist *a)
2685 for (; a; a = a->next)
2687 if (check_restricted (a->expr) == FAILURE)
2695 /************* Restricted/specification expressions *************/
2698 /* Make sure a non-intrinsic function is a specification function. */
2701 external_spec_function (gfc_expr *e)
2705 f = e->value.function.esym;
2707 if (f->attr.proc == PROC_ST_FUNCTION)
2709 gfc_error ("Specification function '%s' at %L cannot be a statement "
2710 "function", f->name, &e->where);
2714 if (f->attr.proc == PROC_INTERNAL)
2716 gfc_error ("Specification function '%s' at %L cannot be an internal "
2717 "function", f->name, &e->where);
2721 if (!f->attr.pure && !f->attr.elemental)
2723 gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2728 if (f->attr.recursive)
2730 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2731 f->name, &e->where);
2735 return restricted_args (e->value.function.actual);
2739 /* Check to see that a function reference to an intrinsic is a
2740 restricted expression. */
2743 restricted_intrinsic (gfc_expr *e)
2745 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2746 if (check_inquiry (e, 0) == MATCH_YES)
2749 return restricted_args (e->value.function.actual);
2753 /* Check the expressions of an actual arglist. Used by check_restricted. */
2756 check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
2758 for (; arg; arg = arg->next)
2759 if (checker (arg->expr) == FAILURE)
2766 /* Check the subscription expressions of a reference chain with a checking
2767 function; used by check_restricted. */
2770 check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
2780 for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2782 if (checker (ref->u.ar.start[dim]) == FAILURE)
2784 if (checker (ref->u.ar.end[dim]) == FAILURE)
2786 if (checker (ref->u.ar.stride[dim]) == FAILURE)
2792 /* Nothing needed, just proceed to next reference. */
2796 if (checker (ref->u.ss.start) == FAILURE)
2798 if (checker (ref->u.ss.end) == FAILURE)
2807 return check_references (ref->next, checker);
2811 /* Verify that an expression is a restricted expression. Like its
2812 cousin check_init_expr(), an error message is generated if we
2816 check_restricted (gfc_expr *e)
2824 switch (e->expr_type)
2827 t = check_intrinsic_op (e, check_restricted);
2829 t = gfc_simplify_expr (e, 0);
2834 if (e->value.function.esym)
2836 t = check_arglist (e->value.function.actual, &check_restricted);
2838 t = external_spec_function (e);
2842 if (e->value.function.isym && e->value.function.isym->inquiry)
2845 t = check_arglist (e->value.function.actual, &check_restricted);
2848 t = restricted_intrinsic (e);
2853 sym = e->symtree->n.sym;
2856 /* If a dummy argument appears in a context that is valid for a
2857 restricted expression in an elemental procedure, it will have
2858 already been simplified away once we get here. Therefore we
2859 don't need to jump through hoops to distinguish valid from
2861 if (sym->attr.dummy && sym->ns == gfc_current_ns
2862 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2864 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2865 sym->name, &e->where);
2869 if (sym->attr.optional)
2871 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2872 sym->name, &e->where);
2876 if (sym->attr.intent == INTENT_OUT)
2878 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2879 sym->name, &e->where);
2883 /* Check reference chain if any. */
2884 if (check_references (e->ref, &check_restricted) == FAILURE)
2887 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2888 processed in resolve.c(resolve_formal_arglist). This is done so
2889 that host associated dummy array indices are accepted (PR23446).
2890 This mechanism also does the same for the specification expressions
2891 of array-valued functions. */
2893 || sym->attr.in_common
2894 || sym->attr.use_assoc
2896 || sym->attr.implied_index
2897 || sym->attr.flavor == FL_PARAMETER
2898 || (sym->ns && sym->ns == gfc_current_ns->parent)
2899 || (sym->ns && gfc_current_ns->parent
2900 && sym->ns == gfc_current_ns->parent->parent)
2901 || (sym->ns->proc_name != NULL
2902 && sym->ns->proc_name->attr.flavor == FL_MODULE)
2903 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2909 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2910 sym->name, &e->where);
2911 /* Prevent a repetition of the error. */
2920 case EXPR_SUBSTRING:
2921 t = gfc_specification_expr (e->ref->u.ss.start);
2925 t = gfc_specification_expr (e->ref->u.ss.end);
2927 t = gfc_simplify_expr (e, 0);
2931 case EXPR_STRUCTURE:
2932 t = gfc_check_constructor (e, check_restricted);
2936 t = gfc_check_constructor (e, check_restricted);
2940 gfc_internal_error ("check_restricted(): Unknown expression type");
2947 /* Check to see that an expression is a specification expression. If
2948 we return FAILURE, an error has been generated. */
2951 gfc_specification_expr (gfc_expr *e)
2953 gfc_component *comp;
2958 if (e->ts.type != BT_INTEGER)
2960 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2961 &e->where, gfc_basic_typename (e->ts.type));
2965 if (e->expr_type == EXPR_FUNCTION
2966 && !e->value.function.isym
2967 && !e->value.function.esym
2968 && !gfc_pure (e->symtree->n.sym)
2969 && (!gfc_is_proc_ptr_comp (e, &comp)
2970 || !comp->attr.pure))
2972 gfc_error ("Function '%s' at %L must be PURE",
2973 e->symtree->n.sym->name, &e->where);
2974 /* Prevent repeat error messages. */
2975 e->symtree->n.sym->attr.pure = 1;
2981 gfc_error ("Expression at %L must be scalar", &e->where);
2985 if (gfc_simplify_expr (e, 0) == FAILURE)
2988 return check_restricted (e);
2992 /************** Expression conformance checks. *************/
2994 /* Given two expressions, make sure that the arrays are conformable. */
2997 gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
2999 int op1_flag, op2_flag, d;
3000 mpz_t op1_size, op2_size;
3006 if (op1->rank == 0 || op2->rank == 0)
3009 va_start (argp, optype_msgid);
3010 vsnprintf (buffer, 240, optype_msgid, argp);
3013 if (op1->rank != op2->rank)
3015 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
3016 op1->rank, op2->rank, &op1->where);
3022 for (d = 0; d < op1->rank; d++)
3024 op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
3025 op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
3027 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
3029 gfc_error ("Different shape for %s at %L on dimension %d "
3030 "(%d and %d)", _(buffer), &op1->where, d + 1,
3031 (int) mpz_get_si (op1_size),
3032 (int) mpz_get_si (op2_size));
3038 mpz_clear (op1_size);
3040 mpz_clear (op2_size);
3050 /* Given an assignable expression and an arbitrary expression, make
3051 sure that the assignment can take place. */
3054 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
3060 sym = lvalue->symtree->n.sym;
3062 /* Check INTENT(IN), unless the object itself is the component or
3063 sub-component of a pointer. */
3064 has_pointer = sym->attr.pointer;
3066 for (ref = lvalue->ref; ref; ref = ref->next)
3067 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
3073 if (!has_pointer && sym->attr.intent == INTENT_IN)
3075 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3076 sym->name, &lvalue->where);
3080 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3081 variable local to a function subprogram. Its existence begins when
3082 execution of the function is initiated and ends when execution of the
3083 function is terminated...
3084 Therefore, the left hand side is no longer a variable, when it is: */
3085 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
3086 && !sym->attr.external)
3091 /* (i) Use associated; */
3092 if (sym->attr.use_assoc)
3095 /* (ii) The assignment is in the main program; or */
3096 if (gfc_current_ns->proc_name->attr.is_main_program)
3099 /* (iii) A module or internal procedure... */
3100 if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
3101 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
3102 && gfc_current_ns->parent
3103 && (!(gfc_current_ns->parent->proc_name->attr.function
3104 || gfc_current_ns->parent->proc_name->attr.subroutine)
3105 || gfc_current_ns->parent->proc_name->attr.is_main_program))
3107 /* ... that is not a function... */
3108 if (!gfc_current_ns->proc_name->attr.function)
3111 /* ... or is not an entry and has a different name. */
3112 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
3116 /* (iv) Host associated and not the function symbol or the
3117 parent result. This picks up sibling references, which
3118 cannot be entries. */
3119 if (!sym->attr.entry
3120 && sym->ns == gfc_current_ns->parent
3121 && sym != gfc_current_ns->proc_name
3122 && sym != gfc_current_ns->parent->proc_name->result)
3127 gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
3132 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
3134 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3135 lvalue->rank, rvalue->rank, &lvalue->where);
3139 if (lvalue->ts.type == BT_UNKNOWN)
3141 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3146 if (rvalue->expr_type == EXPR_NULL)
3148 if (has_pointer && (ref == NULL || ref->next == NULL)
3149 && lvalue->symtree->n.sym->attr.data)
3153 gfc_error ("NULL appears on right-hand side in assignment at %L",
3159 /* This is possibly a typo: x = f() instead of x => f(). */
3160 if (gfc_option.warn_surprising
3161 && rvalue->expr_type == EXPR_FUNCTION
3162 && rvalue->symtree->n.sym->attr.pointer)
3163 gfc_warning ("POINTER valued function appears on right-hand side of "
3164 "assignment at %L", &rvalue->where);
3166 /* Check size of array assignments. */
3167 if (lvalue->rank != 0 && rvalue->rank != 0
3168 && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
3171 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
3172 && lvalue->symtree->n.sym->attr.data
3173 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
3174 "initialize non-integer variable '%s'",
3175 &rvalue->where, lvalue->symtree->n.sym->name)
3178 else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
3179 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
3180 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3181 &rvalue->where) == FAILURE)
3184 /* Handle the case of a BOZ literal on the RHS. */
3185 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
3188 if (gfc_option.warn_surprising)
3189 gfc_warning ("BOZ literal at %L is bitwise transferred "
3190 "non-integer symbol '%s'", &rvalue->where,
3191 lvalue->symtree->n.sym->name);
3192 if (!gfc_convert_boz (rvalue, &lvalue->ts))
3194 if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
3196 if (rc == ARITH_UNDERFLOW)
3197 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3198 ". This check can be disabled with the option "
3199 "-fno-range-check", &rvalue->where);
3200 else if (rc == ARITH_OVERFLOW)
3201 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3202 ". This check can be disabled with the option "
3203 "-fno-range-check", &rvalue->where);
3204 else if (rc == ARITH_NAN)
3205 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3206 ". This check can be disabled with the option "
3207 "-fno-range-check", &rvalue->where);
3212 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
3215 /* Only DATA Statements come here. */
3218 /* Numeric can be converted to any other numeric. And Hollerith can be
3219 converted to any other type. */
3220 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3221 || rvalue->ts.type == BT_HOLLERITH)
3224 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3227 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3228 "conversion of %s to %s", &lvalue->where,
3229 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3234 /* Assignment is the only case where character variables of different
3235 kind values can be converted into one another. */
3236 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3238 if (lvalue->ts.kind != rvalue->ts.kind)
3239 gfc_convert_chartype (rvalue, &lvalue->ts);
3244 return gfc_convert_type (rvalue, &lvalue->ts, 1);
3248 /* Check that a pointer assignment is OK. We first check lvalue, and
3249 we only check rvalue if it's not an assignment to NULL() or a
3250 NULLIFY statement. */
3253 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3255 symbol_attribute attr;
3258 int pointer, check_intent_in, proc_pointer;
3260 if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3261 && !lvalue->symtree->n.sym->attr.proc_pointer)
3263 gfc_error ("Pointer assignment target is not a POINTER at %L",
3268 if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3269 && lvalue->symtree->n.sym->attr.use_assoc
3270 && !lvalue->symtree->n.sym->attr.proc_pointer)
3272 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3273 "l-value since it is a procedure",
3274 lvalue->symtree->n.sym->name, &lvalue->where);
3279 /* Check INTENT(IN), unless the object itself is the component or
3280 sub-component of a pointer. */
3281 check_intent_in = 1;
3282 pointer = lvalue->symtree->n.sym->attr.pointer;
3283 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3285 for (ref = lvalue->ref; ref; ref = ref->next)
3288 check_intent_in = 0;
3290 if (ref->type == REF_COMPONENT)
3292 pointer = ref->u.c.component->attr.pointer;
3293 proc_pointer = ref->u.c.component->attr.proc_pointer;
3296 if (ref->type == REF_ARRAY && ref->next == NULL)
3298 if (ref->u.ar.type == AR_FULL)
3301 if (ref->u.ar.type != AR_SECTION)
3303 gfc_error ("Expected bounds specification for '%s' at %L",
3304 lvalue->symtree->n.sym->name, &lvalue->where);
3308 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3309 "specification for '%s' in pointer assignment "
3310 "at %L", lvalue->symtree->n.sym->name,
3311 &lvalue->where) == FAILURE)
3314 gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3315 "in gfortran", &lvalue->where);
3316 /* TODO: See PR 29785. Add checks that all lbounds are specified and
3317 either never or always the upper-bound; strides shall not be
3323 if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
3325 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3326 lvalue->symtree->n.sym->name, &lvalue->where);
3330 if (!pointer && !proc_pointer
3331 && !(lvalue->ts.type == BT_CLASS
3332 && lvalue->ts.u.derived->components->attr.pointer))
3334 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
3338 is_pure = gfc_pure (NULL);
3340 if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
3341 && lvalue->symtree->n.sym->value != rvalue)
3343 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
3347 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3348 kind, etc for lvalue and rvalue must match, and rvalue must be a
3349 pure variable if we're in a pure function. */
3350 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3353 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3354 if (lvalue->expr_type == EXPR_VARIABLE
3355 && gfc_is_coindexed (lvalue))
3358 for (ref = lvalue->ref; ref; ref = ref->next)
3359 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3361 gfc_error ("Pointer object at %L shall not have a coindex",
3367 /* Checks on rvalue for procedure pointer assignments. */
3372 gfc_component *comp;
3375 attr = gfc_expr_attr (rvalue);
3376 if (!((rvalue->expr_type == EXPR_NULL)
3377 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3378 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
3379 || (rvalue->expr_type == EXPR_VARIABLE
3380 && attr.flavor == FL_PROCEDURE)))
3382 gfc_error ("Invalid procedure pointer assignment at %L",
3388 gfc_error ("Abstract interface '%s' is invalid "
3389 "in procedure pointer assignment at %L",
3390 rvalue->symtree->name, &rvalue->where);
3393 /* Check for C727. */
3394 if (attr.flavor == FL_PROCEDURE)
3396 if (attr.proc == PROC_ST_FUNCTION)
3398 gfc_error ("Statement function '%s' is invalid "
3399 "in procedure pointer assignment at %L",
3400 rvalue->symtree->name, &rvalue->where);
3403 if (attr.proc == PROC_INTERNAL &&
3404 gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
3405 "invalid in procedure pointer assignment at %L",
3406 rvalue->symtree->name, &rvalue->where) == FAILURE)
3410 /* Ensure that the calling convention is the same. As other attributes
3411 such as DLLEXPORT may differ, one explicitly only tests for the
3412 calling conventions. */
3413 if (rvalue->expr_type == EXPR_VARIABLE
3414 && lvalue->symtree->n.sym->attr.ext_attr
3415 != rvalue->symtree->n.sym->attr.ext_attr)
3417 symbol_attribute calls;
3420 gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
3421 gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
3422 gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
3424 if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
3425 != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
3427 gfc_error ("Mismatch in the procedure pointer assignment "
3428 "at %L: mismatch in the calling convention",
3434 if (gfc_is_proc_ptr_comp (lvalue, &comp))
3435 s1 = comp->ts.interface;
3437 s1 = lvalue->symtree->n.sym;
3439 if (gfc_is_proc_ptr_comp (rvalue, &comp))
3441 s2 = comp->ts.interface;
3444 else if (rvalue->expr_type == EXPR_FUNCTION)
3446 s2 = rvalue->symtree->n.sym->result;
3447 name = rvalue->symtree->n.sym->result->name;
3451 s2 = rvalue->symtree->n.sym;
3452 name = rvalue->symtree->n.sym->name;
3455 if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
3458 gfc_error ("Interface mismatch in procedure pointer assignment "
3459 "at %L: %s", &rvalue->where, err);
3466 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3468 gfc_error ("Different types in pointer assignment at %L; attempted "
3469 "assignment of %s to %s", &lvalue->where,
3470 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3474 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
3476 gfc_error ("Different kind type parameters in pointer "
3477 "assignment at %L", &lvalue->where);
3481 if (lvalue->rank != rvalue->rank)
3483 gfc_error ("Different ranks in pointer assignment at %L",
3488 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3489 if (rvalue->expr_type == EXPR_NULL)
3492 if (lvalue->ts.type == BT_CHARACTER)
3494 gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3499 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3500 lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3502 attr = gfc_expr_attr (rvalue);
3503 if (!attr.target && !attr.pointer)
3505 gfc_error ("Pointer assignment target is neither TARGET "
3506 "nor POINTER at %L", &rvalue->where);
3510 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3512 gfc_error ("Bad target in pointer assignment in PURE "
3513 "procedure at %L", &rvalue->where);
3516 if (gfc_has_vector_index (rvalue))
3518 gfc_error ("Pointer assignment with vector subscript "
3519 "on rhs at %L", &rvalue->where);
3523 if (attr.is_protected && attr.use_assoc
3524 && !(attr.pointer || attr.proc_pointer))
3526 gfc_error ("Pointer assignment target has PROTECTED "
3527 "attribute at %L", &rvalue->where);
3531 /* F2008, C725. For PURE also C1283. */
3532 if (rvalue->expr_type == EXPR_VARIABLE
3533 && gfc_is_coindexed (rvalue))
3536 for (ref = rvalue->ref; ref; ref = ref->next)
3537 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3539 gfc_error ("Data target at %L shall not have a coindex",
3549 /* Relative of gfc_check_assign() except that the lvalue is a single
3550 symbol. Used for initialization assignments. */
3553 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3558 memset (&lvalue, '\0', sizeof (gfc_expr));
3560 lvalue.expr_type = EXPR_VARIABLE;
3561 lvalue.ts = sym->ts;
3563 lvalue.rank = sym->as->rank;
3564 lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3565 lvalue.symtree->n.sym = sym;
3566 lvalue.where = sym->declared_at;
3568 if (sym->attr.pointer || sym->attr.proc_pointer
3569 || (sym->ts.type == BT_CLASS
3570 && sym->ts.u.derived->components->attr.pointer
3571 && rvalue->expr_type == EXPR_NULL))
3572 r = gfc_check_pointer_assign (&lvalue, rvalue);
3574 r = gfc_check_assign (&lvalue, rvalue, 1);
3576 gfc_free (lvalue.symtree);
3582 /* Get an expression for a default initializer. */
3585 gfc_default_initializer (gfc_typespec *ts)
3588 gfc_component *comp;
3590 /* See if we have a default initializer. */
3591 for (comp = ts->u.derived->components; comp; comp = comp->next)
3592 if (comp->initializer || comp->attr.allocatable)
3598 init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
3599 &ts->u.derived->declared_at);
3602 for (comp = ts->u.derived->components; comp; comp = comp->next)
3604 gfc_constructor *ctor = gfc_constructor_get();
3606 if (comp->initializer)
3607 ctor->expr = gfc_copy_expr (comp->initializer);
3609 if (comp->attr.allocatable)
3611 ctor->expr = gfc_get_expr ();
3612 ctor->expr->expr_type = EXPR_NULL;
3613 ctor->expr->ts = comp->ts;
3616 gfc_constructor_append (&init->value.constructor, ctor);
3623 /* Given a symbol, create an expression node with that symbol as a
3624 variable. If the symbol is array valued, setup a reference of the
3628 gfc_get_variable_expr (gfc_symtree *var)
3632 e = gfc_get_expr ();
3633 e->expr_type = EXPR_VARIABLE;
3635 e->ts = var->n.sym->ts;
3637 if (var->n.sym->as != NULL)
3639 e->rank = var->n.sym->as->rank;
3640 e->ref = gfc_get_ref ();
3641 e->ref->type = REF_ARRAY;
3642 e->ref->u.ar.type = AR_FULL;
3649 /* Returns the array_spec of a full array expression. A NULL is
3650 returned otherwise. */
3652 gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
3657 if (expr->rank == 0)
3660 /* Follow any component references. */
3661 if (expr->expr_type == EXPR_VARIABLE
3662 || expr->expr_type == EXPR_CONSTANT)
3664 as = expr->symtree->n.sym->as;
3665 for (ref = expr->ref; ref; ref = ref->next)
3670 as = ref->u.c.component->as;
3678 switch (ref->u.ar.type)
3701 /* General expression traversal function. */
3704 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3705 bool (*func)(gfc_expr *, gfc_symbol *, int*),
3710 gfc_actual_arglist *args;
3717 if ((*func) (expr, sym, &f))
3720 if (expr->ts.type == BT_CHARACTER
3722 && expr->ts.u.cl->length
3723 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
3724 && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
3727 switch (expr->expr_type)
3732 for (args = expr->value.function.actual; args; args = args->next)
3734 if (gfc_traverse_expr (args->expr, sym, func, f))
3742 case EXPR_SUBSTRING:
3745 case EXPR_STRUCTURE:
3747 for (c = gfc_constructor_first (expr->value.constructor);
3748 c; c = gfc_constructor_next (c))
3750 if (gfc_traverse_expr (c->expr, sym, func, f))
3754 if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3756 if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3758 if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3760 if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3767 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3769 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3785 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3787 if (gfc_traverse_expr (ar.start[i], sym, func, f))
3789 if (gfc_traverse_expr (ar.end[i], sym, func, f))
3791 if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3797 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3799 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3804 if (ref->u.c.component->ts.type == BT_CHARACTER
3805 && ref->u.c.component->ts.u.cl
3806 && ref->u.c.component->ts.u.cl->length
3807 && ref->u.c.component->ts.u.cl->length->expr_type
3809 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
3813 if (ref->u.c.component->as)
3814 for (i = 0; i < ref->u.c.component->as->rank
3815 + ref->u.c.component->as->corank; i++)
3817 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3820 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3834 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3837 expr_set_symbols_referenced (gfc_expr *expr,
3838 gfc_symbol *sym ATTRIBUTE_UNUSED,
3839 int *f ATTRIBUTE_UNUSED)
3841 if (expr->expr_type != EXPR_VARIABLE)
3843 gfc_set_sym_referenced (expr->symtree->n.sym);
3848 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3850 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3854 /* Determine if an expression is a procedure pointer component. If yes, the
3855 argument 'comp' will point to the component (provided that 'comp' was
3859 gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
3864 if (!expr || !expr->ref)
3871 if (ref->type == REF_COMPONENT)
3873 ppc = ref->u.c.component->attr.proc_pointer;
3875 *comp = ref->u.c.component;
3882 /* Walk an expression tree and check each variable encountered for being typed.
3883 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3884 mode as is a basic arithmetic expression using those; this is for things in
3887 INTEGER :: arr(n), n
3888 INTEGER :: arr(n + 1), n
3890 The namespace is needed for IMPLICIT typing. */
3892 static gfc_namespace* check_typed_ns;
3895 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3896 int* f ATTRIBUTE_UNUSED)
3900 if (e->expr_type != EXPR_VARIABLE)
3903 gcc_assert (e->symtree);
3904 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3907 return (t == FAILURE);
3911 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3915 /* If this is a top-level variable or EXPR_OP, do the check with strict given
3919 if (e->expr_type == EXPR_VARIABLE && !e->ref)
3920 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3922 if (e->expr_type == EXPR_OP)
3924 gfc_try t = SUCCESS;
3926 gcc_assert (e->value.op.op1);
3927 t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
3929 if (t == SUCCESS && e->value.op.op2)
3930 t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
3936 /* Otherwise, walk the expression and do it strictly. */
3937 check_typed_ns = ns;
3938 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3940 return error_found ? FAILURE : SUCCESS;
3943 /* Walk an expression tree and replace all symbols with a corresponding symbol
3944 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3945 statements. The boolean return value is required by gfc_traverse_expr. */
3948 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3950 if ((expr->expr_type == EXPR_VARIABLE
3951 || (expr->expr_type == EXPR_FUNCTION
3952 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3953 && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
3956 gfc_namespace *ns = sym->formal_ns;
3957 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3958 the symtree rather than create a new one (and probably fail later). */
3959 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3960 expr->symtree->n.sym->name);
3962 stree->n.sym->attr = expr->symtree->n.sym->attr;
3963 expr->symtree = stree;
3969 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
3971 gfc_traverse_expr (expr, dest, &replace_symbol, 0);
3974 /* The following is analogous to 'replace_symbol', and needed for copying
3975 interfaces for procedure pointer components. The argument 'sym' must formally
3976 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
3977 However, it gets actually passed a gfc_component (i.e. the procedure pointer
3978 component in whose formal_ns the arguments have to be). */
3981 replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3983 gfc_component *comp;
3984 comp = (gfc_component *)sym;
3985 if ((expr->expr_type == EXPR_VARIABLE
3986 || (expr->expr_type == EXPR_FUNCTION
3987 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3988 && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
3991 gfc_namespace *ns = comp->formal_ns;
3992 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3993 the symtree rather than create a new one (and probably fail later). */
3994 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3995 expr->symtree->n.sym->name);
3997 stree->n.sym->attr = expr->symtree->n.sym->attr;
3998 expr->symtree = stree;
4004 gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
4006 gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
4011 gfc_is_coindexed (gfc_expr *e)
4015 for (ref = e->ref; ref; ref = ref->next)
4016 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
4023 /* Check whether the expression has an ultimate allocatable component.
4024 Being itself allocatable does not count. */
4026 gfc_has_ultimate_allocatable (gfc_expr *e)
4028 gfc_ref *ref, *last = NULL;
4030 if (e->expr_type != EXPR_VARIABLE)
4033 for (ref = e->ref; ref; ref = ref->next)
4034 if (ref->type == REF_COMPONENT)
4037 if (last && last->u.c.component->ts.type == BT_CLASS)
4038 return last->u.c.component->ts.u.derived->components->attr.alloc_comp;
4039 else if (last && last->u.c.component->ts.type == BT_DERIVED)
4040 return last->u.c.component->ts.u.derived->attr.alloc_comp;
4044 if (e->ts.type == BT_CLASS)
4045 return e->ts.u.derived->components->attr.alloc_comp;
4046 else if (e->ts.type == BT_DERIVED)
4047 return e->ts.u.derived->attr.alloc_comp;
4053 /* Check whether the expression has an pointer component.
4054 Being itself a pointer does not count. */
4056 gfc_has_ultimate_pointer (gfc_expr *e)
4058 gfc_ref *ref, *last = NULL;
4060 if (e->expr_type != EXPR_VARIABLE)
4063 for (ref = e->ref; ref; ref = ref->next)
4064 if (ref->type == REF_COMPONENT)
4067 if (last && last->u.c.component->ts.type == BT_CLASS)
4068 return last->u.c.component->ts.u.derived->components->attr.pointer_comp;
4069 else if (last && last->u.c.component->ts.type == BT_DERIVED)
4070 return last->u.c.component->ts.u.derived->attr.pointer_comp;
4074 if (e->ts.type == BT_CLASS)
4075 return e->ts.u.derived->components->attr.pointer_comp;
4076 else if (e->ts.type == BT_DERIVED)
4077 return e->ts.u.derived->attr.pointer_comp;