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_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);
400 gfc_clear_shape (mpz_t *shape, int rank)
404 for (i = 0; i < rank; i++)
405 mpz_clear (shape[i]);
410 gfc_free_shape (mpz_t **shape, int rank)
415 gfc_clear_shape (*shape, rank);
421 /* Workhorse function for gfc_free_expr() that frees everything
422 beneath an expression node, but not the node itself. This is
423 useful when we want to simplify a node and replace it with
424 something else or the expression node belongs to another structure. */
427 free_expr0 (gfc_expr *e)
429 switch (e->expr_type)
432 /* Free any parts of the value that need freeing. */
436 mpz_clear (e->value.integer);
440 mpfr_clear (e->value.real);
444 free (e->value.character.string);
448 mpc_clear (e->value.complex);
455 /* Free the representation. */
456 free (e->representation.string);
461 if (e->value.op.op1 != NULL)
462 gfc_free_expr (e->value.op.op1);
463 if (e->value.op.op2 != NULL)
464 gfc_free_expr (e->value.op.op2);
468 gfc_free_actual_arglist (e->value.function.actual);
473 gfc_free_actual_arglist (e->value.compcall.actual);
481 gfc_constructor_free (e->value.constructor);
485 free (e->value.character.string);
492 gfc_internal_error ("free_expr0(): Bad expr type");
495 /* Free a shape array. */
496 gfc_free_shape (&e->shape, e->rank);
498 gfc_free_ref_list (e->ref);
500 memset (e, '\0', sizeof (gfc_expr));
504 /* Free an expression node and everything beneath it. */
507 gfc_free_expr (gfc_expr *e)
516 /* Free an argument list and everything below it. */
519 gfc_free_actual_arglist (gfc_actual_arglist *a1)
521 gfc_actual_arglist *a2;
526 gfc_free_expr (a1->expr);
533 /* Copy an arglist structure and all of the arguments. */
536 gfc_copy_actual_arglist (gfc_actual_arglist *p)
538 gfc_actual_arglist *head, *tail, *new_arg;
542 for (; p; p = p->next)
544 new_arg = gfc_get_actual_arglist ();
547 new_arg->expr = gfc_copy_expr (p->expr);
548 new_arg->next = NULL;
553 tail->next = new_arg;
562 /* Free a list of reference structures. */
565 gfc_free_ref_list (gfc_ref *p)
577 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
579 gfc_free_expr (p->u.ar.start[i]);
580 gfc_free_expr (p->u.ar.end[i]);
581 gfc_free_expr (p->u.ar.stride[i]);
587 gfc_free_expr (p->u.ss.start);
588 gfc_free_expr (p->u.ss.end);
600 /* Graft the *src expression onto the *dest subexpression. */
603 gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
611 /* Try to extract an integer constant from the passed expression node.
612 Returns an error message or NULL if the result is set. It is
613 tempting to generate an error and return SUCCESS or FAILURE, but
614 failure is OK for some callers. */
617 gfc_extract_int (gfc_expr *expr, int *result)
619 if (expr->expr_type != EXPR_CONSTANT)
620 return _("Constant expression required at %C");
622 if (expr->ts.type != BT_INTEGER)
623 return _("Integer expression required at %C");
625 if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
626 || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
628 return _("Integer value too large in expression at %C");
631 *result = (int) mpz_get_si (expr->value.integer);
637 /* Recursively copy a list of reference structures. */
640 gfc_copy_ref (gfc_ref *src)
648 dest = gfc_get_ref ();
649 dest->type = src->type;
654 ar = gfc_copy_array_ref (&src->u.ar);
660 dest->u.c = src->u.c;
664 dest->u.ss = src->u.ss;
665 dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
666 dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
670 dest->next = gfc_copy_ref (src->next);
676 /* Detect whether an expression has any vector index array references. */
679 gfc_has_vector_index (gfc_expr *e)
683 for (ref = e->ref; ref; ref = ref->next)
684 if (ref->type == REF_ARRAY)
685 for (i = 0; i < ref->u.ar.dimen; i++)
686 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
692 /* Copy a shape array. */
695 gfc_copy_shape (mpz_t *shape, int rank)
703 new_shape = gfc_get_shape (rank);
705 for (n = 0; n < rank; n++)
706 mpz_init_set (new_shape[n], shape[n]);
712 /* Copy a shape array excluding dimension N, where N is an integer
713 constant expression. Dimensions are numbered in fortran style --
716 So, if the original shape array contains R elements
717 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
718 the result contains R-1 elements:
719 { s1 ... sN-1 sN+1 ... sR-1}
721 If anything goes wrong -- N is not a constant, its value is out
722 of range -- or anything else, just returns NULL. */
725 gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
727 mpz_t *new_shape, *s;
733 || dim->expr_type != EXPR_CONSTANT
734 || dim->ts.type != BT_INTEGER)
737 n = mpz_get_si (dim->value.integer);
738 n--; /* Convert to zero based index. */
739 if (n < 0 || n >= rank)
742 s = new_shape = gfc_get_shape (rank - 1);
744 for (i = 0; i < rank; i++)
748 mpz_init_set (*s, shape[i]);
756 /* Return the maximum kind of two expressions. In general, higher
757 kind numbers mean more precision for numeric types. */
760 gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
762 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
766 /* Returns nonzero if the type is numeric, zero otherwise. */
769 numeric_type (bt type)
771 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
775 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
778 gfc_numeric_ts (gfc_typespec *ts)
780 return numeric_type (ts->type);
784 /* Return an expression node with an optional argument list attached.
785 A variable number of gfc_expr pointers are strung together in an
786 argument list with a NULL pointer terminating the list. */
789 gfc_build_conversion (gfc_expr *e)
794 p->expr_type = EXPR_FUNCTION;
796 p->value.function.actual = NULL;
798 p->value.function.actual = gfc_get_actual_arglist ();
799 p->value.function.actual->expr = e;
805 /* Given an expression node with some sort of numeric binary
806 expression, insert type conversions required to make the operands
807 have the same type. Conversion warnings are disabled if wconversion
810 The exception is that the operands of an exponential don't have to
811 have the same type. If possible, the base is promoted to the type
812 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
813 1.0**2 stays as it is. */
816 gfc_type_convert_binary (gfc_expr *e, int wconversion)
820 op1 = e->value.op.op1;
821 op2 = e->value.op.op2;
823 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
825 gfc_clear_ts (&e->ts);
829 /* Kind conversions of same type. */
830 if (op1->ts.type == op2->ts.type)
832 if (op1->ts.kind == op2->ts.kind)
834 /* No type conversions. */
839 if (op1->ts.kind > op2->ts.kind)
840 gfc_convert_type_warn (op2, &op1->ts, 2, wconversion);
842 gfc_convert_type_warn (op1, &op2->ts, 2, wconversion);
848 /* Integer combined with real or complex. */
849 if (op2->ts.type == BT_INTEGER)
853 /* Special case for ** operator. */
854 if (e->value.op.op == INTRINSIC_POWER)
857 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
861 if (op1->ts.type == BT_INTEGER)
864 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
868 /* Real combined with complex. */
869 e->ts.type = BT_COMPLEX;
870 if (op1->ts.kind > op2->ts.kind)
871 e->ts.kind = op1->ts.kind;
873 e->ts.kind = op2->ts.kind;
874 if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
875 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
876 if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
877 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
884 /* Function to determine if an expression is constant or not. This
885 function expects that the expression has already been simplified. */
888 gfc_is_constant_expr (gfc_expr *e)
891 gfc_actual_arglist *arg;
897 switch (e->expr_type)
900 return (gfc_is_constant_expr (e->value.op.op1)
901 && (e->value.op.op2 == NULL
902 || gfc_is_constant_expr (e->value.op.op2)));
910 gcc_assert (e->symtree || e->value.function.esym
911 || e->value.function.isym);
913 /* Call to intrinsic with at least one argument. */
914 if (e->value.function.isym && e->value.function.actual)
916 for (arg = e->value.function.actual; arg; arg = arg->next)
917 if (!gfc_is_constant_expr (arg->expr))
921 /* Specification functions are constant. */
922 /* F95, 7.1.6.2; F2003, 7.1.7 */
925 sym = e->symtree->n.sym;
926 if (e->value.function.esym)
927 sym = e->value.function.esym;
930 && sym->attr.function
932 && !sym->attr.intrinsic
933 && !sym->attr.recursive
934 && sym->attr.proc != PROC_INTERNAL
935 && sym->attr.proc != PROC_ST_FUNCTION
936 && sym->attr.proc != PROC_UNKNOWN
937 && sym->formal == NULL)
940 if (e->value.function.isym
941 && (e->value.function.isym->elemental
942 || e->value.function.isym->pure
943 || e->value.function.isym->inquiry
944 || e->value.function.isym->transformational))
954 return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
955 && gfc_is_constant_expr (e->ref->u.ss.end));
959 c = gfc_constructor_first (e->value.constructor);
960 if ((e->expr_type == EXPR_ARRAY) && c && c->iterator)
961 return gfc_constant_ac (e);
963 for (; c; c = gfc_constructor_next (c))
964 if (!gfc_is_constant_expr (c->expr))
971 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
977 /* Is true if an array reference is followed by a component or substring
980 is_subref_array (gfc_expr * e)
985 if (e->expr_type != EXPR_VARIABLE)
988 if (e->symtree->n.sym->attr.subref_array_pointer)
992 for (ref = e->ref; ref; ref = ref->next)
994 if (ref->type == REF_ARRAY
995 && ref->u.ar.type != AR_ELEMENT)
999 && ref->type != REF_ARRAY)
1006 /* Try to collapse intrinsic expressions. */
1009 simplify_intrinsic_op (gfc_expr *p, int type)
1011 gfc_intrinsic_op op;
1012 gfc_expr *op1, *op2, *result;
1014 if (p->value.op.op == INTRINSIC_USER)
1017 op1 = p->value.op.op1;
1018 op2 = p->value.op.op2;
1019 op = p->value.op.op;
1021 if (gfc_simplify_expr (op1, type) == FAILURE)
1023 if (gfc_simplify_expr (op2, type) == FAILURE)
1026 if (!gfc_is_constant_expr (op1)
1027 || (op2 != NULL && !gfc_is_constant_expr (op2)))
1031 p->value.op.op1 = NULL;
1032 p->value.op.op2 = NULL;
1036 case INTRINSIC_PARENTHESES:
1037 result = gfc_parentheses (op1);
1040 case INTRINSIC_UPLUS:
1041 result = gfc_uplus (op1);
1044 case INTRINSIC_UMINUS:
1045 result = gfc_uminus (op1);
1048 case INTRINSIC_PLUS:
1049 result = gfc_add (op1, op2);
1052 case INTRINSIC_MINUS:
1053 result = gfc_subtract (op1, op2);
1056 case INTRINSIC_TIMES:
1057 result = gfc_multiply (op1, op2);
1060 case INTRINSIC_DIVIDE:
1061 result = gfc_divide (op1, op2);
1064 case INTRINSIC_POWER:
1065 result = gfc_power (op1, op2);
1068 case INTRINSIC_CONCAT:
1069 result = gfc_concat (op1, op2);
1073 case INTRINSIC_EQ_OS:
1074 result = gfc_eq (op1, op2, op);
1078 case INTRINSIC_NE_OS:
1079 result = gfc_ne (op1, op2, op);
1083 case INTRINSIC_GT_OS:
1084 result = gfc_gt (op1, op2, op);
1088 case INTRINSIC_GE_OS:
1089 result = gfc_ge (op1, op2, op);
1093 case INTRINSIC_LT_OS:
1094 result = gfc_lt (op1, op2, op);
1098 case INTRINSIC_LE_OS:
1099 result = gfc_le (op1, op2, op);
1103 result = gfc_not (op1);
1107 result = gfc_and (op1, op2);
1111 result = gfc_or (op1, op2);
1115 result = gfc_eqv (op1, op2);
1118 case INTRINSIC_NEQV:
1119 result = gfc_neqv (op1, op2);
1123 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1128 gfc_free_expr (op1);
1129 gfc_free_expr (op2);
1133 result->rank = p->rank;
1134 result->where = p->where;
1135 gfc_replace_expr (p, result);
1141 /* Subroutine to simplify constructor expressions. Mutually recursive
1142 with gfc_simplify_expr(). */
1145 simplify_constructor (gfc_constructor_base base, int type)
1150 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1153 && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
1154 || gfc_simplify_expr (c->iterator->end, type) == FAILURE
1155 || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
1160 /* Try and simplify a copy. Replace the original if successful
1161 but keep going through the constructor at all costs. Not
1162 doing so can make a dog's dinner of complicated things. */
1163 p = gfc_copy_expr (c->expr);
1165 if (gfc_simplify_expr (p, type) == FAILURE)
1171 gfc_replace_expr (c->expr, p);
1179 /* Pull a single array element out of an array constructor. */
1182 find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
1183 gfc_constructor **rval)
1185 unsigned long nelemen;
1191 gfc_constructor *cons;
1198 mpz_init_set_ui (offset, 0);
1201 mpz_init_set_ui (span, 1);
1202 for (i = 0; i < ar->dimen; i++)
1204 if (gfc_reduce_init_expr (ar->as->lower[i]) == FAILURE
1205 || gfc_reduce_init_expr (ar->as->upper[i]) == FAILURE)
1212 e = gfc_copy_expr (ar->start[i]);
1213 if (e->expr_type != EXPR_CONSTANT)
1219 gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
1220 && ar->as->lower[i]->expr_type == EXPR_CONSTANT);
1222 /* Check the bounds. */
1223 if ((ar->as->upper[i]
1224 && mpz_cmp (e->value.integer,
1225 ar->as->upper[i]->value.integer) > 0)
1226 || (mpz_cmp (e->value.integer,
1227 ar->as->lower[i]->value.integer) < 0))
1229 gfc_error ("Index in dimension %d is out of bounds "
1230 "at %L", i + 1, &ar->c_where[i]);
1236 mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1237 mpz_mul (delta, delta, span);
1238 mpz_add (offset, offset, delta);
1240 mpz_set_ui (tmp, 1);
1241 mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1242 mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1243 mpz_mul (span, span, tmp);
1246 for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset);
1247 cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
1268 /* Find a component of a structure constructor. */
1270 static gfc_constructor *
1271 find_component_ref (gfc_constructor_base base, gfc_ref *ref)
1273 gfc_component *comp;
1274 gfc_component *pick;
1275 gfc_constructor *c = gfc_constructor_first (base);
1277 comp = ref->u.c.sym->components;
1278 pick = ref->u.c.component;
1279 while (comp != pick)
1282 c = gfc_constructor_next (c);
1289 /* Replace an expression with the contents of a constructor, removing
1290 the subobject reference in the process. */
1293 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1303 e = gfc_copy_expr (p);
1304 e->ref = p->ref->next;
1305 p->ref->next = NULL;
1306 gfc_replace_expr (p, e);
1310 /* Pull an array section out of an array constructor. */
1313 find_array_section (gfc_expr *expr, gfc_ref *ref)
1320 long unsigned one = 1;
1322 mpz_t start[GFC_MAX_DIMENSIONS];
1323 mpz_t end[GFC_MAX_DIMENSIONS];
1324 mpz_t stride[GFC_MAX_DIMENSIONS];
1325 mpz_t delta[GFC_MAX_DIMENSIONS];
1326 mpz_t ctr[GFC_MAX_DIMENSIONS];
1331 gfc_constructor_base base;
1332 gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS];
1342 base = expr->value.constructor;
1343 expr->value.constructor = NULL;
1345 rank = ref->u.ar.as->rank;
1347 if (expr->shape == NULL)
1348 expr->shape = gfc_get_shape (rank);
1350 mpz_init_set_ui (delta_mpz, one);
1351 mpz_init_set_ui (nelts, one);
1354 /* Do the initialization now, so that we can cleanup without
1355 keeping track of where we were. */
1356 for (d = 0; d < rank; d++)
1358 mpz_init (delta[d]);
1359 mpz_init (start[d]);
1362 mpz_init (stride[d]);
1366 /* Build the counters to clock through the array reference. */
1368 for (d = 0; d < rank; d++)
1370 /* Make this stretch of code easier on the eye! */
1371 begin = ref->u.ar.start[d];
1372 finish = ref->u.ar.end[d];
1373 step = ref->u.ar.stride[d];
1374 lower = ref->u.ar.as->lower[d];
1375 upper = ref->u.ar.as->upper[d];
1377 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1379 gfc_constructor *ci;
1382 if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1388 gcc_assert (begin->rank == 1);
1389 /* Zero-sized arrays have no shape and no elements, stop early. */
1392 mpz_init_set_ui (nelts, 0);
1396 vecsub[d] = gfc_constructor_first (begin->value.constructor);
1397 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1398 mpz_mul (nelts, nelts, begin->shape[0]);
1399 mpz_set (expr->shape[shape_i++], begin->shape[0]);
1402 for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci))
1404 if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
1405 || mpz_cmp (ci->expr->value.integer,
1406 lower->value.integer) < 0)
1408 gfc_error ("index in dimension %d is out of bounds "
1409 "at %L", d + 1, &ref->u.ar.c_where[d]);
1417 if ((begin && begin->expr_type != EXPR_CONSTANT)
1418 || (finish && finish->expr_type != EXPR_CONSTANT)
1419 || (step && step->expr_type != EXPR_CONSTANT))
1425 /* Obtain the stride. */
1427 mpz_set (stride[d], step->value.integer);
1429 mpz_set_ui (stride[d], one);
1431 if (mpz_cmp_ui (stride[d], 0) == 0)
1432 mpz_set_ui (stride[d], one);
1434 /* Obtain the start value for the index. */
1436 mpz_set (start[d], begin->value.integer);
1438 mpz_set (start[d], lower->value.integer);
1440 mpz_set (ctr[d], start[d]);
1442 /* Obtain the end value for the index. */
1444 mpz_set (end[d], finish->value.integer);
1446 mpz_set (end[d], upper->value.integer);
1448 /* Separate 'if' because elements sometimes arrive with
1450 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1451 mpz_set (end [d], begin->value.integer);
1453 /* Check the bounds. */
1454 if (mpz_cmp (ctr[d], upper->value.integer) > 0
1455 || mpz_cmp (end[d], upper->value.integer) > 0
1456 || mpz_cmp (ctr[d], lower->value.integer) < 0
1457 || mpz_cmp (end[d], lower->value.integer) < 0)
1459 gfc_error ("index in dimension %d is out of bounds "
1460 "at %L", d + 1, &ref->u.ar.c_where[d]);
1465 /* Calculate the number of elements and the shape. */
1466 mpz_set (tmp_mpz, stride[d]);
1467 mpz_add (tmp_mpz, end[d], tmp_mpz);
1468 mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1469 mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1470 mpz_mul (nelts, nelts, tmp_mpz);
1472 /* An element reference reduces the rank of the expression; don't
1473 add anything to the shape array. */
1474 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1475 mpz_set (expr->shape[shape_i++], tmp_mpz);
1478 /* Calculate the 'stride' (=delta) for conversion of the
1479 counter values into the index along the constructor. */
1480 mpz_set (delta[d], delta_mpz);
1481 mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1482 mpz_add_ui (tmp_mpz, tmp_mpz, one);
1483 mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1487 cons = gfc_constructor_first (base);
1489 /* Now clock through the array reference, calculating the index in
1490 the source constructor and transferring the elements to the new
1492 for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1494 if (ref->u.ar.offset)
1495 mpz_set (ptr, ref->u.ar.offset->value.integer);
1497 mpz_init_set_ui (ptr, 0);
1500 for (d = 0; d < rank; d++)
1502 mpz_set (tmp_mpz, ctr[d]);
1503 mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1504 mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1505 mpz_add (ptr, ptr, tmp_mpz);
1507 if (!incr_ctr) continue;
1509 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1511 gcc_assert(vecsub[d]);
1513 if (!gfc_constructor_next (vecsub[d]))
1514 vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor);
1517 vecsub[d] = gfc_constructor_next (vecsub[d]);
1520 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1524 mpz_add (ctr[d], ctr[d], stride[d]);
1526 if (mpz_cmp_ui (stride[d], 0) > 0
1527 ? mpz_cmp (ctr[d], end[d]) > 0
1528 : mpz_cmp (ctr[d], end[d]) < 0)
1529 mpz_set (ctr[d], start[d]);
1535 limit = mpz_get_ui (ptr);
1536 if (limit >= gfc_option.flag_max_array_constructor)
1538 gfc_error ("The number of elements in the array constructor "
1539 "at %L requires an increase of the allowed %d "
1540 "upper limit. See -fmax-array-constructor "
1541 "option", &expr->where,
1542 gfc_option.flag_max_array_constructor);
1546 cons = gfc_constructor_lookup (base, limit);
1548 gfc_constructor_append_expr (&expr->value.constructor,
1549 gfc_copy_expr (cons->expr), NULL);
1556 mpz_clear (delta_mpz);
1557 mpz_clear (tmp_mpz);
1559 for (d = 0; d < rank; d++)
1561 mpz_clear (delta[d]);
1562 mpz_clear (start[d]);
1565 mpz_clear (stride[d]);
1567 gfc_constructor_free (base);
1571 /* Pull a substring out of an expression. */
1574 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1581 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1582 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1585 *newp = gfc_copy_expr (p);
1586 free ((*newp)->value.character.string);
1588 end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1589 start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1590 length = end - start + 1;
1592 chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1593 (*newp)->value.character.length = length;
1594 memcpy (chr, &p->value.character.string[start - 1],
1595 length * sizeof (gfc_char_t));
1602 /* Simplify a subobject reference of a constructor. This occurs when
1603 parameter variable values are substituted. */
1606 simplify_const_ref (gfc_expr *p)
1608 gfc_constructor *cons, *c;
1614 switch (p->ref->type)
1617 switch (p->ref->u.ar.type)
1620 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1621 will generate this. */
1622 if (p->expr_type != EXPR_ARRAY)
1624 remove_subobject_ref (p, NULL);
1627 if (find_array_element (p->value.constructor, &p->ref->u.ar,
1634 remove_subobject_ref (p, cons);
1638 if (find_array_section (p, p->ref) == FAILURE)
1640 p->ref->u.ar.type = AR_FULL;
1645 if (p->ref->next != NULL
1646 && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1648 for (c = gfc_constructor_first (p->value.constructor);
1649 c; c = gfc_constructor_next (c))
1651 c->expr->ref = gfc_copy_ref (p->ref->next);
1652 if (simplify_const_ref (c->expr) == FAILURE)
1656 if (p->ts.type == BT_DERIVED
1658 && (c = gfc_constructor_first (p->value.constructor)))
1660 /* There may have been component references. */
1661 p->ts = c->expr->ts;
1665 for (; last_ref->next; last_ref = last_ref->next) {};
1667 if (p->ts.type == BT_CHARACTER
1668 && last_ref->type == REF_SUBSTRING)
1670 /* If this is a CHARACTER array and we possibly took
1671 a substring out of it, update the type-spec's
1672 character length according to the first element
1673 (as all should have the same length). */
1675 if ((c = gfc_constructor_first (p->value.constructor)))
1677 const gfc_expr* first = c->expr;
1678 gcc_assert (first->expr_type == EXPR_CONSTANT);
1679 gcc_assert (first->ts.type == BT_CHARACTER);
1680 string_len = first->value.character.length;
1686 p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
1689 gfc_free_expr (p->ts.u.cl->length);
1692 = gfc_get_int_expr (gfc_default_integer_kind,
1696 gfc_free_ref_list (p->ref);
1707 cons = find_component_ref (p->value.constructor, p->ref);
1708 remove_subobject_ref (p, cons);
1712 if (find_substring_ref (p, &newp) == FAILURE)
1715 gfc_replace_expr (p, newp);
1716 gfc_free_ref_list (p->ref);
1726 /* Simplify a chain of references. */
1729 simplify_ref_chain (gfc_ref *ref, int type)
1733 for (; ref; ref = ref->next)
1738 for (n = 0; n < ref->u.ar.dimen; n++)
1740 if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1742 if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1744 if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1750 if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1752 if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1764 /* Try to substitute the value of a parameter variable. */
1767 simplify_parameter_variable (gfc_expr *p, int type)
1772 e = gfc_copy_expr (p->symtree->n.sym->value);
1778 /* Do not copy subobject refs for constant. */
1779 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1780 e->ref = gfc_copy_ref (p->ref);
1781 t = gfc_simplify_expr (e, type);
1783 /* Only use the simplification if it eliminated all subobject references. */
1784 if (t == SUCCESS && !e->ref)
1785 gfc_replace_expr (p, e);
1792 /* Given an expression, simplify it by collapsing constant
1793 expressions. Most simplification takes place when the expression
1794 tree is being constructed. If an intrinsic function is simplified
1795 at some point, we get called again to collapse the result against
1798 We work by recursively simplifying expression nodes, simplifying
1799 intrinsic functions where possible, which can lead to further
1800 constant collapsing. If an operator has constant operand(s), we
1801 rip the expression apart, and rebuild it, hoping that it becomes
1804 The expression type is defined for:
1805 0 Basic expression parsing
1806 1 Simplifying array constructors -- will substitute
1808 Returns FAILURE on error, SUCCESS otherwise.
1809 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1812 gfc_simplify_expr (gfc_expr *p, int type)
1814 gfc_actual_arglist *ap;
1819 switch (p->expr_type)
1826 for (ap = p->value.function.actual; ap; ap = ap->next)
1827 if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1830 if (p->value.function.isym != NULL
1831 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1836 case EXPR_SUBSTRING:
1837 if (simplify_ref_chain (p->ref, type) == FAILURE)
1840 if (gfc_is_constant_expr (p))
1846 if (p->ref && p->ref->u.ss.start)
1848 gfc_extract_int (p->ref->u.ss.start, &start);
1849 start--; /* Convert from one-based to zero-based. */
1852 end = p->value.character.length;
1853 if (p->ref && p->ref->u.ss.end)
1854 gfc_extract_int (p->ref->u.ss.end, &end);
1859 s = gfc_get_wide_string (end - start + 2);
1860 memcpy (s, p->value.character.string + start,
1861 (end - start) * sizeof (gfc_char_t));
1862 s[end - start + 1] = '\0'; /* TODO: C-style string. */
1863 free (p->value.character.string);
1864 p->value.character.string = s;
1865 p->value.character.length = end - start;
1866 p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1867 p->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
1869 p->value.character.length);
1870 gfc_free_ref_list (p->ref);
1872 p->expr_type = EXPR_CONSTANT;
1877 if (simplify_intrinsic_op (p, type) == FAILURE)
1882 /* Only substitute array parameter variables if we are in an
1883 initialization expression, or we want a subsection. */
1884 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1885 && (gfc_init_expr_flag || p->ref
1886 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1888 if (simplify_parameter_variable (p, type) == FAILURE)
1895 gfc_simplify_iterator_var (p);
1898 /* Simplify subcomponent references. */
1899 if (simplify_ref_chain (p->ref, type) == FAILURE)
1904 case EXPR_STRUCTURE:
1906 if (simplify_ref_chain (p->ref, type) == FAILURE)
1909 if (simplify_constructor (p->value.constructor, type) == FAILURE)
1912 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1913 && p->ref->u.ar.type == AR_FULL)
1914 gfc_expand_constructor (p, false);
1916 if (simplify_const_ref (p) == FAILURE)
1931 /* Returns the type of an expression with the exception that iterator
1932 variables are automatically integers no matter what else they may
1938 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1945 /* Check an intrinsic arithmetic operation to see if it is consistent
1946 with some type of expression. */
1948 static gfc_try check_init_expr (gfc_expr *);
1951 /* Scalarize an expression for an elemental intrinsic call. */
1954 scalarize_intrinsic_call (gfc_expr *e)
1956 gfc_actual_arglist *a, *b;
1957 gfc_constructor_base ctor;
1958 gfc_constructor *args[5];
1959 gfc_constructor *ci, *new_ctor;
1960 gfc_expr *expr, *old;
1961 int n, i, rank[5], array_arg;
1963 /* Find which, if any, arguments are arrays. Assume that the old
1964 expression carries the type information and that the first arg
1965 that is an array expression carries all the shape information.*/
1967 a = e->value.function.actual;
1968 for (; a; a = a->next)
1971 if (a->expr->expr_type != EXPR_ARRAY)
1974 expr = gfc_copy_expr (a->expr);
1981 old = gfc_copy_expr (e);
1983 gfc_constructor_free (expr->value.constructor);
1984 expr->value.constructor = NULL;
1986 expr->where = old->where;
1987 expr->expr_type = EXPR_ARRAY;
1989 /* Copy the array argument constructors into an array, with nulls
1992 a = old->value.function.actual;
1993 for (; a; a = a->next)
1995 /* Check that this is OK for an initialization expression. */
1996 if (a->expr && check_init_expr (a->expr) == FAILURE)
2000 if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
2002 rank[n] = a->expr->rank;
2003 ctor = a->expr->symtree->n.sym->value->value.constructor;
2004 args[n] = gfc_constructor_first (ctor);
2006 else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
2009 rank[n] = a->expr->rank;
2012 ctor = gfc_constructor_copy (a->expr->value.constructor);
2013 args[n] = gfc_constructor_first (ctor);
2022 /* Using the array argument as the master, step through the array
2023 calling the function for each element and advancing the array
2024 constructors together. */
2025 for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
2027 new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
2028 gfc_copy_expr (old), NULL);
2030 gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
2032 b = old->value.function.actual;
2033 for (i = 0; i < n; i++)
2036 new_ctor->expr->value.function.actual
2037 = a = gfc_get_actual_arglist ();
2040 a->next = gfc_get_actual_arglist ();
2045 a->expr = gfc_copy_expr (args[i]->expr);
2047 a->expr = gfc_copy_expr (b->expr);
2052 /* Simplify the function calls. If the simplification fails, the
2053 error will be flagged up down-stream or the library will deal
2055 gfc_simplify_expr (new_ctor->expr, 0);
2057 for (i = 0; i < n; i++)
2059 args[i] = gfc_constructor_next (args[i]);
2061 for (i = 1; i < n; i++)
2062 if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
2063 || (args[i] == NULL && args[array_arg - 1] != NULL)))
2069 gfc_free_expr (old);
2073 gfc_error_now ("elemental function arguments at %C are not compliant");
2076 gfc_free_expr (expr);
2077 gfc_free_expr (old);
2083 check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
2085 gfc_expr *op1 = e->value.op.op1;
2086 gfc_expr *op2 = e->value.op.op2;
2088 if ((*check_function) (op1) == FAILURE)
2091 switch (e->value.op.op)
2093 case INTRINSIC_UPLUS:
2094 case INTRINSIC_UMINUS:
2095 if (!numeric_type (et0 (op1)))
2100 case INTRINSIC_EQ_OS:
2102 case INTRINSIC_NE_OS:
2104 case INTRINSIC_GT_OS:
2106 case INTRINSIC_GE_OS:
2108 case INTRINSIC_LT_OS:
2110 case INTRINSIC_LE_OS:
2111 if ((*check_function) (op2) == FAILURE)
2114 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
2115 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
2117 gfc_error ("Numeric or CHARACTER operands are required in "
2118 "expression at %L", &e->where);
2123 case INTRINSIC_PLUS:
2124 case INTRINSIC_MINUS:
2125 case INTRINSIC_TIMES:
2126 case INTRINSIC_DIVIDE:
2127 case INTRINSIC_POWER:
2128 if ((*check_function) (op2) == FAILURE)
2131 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
2136 case INTRINSIC_CONCAT:
2137 if ((*check_function) (op2) == FAILURE)
2140 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
2142 gfc_error ("Concatenation operator in expression at %L "
2143 "must have two CHARACTER operands", &op1->where);
2147 if (op1->ts.kind != op2->ts.kind)
2149 gfc_error ("Concat operator at %L must concatenate strings of the "
2150 "same kind", &e->where);
2157 if (et0 (op1) != BT_LOGICAL)
2159 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2160 "operand", &op1->where);
2169 case INTRINSIC_NEQV:
2170 if ((*check_function) (op2) == FAILURE)
2173 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
2175 gfc_error ("LOGICAL operands are required in expression at %L",
2182 case INTRINSIC_PARENTHESES:
2186 gfc_error ("Only intrinsic operators can be used in expression at %L",
2194 gfc_error ("Numeric operands are required in expression at %L", &e->where);
2199 /* F2003, 7.1.7 (3): In init expression, allocatable components
2200 must not be data-initialized. */
2202 check_alloc_comp_init (gfc_expr *e)
2204 gfc_component *comp;
2205 gfc_constructor *ctor;
2207 gcc_assert (e->expr_type == EXPR_STRUCTURE);
2208 gcc_assert (e->ts.type == BT_DERIVED);
2210 for (comp = e->ts.u.derived->components,
2211 ctor = gfc_constructor_first (e->value.constructor);
2212 comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
2214 if (comp->attr.allocatable
2215 && ctor->expr->expr_type != EXPR_NULL)
2217 gfc_error("Invalid initialization expression for ALLOCATABLE "
2218 "component '%s' in structure constructor at %L",
2219 comp->name, &ctor->expr->where);
2228 check_init_expr_arguments (gfc_expr *e)
2230 gfc_actual_arglist *ap;
2232 for (ap = e->value.function.actual; ap; ap = ap->next)
2233 if (check_init_expr (ap->expr) == FAILURE)
2239 static gfc_try check_restricted (gfc_expr *);
2241 /* F95, 7.1.6.1, Initialization expressions, (7)
2242 F2003, 7.1.7 Initialization expression, (8) */
2245 check_inquiry (gfc_expr *e, int not_restricted)
2248 const char *const *functions;
2250 static const char *const inquiry_func_f95[] = {
2251 "lbound", "shape", "size", "ubound",
2252 "bit_size", "len", "kind",
2253 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2254 "precision", "radix", "range", "tiny",
2258 static const char *const inquiry_func_f2003[] = {
2259 "lbound", "shape", "size", "ubound",
2260 "bit_size", "len", "kind",
2261 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2262 "precision", "radix", "range", "tiny",
2267 gfc_actual_arglist *ap;
2269 if (!e->value.function.isym
2270 || !e->value.function.isym->inquiry)
2273 /* An undeclared parameter will get us here (PR25018). */
2274 if (e->symtree == NULL)
2277 name = e->symtree->n.sym->name;
2279 functions = (gfc_option.warn_std & GFC_STD_F2003)
2280 ? inquiry_func_f2003 : inquiry_func_f95;
2282 for (i = 0; functions[i]; i++)
2283 if (strcmp (functions[i], name) == 0)
2286 if (functions[i] == NULL)
2289 /* At this point we have an inquiry function with a variable argument. The
2290 type of the variable might be undefined, but we need it now, because the
2291 arguments of these functions are not allowed to be undefined. */
2293 for (ap = e->value.function.actual; ap; ap = ap->next)
2298 if (ap->expr->ts.type == BT_UNKNOWN)
2300 if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2301 && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)
2305 ap->expr->ts = ap->expr->symtree->n.sym->ts;
2308 /* Assumed character length will not reduce to a constant expression
2309 with LEN, as required by the standard. */
2310 if (i == 5 && not_restricted
2311 && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2312 && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL
2313 || ap->expr->symtree->n.sym->ts.deferred))
2315 gfc_error ("Assumed or deferred character length variable '%s' "
2316 " in constant expression at %L",
2317 ap->expr->symtree->n.sym->name,
2321 else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
2324 if (not_restricted == 0
2325 && ap->expr->expr_type != EXPR_VARIABLE
2326 && check_restricted (ap->expr) == FAILURE)
2329 if (not_restricted == 0
2330 && ap->expr->expr_type == EXPR_VARIABLE
2331 && ap->expr->symtree->n.sym->attr.dummy
2332 && ap->expr->symtree->n.sym->attr.optional)
2340 /* F95, 7.1.6.1, Initialization expressions, (5)
2341 F2003, 7.1.7 Initialization expression, (5) */
2344 check_transformational (gfc_expr *e)
2346 static const char * const trans_func_f95[] = {
2347 "repeat", "reshape", "selected_int_kind",
2348 "selected_real_kind", "transfer", "trim", NULL
2351 static const char * const trans_func_f2003[] = {
2352 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2353 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2354 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2355 "trim", "unpack", NULL
2360 const char *const *functions;
2362 if (!e->value.function.isym
2363 || !e->value.function.isym->transformational)
2366 name = e->symtree->n.sym->name;
2368 functions = (gfc_option.allow_std & GFC_STD_F2003)
2369 ? trans_func_f2003 : trans_func_f95;
2371 /* NULL() is dealt with below. */
2372 if (strcmp ("null", name) == 0)
2375 for (i = 0; functions[i]; i++)
2376 if (strcmp (functions[i], name) == 0)
2379 if (functions[i] == NULL)
2381 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2382 "in an initialization expression", name, &e->where);
2386 return check_init_expr_arguments (e);
2390 /* F95, 7.1.6.1, Initialization expressions, (6)
2391 F2003, 7.1.7 Initialization expression, (6) */
2394 check_null (gfc_expr *e)
2396 if (strcmp ("null", e->symtree->n.sym->name) != 0)
2399 return check_init_expr_arguments (e);
2404 check_elemental (gfc_expr *e)
2406 if (!e->value.function.isym
2407 || !e->value.function.isym->elemental)
2410 if (e->ts.type != BT_INTEGER
2411 && e->ts.type != BT_CHARACTER
2412 && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2413 "nonstandard initialization expression at %L",
2414 &e->where) == FAILURE)
2417 return check_init_expr_arguments (e);
2422 check_conversion (gfc_expr *e)
2424 if (!e->value.function.isym
2425 || !e->value.function.isym->conversion)
2428 return check_init_expr_arguments (e);
2432 /* Verify that an expression is an initialization expression. A side
2433 effect is that the expression tree is reduced to a single constant
2434 node if all goes well. This would normally happen when the
2435 expression is constructed but function references are assumed to be
2436 intrinsics in the context of initialization expressions. If
2437 FAILURE is returned an error message has been generated. */
2440 check_init_expr (gfc_expr *e)
2448 switch (e->expr_type)
2451 t = check_intrinsic_op (e, check_init_expr);
2453 t = gfc_simplify_expr (e, 0);
2461 gfc_intrinsic_sym* isym;
2464 sym = e->symtree->n.sym;
2465 if (!gfc_is_intrinsic (sym, 0, e->where)
2466 || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2468 gfc_error ("Function '%s' in initialization expression at %L "
2469 "must be an intrinsic function",
2470 e->symtree->n.sym->name, &e->where);
2474 if ((m = check_conversion (e)) == MATCH_NO
2475 && (m = check_inquiry (e, 1)) == MATCH_NO
2476 && (m = check_null (e)) == MATCH_NO
2477 && (m = check_transformational (e)) == MATCH_NO
2478 && (m = check_elemental (e)) == MATCH_NO)
2480 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2481 "in an initialization expression",
2482 e->symtree->n.sym->name, &e->where);
2486 if (m == MATCH_ERROR)
2489 /* Try to scalarize an elemental intrinsic function that has an
2491 isym = gfc_find_function (e->symtree->n.sym->name);
2492 if (isym && isym->elemental
2493 && (t = scalarize_intrinsic_call (e)) == SUCCESS)
2498 t = gfc_simplify_expr (e, 0);
2505 if (gfc_check_iter_variable (e) == SUCCESS)
2508 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2510 /* A PARAMETER shall not be used to define itself, i.e.
2511 REAL, PARAMETER :: x = transfer(0, x)
2513 if (!e->symtree->n.sym->value)
2515 gfc_error("PARAMETER '%s' is used at %L before its definition "
2516 "is complete", e->symtree->n.sym->name, &e->where);
2520 t = simplify_parameter_variable (e, 0);
2525 if (gfc_in_match_data ())
2530 if (e->symtree->n.sym->as)
2532 switch (e->symtree->n.sym->as->type)
2534 case AS_ASSUMED_SIZE:
2535 gfc_error ("Assumed size array '%s' at %L is not permitted "
2536 "in an initialization expression",
2537 e->symtree->n.sym->name, &e->where);
2540 case AS_ASSUMED_SHAPE:
2541 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2542 "in an initialization expression",
2543 e->symtree->n.sym->name, &e->where);
2547 gfc_error ("Deferred array '%s' at %L is not permitted "
2548 "in an initialization expression",
2549 e->symtree->n.sym->name, &e->where);
2553 gfc_error ("Array '%s' at %L is a variable, which does "
2554 "not reduce to a constant expression",
2555 e->symtree->n.sym->name, &e->where);
2563 gfc_error ("Parameter '%s' at %L has not been declared or is "
2564 "a variable, which does not reduce to a constant "
2565 "expression", e->symtree->n.sym->name, &e->where);
2574 case EXPR_SUBSTRING:
2575 t = check_init_expr (e->ref->u.ss.start);
2579 t = check_init_expr (e->ref->u.ss.end);
2581 t = gfc_simplify_expr (e, 0);
2585 case EXPR_STRUCTURE:
2586 t = e->ts.is_iso_c ? SUCCESS : FAILURE;
2590 t = check_alloc_comp_init (e);
2594 t = gfc_check_constructor (e, check_init_expr);
2601 t = gfc_check_constructor (e, check_init_expr);
2605 t = gfc_expand_constructor (e, true);
2609 t = gfc_check_constructor_type (e);
2613 gfc_internal_error ("check_init_expr(): Unknown expression type");
2619 /* Reduces a general expression to an initialization expression (a constant).
2620 This used to be part of gfc_match_init_expr.
2621 Note that this function doesn't free the given expression on FAILURE. */
2624 gfc_reduce_init_expr (gfc_expr *expr)
2628 gfc_init_expr_flag = true;
2629 t = gfc_resolve_expr (expr);
2631 t = check_init_expr (expr);
2632 gfc_init_expr_flag = false;
2637 if (expr->expr_type == EXPR_ARRAY)
2639 if (gfc_check_constructor_type (expr) == FAILURE)
2641 if (gfc_expand_constructor (expr, true) == FAILURE)
2649 /* Match an initialization expression. We work by first matching an
2650 expression, then reducing it to a constant. */
2653 gfc_match_init_expr (gfc_expr **result)
2661 gfc_init_expr_flag = true;
2663 m = gfc_match_expr (&expr);
2666 gfc_init_expr_flag = false;
2670 t = gfc_reduce_init_expr (expr);
2673 gfc_free_expr (expr);
2674 gfc_init_expr_flag = false;
2679 gfc_init_expr_flag = false;
2685 /* Given an actual argument list, test to see that each argument is a
2686 restricted expression and optionally if the expression type is
2687 integer or character. */
2690 restricted_args (gfc_actual_arglist *a)
2692 for (; a; a = a->next)
2694 if (check_restricted (a->expr) == FAILURE)
2702 /************* Restricted/specification expressions *************/
2705 /* Make sure a non-intrinsic function is a specification function. */
2708 external_spec_function (gfc_expr *e)
2712 f = e->value.function.esym;
2714 if (f->attr.proc == PROC_ST_FUNCTION)
2716 gfc_error ("Specification function '%s' at %L cannot be a statement "
2717 "function", f->name, &e->where);
2721 if (f->attr.proc == PROC_INTERNAL)
2723 gfc_error ("Specification function '%s' at %L cannot be an internal "
2724 "function", f->name, &e->where);
2728 if (!f->attr.pure && !f->attr.elemental)
2730 gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2735 if (f->attr.recursive)
2737 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2738 f->name, &e->where);
2742 return restricted_args (e->value.function.actual);
2746 /* Check to see that a function reference to an intrinsic is a
2747 restricted expression. */
2750 restricted_intrinsic (gfc_expr *e)
2752 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2753 if (check_inquiry (e, 0) == MATCH_YES)
2756 return restricted_args (e->value.function.actual);
2760 /* Check the expressions of an actual arglist. Used by check_restricted. */
2763 check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
2765 for (; arg; arg = arg->next)
2766 if (checker (arg->expr) == FAILURE)
2773 /* Check the subscription expressions of a reference chain with a checking
2774 function; used by check_restricted. */
2777 check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
2787 for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2789 if (checker (ref->u.ar.start[dim]) == FAILURE)
2791 if (checker (ref->u.ar.end[dim]) == FAILURE)
2793 if (checker (ref->u.ar.stride[dim]) == FAILURE)
2799 /* Nothing needed, just proceed to next reference. */
2803 if (checker (ref->u.ss.start) == FAILURE)
2805 if (checker (ref->u.ss.end) == FAILURE)
2814 return check_references (ref->next, checker);
2818 /* Verify that an expression is a restricted expression. Like its
2819 cousin check_init_expr(), an error message is generated if we
2823 check_restricted (gfc_expr *e)
2831 switch (e->expr_type)
2834 t = check_intrinsic_op (e, check_restricted);
2836 t = gfc_simplify_expr (e, 0);
2841 if (e->value.function.esym)
2843 t = check_arglist (e->value.function.actual, &check_restricted);
2845 t = external_spec_function (e);
2849 if (e->value.function.isym && e->value.function.isym->inquiry)
2852 t = check_arglist (e->value.function.actual, &check_restricted);
2855 t = restricted_intrinsic (e);
2860 sym = e->symtree->n.sym;
2863 /* If a dummy argument appears in a context that is valid for a
2864 restricted expression in an elemental procedure, it will have
2865 already been simplified away once we get here. Therefore we
2866 don't need to jump through hoops to distinguish valid from
2868 if (sym->attr.dummy && sym->ns == gfc_current_ns
2869 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2871 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2872 sym->name, &e->where);
2876 if (sym->attr.optional)
2878 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2879 sym->name, &e->where);
2883 if (sym->attr.intent == INTENT_OUT)
2885 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2886 sym->name, &e->where);
2890 /* Check reference chain if any. */
2891 if (check_references (e->ref, &check_restricted) == FAILURE)
2894 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2895 processed in resolve.c(resolve_formal_arglist). This is done so
2896 that host associated dummy array indices are accepted (PR23446).
2897 This mechanism also does the same for the specification expressions
2898 of array-valued functions. */
2900 || sym->attr.in_common
2901 || sym->attr.use_assoc
2903 || sym->attr.implied_index
2904 || sym->attr.flavor == FL_PARAMETER
2905 || (sym->ns && sym->ns == gfc_current_ns->parent)
2906 || (sym->ns && gfc_current_ns->parent
2907 && sym->ns == gfc_current_ns->parent->parent)
2908 || (sym->ns->proc_name != NULL
2909 && sym->ns->proc_name->attr.flavor == FL_MODULE)
2910 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2916 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2917 sym->name, &e->where);
2918 /* Prevent a repetition of the error. */
2927 case EXPR_SUBSTRING:
2928 t = gfc_specification_expr (e->ref->u.ss.start);
2932 t = gfc_specification_expr (e->ref->u.ss.end);
2934 t = gfc_simplify_expr (e, 0);
2938 case EXPR_STRUCTURE:
2939 t = gfc_check_constructor (e, check_restricted);
2943 t = gfc_check_constructor (e, check_restricted);
2947 gfc_internal_error ("check_restricted(): Unknown expression type");
2954 /* Check to see that an expression is a specification expression. If
2955 we return FAILURE, an error has been generated. */
2958 gfc_specification_expr (gfc_expr *e)
2960 gfc_component *comp;
2965 if (e->ts.type != BT_INTEGER)
2967 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2968 &e->where, gfc_basic_typename (e->ts.type));
2972 if (e->expr_type == EXPR_FUNCTION
2973 && !e->value.function.isym
2974 && !e->value.function.esym
2975 && !gfc_pure (e->symtree->n.sym)
2976 && (!gfc_is_proc_ptr_comp (e, &comp)
2977 || !comp->attr.pure))
2979 gfc_error ("Function '%s' at %L must be PURE",
2980 e->symtree->n.sym->name, &e->where);
2981 /* Prevent repeat error messages. */
2982 e->symtree->n.sym->attr.pure = 1;
2988 gfc_error ("Expression at %L must be scalar", &e->where);
2992 if (gfc_simplify_expr (e, 0) == FAILURE)
2995 return check_restricted (e);
2999 /************** Expression conformance checks. *************/
3001 /* Given two expressions, make sure that the arrays are conformable. */
3004 gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
3006 int op1_flag, op2_flag, d;
3007 mpz_t op1_size, op2_size;
3013 if (op1->rank == 0 || op2->rank == 0)
3016 va_start (argp, optype_msgid);
3017 vsnprintf (buffer, 240, optype_msgid, argp);
3020 if (op1->rank != op2->rank)
3022 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
3023 op1->rank, op2->rank, &op1->where);
3029 for (d = 0; d < op1->rank; d++)
3031 op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
3032 op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
3034 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
3036 gfc_error ("Different shape for %s at %L on dimension %d "
3037 "(%d and %d)", _(buffer), &op1->where, d + 1,
3038 (int) mpz_get_si (op1_size),
3039 (int) mpz_get_si (op2_size));
3045 mpz_clear (op1_size);
3047 mpz_clear (op2_size);
3057 /* Given an assignable expression and an arbitrary expression, make
3058 sure that the assignment can take place. */
3061 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
3067 sym = lvalue->symtree->n.sym;
3069 /* See if this is the component or subcomponent of a pointer. */
3070 has_pointer = sym->attr.pointer;
3071 for (ref = lvalue->ref; ref; ref = ref->next)
3072 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
3078 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3079 variable local to a function subprogram. Its existence begins when
3080 execution of the function is initiated and ends when execution of the
3081 function is terminated...
3082 Therefore, the left hand side is no longer a variable, when it is: */
3083 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
3084 && !sym->attr.external)
3089 /* (i) Use associated; */
3090 if (sym->attr.use_assoc)
3093 /* (ii) The assignment is in the main program; or */
3094 if (gfc_current_ns->proc_name->attr.is_main_program)
3097 /* (iii) A module or internal procedure... */
3098 if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
3099 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
3100 && gfc_current_ns->parent
3101 && (!(gfc_current_ns->parent->proc_name->attr.function
3102 || gfc_current_ns->parent->proc_name->attr.subroutine)
3103 || gfc_current_ns->parent->proc_name->attr.is_main_program))
3105 /* ... that is not a function... */
3106 if (!gfc_current_ns->proc_name->attr.function)
3109 /* ... or is not an entry and has a different name. */
3110 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
3114 /* (iv) Host associated and not the function symbol or the
3115 parent result. This picks up sibling references, which
3116 cannot be entries. */
3117 if (!sym->attr.entry
3118 && sym->ns == gfc_current_ns->parent
3119 && sym != gfc_current_ns->proc_name
3120 && sym != gfc_current_ns->parent->proc_name->result)
3125 gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
3130 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
3132 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3133 lvalue->rank, rvalue->rank, &lvalue->where);
3137 if (lvalue->ts.type == BT_UNKNOWN)
3139 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3144 if (rvalue->expr_type == EXPR_NULL)
3146 if (has_pointer && (ref == NULL || ref->next == NULL)
3147 && lvalue->symtree->n.sym->attr.data)
3151 gfc_error ("NULL appears on right-hand side in assignment at %L",
3157 /* This is possibly a typo: x = f() instead of x => f(). */
3158 if (gfc_option.warn_surprising
3159 && rvalue->expr_type == EXPR_FUNCTION
3160 && rvalue->symtree->n.sym->attr.pointer)
3161 gfc_warning ("POINTER valued function appears on right-hand side of "
3162 "assignment at %L", &rvalue->where);
3164 /* Check size of array assignments. */
3165 if (lvalue->rank != 0 && rvalue->rank != 0
3166 && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
3169 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
3170 && lvalue->symtree->n.sym->attr.data
3171 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
3172 "initialize non-integer variable '%s'",
3173 &rvalue->where, lvalue->symtree->n.sym->name)
3176 else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
3177 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
3178 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3179 &rvalue->where) == FAILURE)
3182 /* Handle the case of a BOZ literal on the RHS. */
3183 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
3186 if (gfc_option.warn_surprising)
3187 gfc_warning ("BOZ literal at %L is bitwise transferred "
3188 "non-integer symbol '%s'", &rvalue->where,
3189 lvalue->symtree->n.sym->name);
3190 if (!gfc_convert_boz (rvalue, &lvalue->ts))
3192 if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
3194 if (rc == ARITH_UNDERFLOW)
3195 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3196 ". This check can be disabled with the option "
3197 "-fno-range-check", &rvalue->where);
3198 else if (rc == ARITH_OVERFLOW)
3199 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3200 ". This check can be disabled with the option "
3201 "-fno-range-check", &rvalue->where);
3202 else if (rc == ARITH_NAN)
3203 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3204 ". This check can be disabled with the option "
3205 "-fno-range-check", &rvalue->where);
3210 /* Warn about type-changing conversions for REAL or COMPLEX constants.
3211 If lvalue and rvalue are mixed REAL and complex, gfc_compare_types
3212 will warn anyway, so there is no need to to so here. */
3214 if (rvalue->expr_type == EXPR_CONSTANT && lvalue->ts.type == rvalue->ts.type
3215 && (lvalue->ts.type == BT_REAL || lvalue->ts.type == BT_COMPLEX))
3217 if (lvalue->ts.kind < rvalue->ts.kind && gfc_option.gfc_warn_conversion)
3219 /* As a special bonus, don't warn about REAL rvalues which are not
3220 changed by the conversion if -Wconversion is specified. */
3221 if (rvalue->ts.type == BT_REAL && mpfr_number_p (rvalue->value.real))
3223 /* Calculate the difference between the constant and the rounded
3224 value and check it against zero. */
3226 gfc_set_model_kind (lvalue->ts.kind);
3228 gfc_set_model_kind (rvalue->ts.kind);
3231 mpfr_set (rv, rvalue->value.real, GFC_RND_MODE);
3232 mpfr_sub (diff, rv, rvalue->value.real, GFC_RND_MODE);
3234 if (!mpfr_zero_p (diff))
3235 gfc_warning ("Change of value in conversion from "
3236 " %s to %s at %L", gfc_typename (&rvalue->ts),
3237 gfc_typename (&lvalue->ts), &rvalue->where);
3243 gfc_warning ("Possible change of value in conversion from %s "
3244 "to %s at %L",gfc_typename (&rvalue->ts),
3245 gfc_typename (&lvalue->ts), &rvalue->where);
3248 else if (gfc_option.warn_conversion_extra
3249 && lvalue->ts.kind > rvalue->ts.kind)
3251 gfc_warning ("Conversion from %s to %s at %L",
3252 gfc_typename (&rvalue->ts),
3253 gfc_typename (&lvalue->ts), &rvalue->where);
3257 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
3260 /* Only DATA Statements come here. */
3263 /* Numeric can be converted to any other numeric. And Hollerith can be
3264 converted to any other type. */
3265 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3266 || rvalue->ts.type == BT_HOLLERITH)
3269 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3272 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3273 "conversion of %s to %s", &lvalue->where,
3274 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3279 /* Assignment is the only case where character variables of different
3280 kind values can be converted into one another. */
3281 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3283 if (lvalue->ts.kind != rvalue->ts.kind)
3284 gfc_convert_chartype (rvalue, &lvalue->ts);
3289 return gfc_convert_type (rvalue, &lvalue->ts, 1);
3293 /* Check that a pointer assignment is OK. We first check lvalue, and
3294 we only check rvalue if it's not an assignment to NULL() or a
3295 NULLIFY statement. */
3298 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3300 symbol_attribute attr;
3302 bool is_pure, is_implicit_pure, rank_remap;
3305 if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3306 && !lvalue->symtree->n.sym->attr.proc_pointer)
3308 gfc_error ("Pointer assignment target is not a POINTER at %L",
3313 if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3314 && lvalue->symtree->n.sym->attr.use_assoc
3315 && !lvalue->symtree->n.sym->attr.proc_pointer)
3317 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3318 "l-value since it is a procedure",
3319 lvalue->symtree->n.sym->name, &lvalue->where);
3323 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3326 for (ref = lvalue->ref; ref; ref = ref->next)
3328 if (ref->type == REF_COMPONENT)
3329 proc_pointer = ref->u.c.component->attr.proc_pointer;
3331 if (ref->type == REF_ARRAY && ref->next == NULL)
3335 if (ref->u.ar.type == AR_FULL)
3338 if (ref->u.ar.type != AR_SECTION)
3340 gfc_error ("Expected bounds specification for '%s' at %L",
3341 lvalue->symtree->n.sym->name, &lvalue->where);
3345 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3346 "specification for '%s' in pointer assignment "
3347 "at %L", lvalue->symtree->n.sym->name,
3348 &lvalue->where) == FAILURE)
3351 /* When bounds are given, all lbounds are necessary and either all
3352 or none of the upper bounds; no strides are allowed. If the
3353 upper bounds are present, we may do rank remapping. */
3354 for (dim = 0; dim < ref->u.ar.dimen; ++dim)
3356 if (!ref->u.ar.start[dim]
3357 || ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3359 gfc_error ("Lower bound has to be present at %L",
3363 if (ref->u.ar.stride[dim])
3365 gfc_error ("Stride must not be present at %L",
3371 rank_remap = (ref->u.ar.end[dim] != NULL);
3374 if ((rank_remap && !ref->u.ar.end[dim])
3375 || (!rank_remap && ref->u.ar.end[dim]))
3377 gfc_error ("Either all or none of the upper bounds"
3378 " must be specified at %L", &lvalue->where);
3386 is_pure = gfc_pure (NULL);
3387 is_implicit_pure = gfc_implicit_pure (NULL);
3389 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3390 kind, etc for lvalue and rvalue must match, and rvalue must be a
3391 pure variable if we're in a pure function. */
3392 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3395 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3396 if (lvalue->expr_type == EXPR_VARIABLE
3397 && gfc_is_coindexed (lvalue))
3400 for (ref = lvalue->ref; ref; ref = ref->next)
3401 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3403 gfc_error ("Pointer object at %L shall not have a coindex",
3409 /* Checks on rvalue for procedure pointer assignments. */
3414 gfc_component *comp;
3417 attr = gfc_expr_attr (rvalue);
3418 if (!((rvalue->expr_type == EXPR_NULL)
3419 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3420 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
3421 || (rvalue->expr_type == EXPR_VARIABLE
3422 && attr.flavor == FL_PROCEDURE)))
3424 gfc_error ("Invalid procedure pointer assignment at %L",
3430 gfc_error ("Abstract interface '%s' is invalid "
3431 "in procedure pointer assignment at %L",
3432 rvalue->symtree->name, &rvalue->where);
3435 /* Check for F08:C729. */
3436 if (attr.flavor == FL_PROCEDURE)
3438 if (attr.proc == PROC_ST_FUNCTION)
3440 gfc_error ("Statement function '%s' is invalid "
3441 "in procedure pointer assignment at %L",
3442 rvalue->symtree->name, &rvalue->where);
3445 if (attr.proc == PROC_INTERNAL &&
3446 gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
3447 "invalid in procedure pointer assignment at %L",
3448 rvalue->symtree->name, &rvalue->where) == FAILURE)
3451 /* Check for F08:C730. */
3452 if (attr.elemental && !attr.intrinsic)
3454 gfc_error ("Nonintrinsic elemental procedure '%s' is invalid "
3455 "in procedure pointer assigment at %L",
3456 rvalue->symtree->name, &rvalue->where);
3460 /* Ensure that the calling convention is the same. As other attributes
3461 such as DLLEXPORT may differ, one explicitly only tests for the
3462 calling conventions. */
3463 if (rvalue->expr_type == EXPR_VARIABLE
3464 && lvalue->symtree->n.sym->attr.ext_attr
3465 != rvalue->symtree->n.sym->attr.ext_attr)
3467 symbol_attribute calls;
3470 gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
3471 gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
3472 gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
3474 if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
3475 != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
3477 gfc_error ("Mismatch in the procedure pointer assignment "
3478 "at %L: mismatch in the calling convention",
3484 if (gfc_is_proc_ptr_comp (lvalue, &comp))
3485 s1 = comp->ts.interface;
3487 s1 = lvalue->symtree->n.sym;
3489 if (gfc_is_proc_ptr_comp (rvalue, &comp))
3491 s2 = comp->ts.interface;
3494 else if (rvalue->expr_type == EXPR_FUNCTION)
3496 if (rvalue->value.function.esym)
3497 s2 = rvalue->value.function.esym->result;
3499 s2 = rvalue->symtree->n.sym->result;
3505 s2 = rvalue->symtree->n.sym;
3506 name = rvalue->symtree->n.sym->name;
3509 if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
3512 gfc_error ("Interface mismatch in procedure pointer assignment "
3513 "at %L: %s", &rvalue->where, err);
3520 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3522 gfc_error ("Different types in pointer assignment at %L; attempted "
3523 "assignment of %s to %s", &lvalue->where,
3524 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3528 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
3530 gfc_error ("Different kind type parameters in pointer "
3531 "assignment at %L", &lvalue->where);
3535 if (lvalue->rank != rvalue->rank && !rank_remap)
3537 gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
3541 if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
3542 /* Make sure the vtab is present. */
3543 gfc_find_derived_vtab (rvalue->ts.u.derived);
3545 /* Check rank remapping. */
3550 /* If this can be determined, check that the target must be at least as
3551 large as the pointer assigned to it is. */
3552 if (gfc_array_size (lvalue, &lsize) == SUCCESS
3553 && gfc_array_size (rvalue, &rsize) == SUCCESS
3554 && mpz_cmp (rsize, lsize) < 0)
3556 gfc_error ("Rank remapping target is smaller than size of the"
3557 " pointer (%ld < %ld) at %L",
3558 mpz_get_si (rsize), mpz_get_si (lsize),
3563 /* The target must be either rank one or it must be simply contiguous
3564 and F2008 must be allowed. */
3565 if (rvalue->rank != 1)
3567 if (!gfc_is_simply_contiguous (rvalue, true))
3569 gfc_error ("Rank remapping target must be rank 1 or"
3570 " simply contiguous at %L", &rvalue->where);
3573 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Rank remapping"
3574 " target is not rank 1 at %L", &rvalue->where)
3580 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3581 if (rvalue->expr_type == EXPR_NULL)
3584 if (lvalue->ts.type == BT_CHARACTER)
3586 gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3591 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3592 lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3594 attr = gfc_expr_attr (rvalue);
3596 if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer)
3598 gfc_error ("Target expression in pointer assignment "
3599 "at %L must deliver a pointer result",
3604 if (!attr.target && !attr.pointer)
3606 gfc_error ("Pointer assignment target is neither TARGET "
3607 "nor POINTER at %L", &rvalue->where);
3611 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3613 gfc_error ("Bad target in pointer assignment in PURE "
3614 "procedure at %L", &rvalue->where);
3617 if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3618 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3621 if (gfc_has_vector_index (rvalue))
3623 gfc_error ("Pointer assignment with vector subscript "
3624 "on rhs at %L", &rvalue->where);
3628 if (attr.is_protected && attr.use_assoc
3629 && !(attr.pointer || attr.proc_pointer))
3631 gfc_error ("Pointer assignment target has PROTECTED "
3632 "attribute at %L", &rvalue->where);
3636 /* F2008, C725. For PURE also C1283. */
3637 if (rvalue->expr_type == EXPR_VARIABLE
3638 && gfc_is_coindexed (rvalue))
3641 for (ref = rvalue->ref; ref; ref = ref->next)
3642 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3644 gfc_error ("Data target at %L shall not have a coindex",
3654 /* Relative of gfc_check_assign() except that the lvalue is a single
3655 symbol. Used for initialization assignments. */
3658 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3663 memset (&lvalue, '\0', sizeof (gfc_expr));
3665 lvalue.expr_type = EXPR_VARIABLE;
3666 lvalue.ts = sym->ts;
3668 lvalue.rank = sym->as->rank;
3669 lvalue.symtree = XCNEW (gfc_symtree);
3670 lvalue.symtree->n.sym = sym;
3671 lvalue.where = sym->declared_at;
3673 if (sym->attr.pointer || sym->attr.proc_pointer
3674 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer
3675 && rvalue->expr_type == EXPR_NULL))
3676 r = gfc_check_pointer_assign (&lvalue, rvalue);
3678 r = gfc_check_assign (&lvalue, rvalue, 1);
3680 free (lvalue.symtree);
3685 if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL)
3687 /* F08:C461. Additional checks for pointer initialization. */
3688 symbol_attribute attr;
3689 attr = gfc_expr_attr (rvalue);
3690 if (attr.allocatable)
3692 gfc_error ("Pointer initialization target at %C "
3693 "must not be ALLOCATABLE ");
3696 if (!attr.target || attr.pointer)
3698 gfc_error ("Pointer initialization target at %C "
3699 "must have the TARGET attribute");
3704 gfc_error ("Pointer initialization target at %C "
3705 "must have the SAVE attribute");
3710 if (sym->attr.proc_pointer && rvalue->expr_type != EXPR_NULL)
3712 /* F08:C1220. Additional checks for procedure pointer initialization. */
3713 symbol_attribute attr = gfc_expr_attr (rvalue);
3714 if (attr.proc_pointer)
3716 gfc_error ("Procedure pointer initialization target at %L "
3717 "may not be a procedure pointer", &rvalue->where);
3726 /* Check for default initializer; sym->value is not enough
3727 as it is also set for EXPR_NULL of allocatables. */
3730 gfc_has_default_initializer (gfc_symbol *der)
3734 gcc_assert (der->attr.flavor == FL_DERIVED);
3735 for (c = der->components; c; c = c->next)
3736 if (c->ts.type == BT_DERIVED)
3738 if (!c->attr.pointer
3739 && gfc_has_default_initializer (c->ts.u.derived))
3741 if (c->attr.pointer && c->initializer)
3754 /* Get an expression for a default initializer. */
3757 gfc_default_initializer (gfc_typespec *ts)
3760 gfc_component *comp;
3762 /* See if we have a default initializer in this, but not in nested
3763 types (otherwise we could use gfc_has_default_initializer()). */
3764 for (comp = ts->u.derived->components; comp; comp = comp->next)
3765 if (comp->initializer || comp->attr.allocatable
3766 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
3767 && CLASS_DATA (comp)->attr.allocatable))
3773 init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
3774 &ts->u.derived->declared_at);
3777 for (comp = ts->u.derived->components; comp; comp = comp->next)
3779 gfc_constructor *ctor = gfc_constructor_get();
3781 if (comp->initializer)
3783 ctor->expr = gfc_copy_expr (comp->initializer);
3784 if ((comp->ts.type != comp->initializer->ts.type
3785 || comp->ts.kind != comp->initializer->ts.kind)
3786 && !comp->attr.pointer && !comp->attr.proc_pointer)
3787 gfc_convert_type_warn (ctor->expr, &comp->ts, 2, false);
3790 if (comp->attr.allocatable
3791 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
3793 ctor->expr = gfc_get_expr ();
3794 ctor->expr->expr_type = EXPR_NULL;
3795 ctor->expr->ts = comp->ts;
3798 gfc_constructor_append (&init->value.constructor, ctor);
3805 /* Given a symbol, create an expression node with that symbol as a
3806 variable. If the symbol is array valued, setup a reference of the
3810 gfc_get_variable_expr (gfc_symtree *var)
3814 e = gfc_get_expr ();
3815 e->expr_type = EXPR_VARIABLE;
3817 e->ts = var->n.sym->ts;
3819 if ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS)
3820 || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym)
3821 && CLASS_DATA (var->n.sym)->as))
3823 e->rank = var->n.sym->ts.type == BT_CLASS
3824 ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank;
3825 e->ref = gfc_get_ref ();
3826 e->ref->type = REF_ARRAY;
3827 e->ref->u.ar.type = AR_FULL;
3835 gfc_lval_expr_from_sym (gfc_symbol *sym)
3838 lval = gfc_get_expr ();
3839 lval->expr_type = EXPR_VARIABLE;
3840 lval->where = sym->declared_at;
3842 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
3844 /* It will always be a full array. */
3845 lval->rank = sym->as ? sym->as->rank : 0;
3848 lval->ref = gfc_get_ref ();
3849 lval->ref->type = REF_ARRAY;
3850 lval->ref->u.ar.type = AR_FULL;
3851 lval->ref->u.ar.dimen = lval->rank;
3852 lval->ref->u.ar.where = sym->declared_at;
3853 lval->ref->u.ar.as = sym->ts.type == BT_CLASS
3854 ? CLASS_DATA (sym)->as : sym->as;
3861 /* Returns the array_spec of a full array expression. A NULL is
3862 returned otherwise. */
3864 gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
3869 if (expr->rank == 0)
3872 /* Follow any component references. */
3873 if (expr->expr_type == EXPR_VARIABLE
3874 || expr->expr_type == EXPR_CONSTANT)
3876 as = expr->symtree->n.sym->as;
3877 for (ref = expr->ref; ref; ref = ref->next)
3882 as = ref->u.c.component->as;
3890 switch (ref->u.ar.type)
3913 /* General expression traversal function. */
3916 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3917 bool (*func)(gfc_expr *, gfc_symbol *, int*),
3922 gfc_actual_arglist *args;
3929 if ((*func) (expr, sym, &f))
3932 if (expr->ts.type == BT_CHARACTER
3934 && expr->ts.u.cl->length
3935 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
3936 && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
3939 switch (expr->expr_type)
3944 for (args = expr->value.function.actual; args; args = args->next)
3946 if (gfc_traverse_expr (args->expr, sym, func, f))
3954 case EXPR_SUBSTRING:
3957 case EXPR_STRUCTURE:
3959 for (c = gfc_constructor_first (expr->value.constructor);
3960 c; c = gfc_constructor_next (c))
3962 if (gfc_traverse_expr (c->expr, sym, func, f))
3966 if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3968 if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3970 if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3972 if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3979 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3981 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3997 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3999 if (gfc_traverse_expr (ar.start[i], sym, func, f))
4001 if (gfc_traverse_expr (ar.end[i], sym, func, f))
4003 if (gfc_traverse_expr (ar.stride[i], sym, func, f))
4009 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
4011 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
4016 if (ref->u.c.component->ts.type == BT_CHARACTER
4017 && ref->u.c.component->ts.u.cl
4018 && ref->u.c.component->ts.u.cl->length
4019 && ref->u.c.component->ts.u.cl->length->expr_type
4021 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
4025 if (ref->u.c.component->as)
4026 for (i = 0; i < ref->u.c.component->as->rank
4027 + ref->u.c.component->as->corank; i++)
4029 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
4032 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
4046 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4049 expr_set_symbols_referenced (gfc_expr *expr,
4050 gfc_symbol *sym ATTRIBUTE_UNUSED,
4051 int *f ATTRIBUTE_UNUSED)
4053 if (expr->expr_type != EXPR_VARIABLE)
4055 gfc_set_sym_referenced (expr->symtree->n.sym);
4060 gfc_expr_set_symbols_referenced (gfc_expr *expr)
4062 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
4066 /* Determine if an expression is a procedure pointer component. If yes, the
4067 argument 'comp' will point to the component (provided that 'comp' was
4071 gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
4076 if (!expr || !expr->ref)
4083 if (ref->type == REF_COMPONENT)
4085 ppc = ref->u.c.component->attr.proc_pointer;
4087 *comp = ref->u.c.component;
4094 /* Walk an expression tree and check each variable encountered for being typed.
4095 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4096 mode as is a basic arithmetic expression using those; this is for things in
4099 INTEGER :: arr(n), n
4100 INTEGER :: arr(n + 1), n
4102 The namespace is needed for IMPLICIT typing. */
4104 static gfc_namespace* check_typed_ns;
4107 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
4108 int* f ATTRIBUTE_UNUSED)
4112 if (e->expr_type != EXPR_VARIABLE)
4115 gcc_assert (e->symtree);
4116 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
4119 return (t == FAILURE);
4123 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
4127 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4131 if (e->expr_type == EXPR_VARIABLE && !e->ref)
4132 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
4134 if (e->expr_type == EXPR_OP)
4136 gfc_try t = SUCCESS;
4138 gcc_assert (e->value.op.op1);
4139 t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
4141 if (t == SUCCESS && e->value.op.op2)
4142 t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
4148 /* Otherwise, walk the expression and do it strictly. */
4149 check_typed_ns = ns;
4150 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
4152 return error_found ? FAILURE : SUCCESS;
4156 /* Walk an expression tree and replace all dummy symbols by the corresponding
4157 symbol in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
4158 statements. The boolean return value is required by gfc_traverse_expr. */
4161 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
4163 if ((expr->expr_type == EXPR_VARIABLE
4164 || (expr->expr_type == EXPR_FUNCTION
4165 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
4166 && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns
4167 && expr->symtree->n.sym->attr.dummy)
4169 gfc_symtree *root = sym->formal_ns ? sym->formal_ns->sym_root
4170 : gfc_current_ns->sym_root;
4171 gfc_symtree *stree = gfc_find_symtree (root, expr->symtree->n.sym->name);
4173 stree->n.sym->attr = expr->symtree->n.sym->attr;
4174 expr->symtree = stree;
4180 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
4182 gfc_traverse_expr (expr, dest, &replace_symbol, 0);
4186 /* The following is analogous to 'replace_symbol', and needed for copying
4187 interfaces for procedure pointer components. The argument 'sym' must formally
4188 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
4189 However, it gets actually passed a gfc_component (i.e. the procedure pointer
4190 component in whose formal_ns the arguments have to be). */
4193 replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
4195 gfc_component *comp;
4196 comp = (gfc_component *)sym;
4197 if ((expr->expr_type == EXPR_VARIABLE
4198 || (expr->expr_type == EXPR_FUNCTION && !expr->value.function.isym
4199 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
4200 && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
4203 gfc_namespace *ns = comp->formal_ns;
4204 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4205 the symtree rather than create a new one (and probably fail later). */
4206 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
4207 expr->symtree->n.sym->name);
4209 stree->n.sym->attr = expr->symtree->n.sym->attr;
4210 expr->symtree = stree;
4216 gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
4218 gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
4223 gfc_ref_this_image (gfc_ref *ref)
4227 gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0);
4229 for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
4230 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
4238 gfc_is_coindexed (gfc_expr *e)
4242 for (ref = e->ref; ref; ref = ref->next)
4243 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
4244 return !gfc_ref_this_image (ref);
4250 /* Coarrays are variables with a corank but not being coindexed. However, also
4251 the following is a coarray: A subobject of a coarray is a coarray if it does
4252 not have any cosubscripts, vector subscripts, allocatable component
4253 selection, or pointer component selection. (F2008, 2.4.7) */
4256 gfc_is_coarray (gfc_expr *e)
4260 gfc_component *comp;
4265 if (e->expr_type != EXPR_VARIABLE)
4269 sym = e->symtree->n.sym;
4271 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
4272 coarray = CLASS_DATA (sym)->attr.codimension;
4274 coarray = sym->attr.codimension;
4276 for (ref = e->ref; ref; ref = ref->next)
4280 comp = ref->u.c.component;
4281 if (comp->ts.type == BT_CLASS && comp->attr.class_ok
4282 && (CLASS_DATA (comp)->attr.class_pointer
4283 || CLASS_DATA (comp)->attr.allocatable))
4286 coarray = CLASS_DATA (comp)->attr.codimension;
4288 else if (comp->attr.pointer || comp->attr.allocatable)
4291 coarray = comp->attr.codimension;
4299 if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref))
4305 for (i = 0; i < ref->u.ar.dimen; i++)
4306 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4317 return coarray && !coindexed;
4322 gfc_get_corank (gfc_expr *e)
4327 if (!gfc_is_coarray (e))
4330 if (e->ts.type == BT_CLASS && e->ts.u.derived->components)
4331 corank = e->ts.u.derived->components->as
4332 ? e->ts.u.derived->components->as->corank : 0;
4334 corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
4336 for (ref = e->ref; ref; ref = ref->next)
4338 if (ref->type == REF_ARRAY)
4339 corank = ref->u.ar.as->corank;
4340 gcc_assert (ref->type != REF_SUBSTRING);
4347 /* Check whether the expression has an ultimate allocatable component.
4348 Being itself allocatable does not count. */
4350 gfc_has_ultimate_allocatable (gfc_expr *e)
4352 gfc_ref *ref, *last = NULL;
4354 if (e->expr_type != EXPR_VARIABLE)
4357 for (ref = e->ref; ref; ref = ref->next)
4358 if (ref->type == REF_COMPONENT)
4361 if (last && last->u.c.component->ts.type == BT_CLASS)
4362 return CLASS_DATA (last->u.c.component)->attr.alloc_comp;
4363 else if (last && last->u.c.component->ts.type == BT_DERIVED)
4364 return last->u.c.component->ts.u.derived->attr.alloc_comp;
4368 if (e->ts.type == BT_CLASS)
4369 return CLASS_DATA (e)->attr.alloc_comp;
4370 else if (e->ts.type == BT_DERIVED)
4371 return e->ts.u.derived->attr.alloc_comp;
4377 /* Check whether the expression has an pointer component.
4378 Being itself a pointer does not count. */
4380 gfc_has_ultimate_pointer (gfc_expr *e)
4382 gfc_ref *ref, *last = NULL;
4384 if (e->expr_type != EXPR_VARIABLE)
4387 for (ref = e->ref; ref; ref = ref->next)
4388 if (ref->type == REF_COMPONENT)
4391 if (last && last->u.c.component->ts.type == BT_CLASS)
4392 return CLASS_DATA (last->u.c.component)->attr.pointer_comp;
4393 else if (last && last->u.c.component->ts.type == BT_DERIVED)
4394 return last->u.c.component->ts.u.derived->attr.pointer_comp;
4398 if (e->ts.type == BT_CLASS)
4399 return CLASS_DATA (e)->attr.pointer_comp;
4400 else if (e->ts.type == BT_DERIVED)
4401 return e->ts.u.derived->attr.pointer_comp;
4407 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4408 Note: A scalar is not regarded as "simply contiguous" by the standard.
4409 if bool is not strict, some futher checks are done - for instance,
4410 a "(::1)" is accepted. */
4413 gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
4417 gfc_array_ref *ar = NULL;
4418 gfc_ref *ref, *part_ref = NULL;
4421 if (expr->expr_type == EXPR_FUNCTION)
4422 return expr->value.function.esym
4423 ? expr->value.function.esym->result->attr.contiguous : false;
4424 else if (expr->expr_type != EXPR_VARIABLE)
4427 if (expr->rank == 0)
4430 for (ref = expr->ref; ref; ref = ref->next)
4433 return false; /* Array shall be last part-ref. */
4435 if (ref->type == REF_COMPONENT)
4437 else if (ref->type == REF_SUBSTRING)
4439 else if (ref->u.ar.type != AR_ELEMENT)
4443 sym = expr->symtree->n.sym;
4444 if (expr->ts.type != BT_CLASS
4446 && !part_ref->u.c.component->attr.contiguous
4447 && part_ref->u.c.component->attr.pointer)
4449 && !sym->attr.contiguous
4450 && (sym->attr.pointer
4451 || sym->as->type == AS_ASSUMED_SHAPE))))
4454 if (!ar || ar->type == AR_FULL)
4457 gcc_assert (ar->type == AR_SECTION);
4459 /* Check for simply contiguous array */
4461 for (i = 0; i < ar->dimen; i++)
4463 if (ar->dimen_type[i] == DIMEN_VECTOR)
4466 if (ar->dimen_type[i] == DIMEN_ELEMENT)
4472 gcc_assert (ar->dimen_type[i] == DIMEN_RANGE);
4475 /* If the previous section was not contiguous, that's an error,
4476 unless we have effective only one element and checking is not
4478 if (!colon && (strict || !ar->start[i] || !ar->end[i]
4479 || ar->start[i]->expr_type != EXPR_CONSTANT
4480 || ar->end[i]->expr_type != EXPR_CONSTANT
4481 || mpz_cmp (ar->start[i]->value.integer,
4482 ar->end[i]->value.integer) != 0))
4485 /* Following the standard, "(::1)" or - if known at compile time -
4486 "(lbound:ubound)" are not simply contigous; if strict
4487 is false, they are regarded as simply contiguous. */
4488 if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT
4489 || ar->stride[i]->ts.type != BT_INTEGER
4490 || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0))
4494 && (strict || ar->start[i]->expr_type != EXPR_CONSTANT
4495 || !ar->as->lower[i]
4496 || ar->as->lower[i]->expr_type != EXPR_CONSTANT
4497 || mpz_cmp (ar->start[i]->value.integer,
4498 ar->as->lower[i]->value.integer) != 0))
4502 && (strict || ar->end[i]->expr_type != EXPR_CONSTANT
4503 || !ar->as->upper[i]
4504 || ar->as->upper[i]->expr_type != EXPR_CONSTANT
4505 || mpz_cmp (ar->end[i]->value.integer,
4506 ar->as->upper[i]->value.integer) != 0))
4514 /* Build call to an intrinsic procedure. The number of arguments has to be
4515 passed (rather than ending the list with a NULL value) because we may
4516 want to add arguments but with a NULL-expression. */
4519 gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name,
4520 locus where, unsigned numarg, ...)
4523 gfc_actual_arglist* atail;
4524 gfc_intrinsic_sym* isym;
4527 const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name);
4529 isym = gfc_intrinsic_function_by_id (id);
4532 result = gfc_get_expr ();
4533 result->expr_type = EXPR_FUNCTION;
4534 result->ts = isym->ts;
4535 result->where = where;
4536 result->value.function.name = mangled_name;
4537 result->value.function.isym = isym;
4539 gfc_get_sym_tree (mangled_name, ns, &result->symtree, false);
4540 gfc_commit_symbol (result->symtree->n.sym);
4541 gcc_assert (result->symtree
4542 && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE
4543 || result->symtree->n.sym->attr.flavor == FL_UNKNOWN));
4545 result->symtree->n.sym->intmod_sym_id = id;
4546 result->symtree->n.sym->attr.flavor = FL_PROCEDURE;
4547 result->symtree->n.sym->attr.intrinsic = 1;
4549 va_start (ap, numarg);
4551 for (i = 0; i < numarg; ++i)
4555 atail->next = gfc_get_actual_arglist ();
4556 atail = atail->next;
4559 atail = result->value.function.actual = gfc_get_actual_arglist ();
4561 atail->expr = va_arg (ap, gfc_expr*);
4569 /* Check if an expression may appear in a variable definition context
4570 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
4571 This is called from the various places when resolving
4572 the pieces that make up such a context.
4574 Optionally, a possible error message can be suppressed if context is NULL
4575 and just the return status (SUCCESS / FAILURE) be requested. */
4578 gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
4579 const char* context)
4581 gfc_symbol* sym = NULL;
4583 bool check_intentin;
4585 symbol_attribute attr;
4588 if (e->expr_type == EXPR_VARIABLE)
4590 gcc_assert (e->symtree);
4591 sym = e->symtree->n.sym;
4593 else if (e->expr_type == EXPR_FUNCTION)
4595 gcc_assert (e->symtree);
4596 sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym;
4599 attr = gfc_expr_attr (e);
4600 if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer)
4602 if (!(gfc_option.allow_std & GFC_STD_F2008))
4605 gfc_error ("Fortran 2008: Pointer functions in variable definition"
4606 " context (%s) at %L", context, &e->where);
4610 else if (e->expr_type != EXPR_VARIABLE)
4613 gfc_error ("Non-variable expression in variable definition context (%s)"
4614 " at %L", context, &e->where);
4618 if (!pointer && sym->attr.flavor == FL_PARAMETER)
4621 gfc_error ("Named constant '%s' in variable definition context (%s)"
4622 " at %L", sym->name, context, &e->where);
4625 if (!pointer && sym->attr.flavor != FL_VARIABLE
4626 && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result)
4627 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
4630 gfc_error ("'%s' in variable definition context (%s) at %L is not"
4631 " a variable", sym->name, context, &e->where);
4635 /* Find out whether the expr is a pointer; this also means following
4636 component references to the last one. */
4637 is_pointer = (attr.pointer || attr.proc_pointer);
4638 if (pointer && !is_pointer)
4641 gfc_error ("Non-POINTER in pointer association context (%s)"
4642 " at %L", context, &e->where);
4649 || (e->ts.type == BT_DERIVED
4650 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
4651 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)))
4654 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
4655 context, &e->where);
4659 /* INTENT(IN) dummy argument. Check this, unless the object itself is
4660 the component of sub-component of a pointer. Obviously,
4661 procedure pointers are of no interest here. */
4662 check_intentin = true;
4663 ptr_component = sym->attr.pointer;
4664 for (ref = e->ref; ref && check_intentin; ref = ref->next)
4666 if (ptr_component && ref->type == REF_COMPONENT)
4667 check_intentin = false;
4668 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
4670 ptr_component = true;
4672 check_intentin = false;
4675 if (check_intentin && sym->attr.intent == INTENT_IN)
4677 if (pointer && is_pointer)
4680 gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
4681 " association context (%s) at %L",
4682 sym->name, context, &e->where);
4685 if (!pointer && !is_pointer && !sym->attr.pointer)
4688 gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
4689 " definition context (%s) at %L",
4690 sym->name, context, &e->where);
4695 /* PROTECTED and use-associated. */
4696 if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin)
4698 if (pointer && is_pointer)
4701 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4702 " pointer association context (%s) at %L",
4703 sym->name, context, &e->where);
4706 if (!pointer && !is_pointer)
4709 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4710 " variable definition context (%s) at %L",
4711 sym->name, context, &e->where);
4716 /* Variable not assignable from a PURE procedure but appears in
4717 variable definition context. */
4718 if (!pointer && gfc_pure (NULL) && gfc_impure_variable (sym))
4721 gfc_error ("Variable '%s' can not appear in a variable definition"
4722 " context (%s) at %L in PURE procedure",
4723 sym->name, context, &e->where);
4727 if (!pointer && context && gfc_implicit_pure (NULL)
4728 && gfc_impure_variable (sym))
4733 for (ns = gfc_current_ns; ns; ns = ns->parent)
4735 sym = ns->proc_name;
4738 if (sym->attr.flavor == FL_PROCEDURE)
4740 sym->attr.implicit_pure = 0;
4745 /* Check variable definition context for associate-names. */
4746 if (!pointer && sym->assoc)
4749 gfc_association_list* assoc;
4751 gcc_assert (sym->assoc->target);
4753 /* If this is a SELECT TYPE temporary (the association is used internally
4754 for SELECT TYPE), silently go over to the target. */
4755 if (sym->attr.select_type_temporary)
4757 gfc_expr* t = sym->assoc->target;
4759 gcc_assert (t->expr_type == EXPR_VARIABLE);
4760 name = t->symtree->name;
4762 if (t->symtree->n.sym->assoc)
4763 assoc = t->symtree->n.sym->assoc;
4772 gcc_assert (name && assoc);
4774 /* Is association to a valid variable? */
4775 if (!assoc->variable)
4779 if (assoc->target->expr_type == EXPR_VARIABLE)
4780 gfc_error ("'%s' at %L associated to vector-indexed target can"
4781 " not be used in a variable definition context (%s)",
4782 name, &e->where, context);
4784 gfc_error ("'%s' at %L associated to expression can"
4785 " not be used in a variable definition context (%s)",
4786 name, &e->where, context);
4791 /* Target must be allowed to appear in a variable definition context. */
4792 if (gfc_check_vardef_context (assoc->target, pointer, false, NULL)
4796 gfc_error ("Associate-name '%s' can not appear in a variable"
4797 " definition context (%s) at %L because its target"
4798 " at %L can not, either",
4799 name, context, &e->where,
4800 &assoc->target->where);