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);
399 /* Workhorse function for gfc_free_expr() that frees everything
400 beneath an expression node, but not the node itself. This is
401 useful when we want to simplify a node and replace it with
402 something else or the expression node belongs to another structure. */
405 free_expr0 (gfc_expr *e)
409 switch (e->expr_type)
412 /* Free any parts of the value that need freeing. */
416 mpz_clear (e->value.integer);
420 mpfr_clear (e->value.real);
424 gfc_free (e->value.character.string);
428 mpc_clear (e->value.complex);
435 /* Free the representation. */
436 if (e->representation.string)
437 gfc_free (e->representation.string);
442 if (e->value.op.op1 != NULL)
443 gfc_free_expr (e->value.op.op1);
444 if (e->value.op.op2 != NULL)
445 gfc_free_expr (e->value.op.op2);
449 gfc_free_actual_arglist (e->value.function.actual);
454 gfc_free_actual_arglist (e->value.compcall.actual);
462 gfc_constructor_free (e->value.constructor);
466 gfc_free (e->value.character.string);
473 gfc_internal_error ("free_expr0(): Bad expr type");
476 /* Free a shape array. */
477 if (e->shape != NULL)
479 for (n = 0; n < e->rank; n++)
480 mpz_clear (e->shape[n]);
485 gfc_free_ref_list (e->ref);
487 memset (e, '\0', sizeof (gfc_expr));
491 /* Free an expression node and everything beneath it. */
494 gfc_free_expr (gfc_expr *e)
503 /* Free an argument list and everything below it. */
506 gfc_free_actual_arglist (gfc_actual_arglist *a1)
508 gfc_actual_arglist *a2;
513 gfc_free_expr (a1->expr);
520 /* Copy an arglist structure and all of the arguments. */
523 gfc_copy_actual_arglist (gfc_actual_arglist *p)
525 gfc_actual_arglist *head, *tail, *new_arg;
529 for (; p; p = p->next)
531 new_arg = gfc_get_actual_arglist ();
534 new_arg->expr = gfc_copy_expr (p->expr);
535 new_arg->next = NULL;
540 tail->next = new_arg;
549 /* Free a list of reference structures. */
552 gfc_free_ref_list (gfc_ref *p)
564 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
566 gfc_free_expr (p->u.ar.start[i]);
567 gfc_free_expr (p->u.ar.end[i]);
568 gfc_free_expr (p->u.ar.stride[i]);
574 gfc_free_expr (p->u.ss.start);
575 gfc_free_expr (p->u.ss.end);
587 /* Graft the *src expression onto the *dest subexpression. */
590 gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
598 /* Try to extract an integer constant from the passed expression node.
599 Returns an error message or NULL if the result is set. It is
600 tempting to generate an error and return SUCCESS or FAILURE, but
601 failure is OK for some callers. */
604 gfc_extract_int (gfc_expr *expr, int *result)
606 if (expr->expr_type != EXPR_CONSTANT)
607 return _("Constant expression required at %C");
609 if (expr->ts.type != BT_INTEGER)
610 return _("Integer expression required at %C");
612 if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
613 || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
615 return _("Integer value too large in expression at %C");
618 *result = (int) mpz_get_si (expr->value.integer);
624 /* Recursively copy a list of reference structures. */
627 gfc_copy_ref (gfc_ref *src)
635 dest = gfc_get_ref ();
636 dest->type = src->type;
641 ar = gfc_copy_array_ref (&src->u.ar);
647 dest->u.c = src->u.c;
651 dest->u.ss = src->u.ss;
652 dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
653 dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
657 dest->next = gfc_copy_ref (src->next);
663 /* Detect whether an expression has any vector index array references. */
666 gfc_has_vector_index (gfc_expr *e)
670 for (ref = e->ref; ref; ref = ref->next)
671 if (ref->type == REF_ARRAY)
672 for (i = 0; i < ref->u.ar.dimen; i++)
673 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
679 /* Copy a shape array. */
682 gfc_copy_shape (mpz_t *shape, int rank)
690 new_shape = gfc_get_shape (rank);
692 for (n = 0; n < rank; n++)
693 mpz_init_set (new_shape[n], shape[n]);
699 /* Copy a shape array excluding dimension N, where N is an integer
700 constant expression. Dimensions are numbered in fortran style --
703 So, if the original shape array contains R elements
704 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
705 the result contains R-1 elements:
706 { s1 ... sN-1 sN+1 ... sR-1}
708 If anything goes wrong -- N is not a constant, its value is out
709 of range -- or anything else, just returns NULL. */
712 gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
714 mpz_t *new_shape, *s;
720 || dim->expr_type != EXPR_CONSTANT
721 || dim->ts.type != BT_INTEGER)
724 n = mpz_get_si (dim->value.integer);
725 n--; /* Convert to zero based index. */
726 if (n < 0 || n >= rank)
729 s = new_shape = gfc_get_shape (rank - 1);
731 for (i = 0; i < rank; i++)
735 mpz_init_set (*s, shape[i]);
743 /* Return the maximum kind of two expressions. In general, higher
744 kind numbers mean more precision for numeric types. */
747 gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
749 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
753 /* Returns nonzero if the type is numeric, zero otherwise. */
756 numeric_type (bt type)
758 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
762 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
765 gfc_numeric_ts (gfc_typespec *ts)
767 return numeric_type (ts->type);
771 /* Return an expression node with an optional argument list attached.
772 A variable number of gfc_expr pointers are strung together in an
773 argument list with a NULL pointer terminating the list. */
776 gfc_build_conversion (gfc_expr *e)
781 p->expr_type = EXPR_FUNCTION;
783 p->value.function.actual = NULL;
785 p->value.function.actual = gfc_get_actual_arglist ();
786 p->value.function.actual->expr = e;
792 /* Given an expression node with some sort of numeric binary
793 expression, insert type conversions required to make the operands
794 have the same type. Conversion warnings are disabled if wconversion
797 The exception is that the operands of an exponential don't have to
798 have the same type. If possible, the base is promoted to the type
799 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
800 1.0**2 stays as it is. */
803 gfc_type_convert_binary (gfc_expr *e, int wconversion)
807 op1 = e->value.op.op1;
808 op2 = e->value.op.op2;
810 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
812 gfc_clear_ts (&e->ts);
816 /* Kind conversions of same type. */
817 if (op1->ts.type == op2->ts.type)
819 if (op1->ts.kind == op2->ts.kind)
821 /* No type conversions. */
826 if (op1->ts.kind > op2->ts.kind)
827 gfc_convert_type_warn (op2, &op1->ts, 2, wconversion);
829 gfc_convert_type_warn (op1, &op2->ts, 2, wconversion);
835 /* Integer combined with real or complex. */
836 if (op2->ts.type == BT_INTEGER)
840 /* Special case for ** operator. */
841 if (e->value.op.op == INTRINSIC_POWER)
844 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
848 if (op1->ts.type == BT_INTEGER)
851 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
855 /* Real combined with complex. */
856 e->ts.type = BT_COMPLEX;
857 if (op1->ts.kind > op2->ts.kind)
858 e->ts.kind = op1->ts.kind;
860 e->ts.kind = op2->ts.kind;
861 if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
862 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
863 if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
864 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
871 /* Function to determine if an expression is constant or not. This
872 function expects that the expression has already been simplified. */
875 gfc_is_constant_expr (gfc_expr *e)
878 gfc_actual_arglist *arg;
884 switch (e->expr_type)
887 return (gfc_is_constant_expr (e->value.op.op1)
888 && (e->value.op.op2 == NULL
889 || gfc_is_constant_expr (e->value.op.op2)));
897 /* Call to intrinsic with at least one argument. */
898 if (e->value.function.isym && e->value.function.actual)
900 for (arg = e->value.function.actual; arg; arg = arg->next)
901 if (!gfc_is_constant_expr (arg->expr))
905 /* Make sure we have a symbol. */
906 gcc_assert (e->symtree);
908 sym = e->symtree->n.sym;
910 /* Specification functions are constant. */
911 /* F95, 7.1.6.2; F2003, 7.1.7 */
913 && sym->attr.function
915 && !sym->attr.intrinsic
916 && !sym->attr.recursive
917 && sym->attr.proc != PROC_INTERNAL
918 && sym->attr.proc != PROC_ST_FUNCTION
919 && sym->attr.proc != PROC_UNKNOWN
920 && sym->formal == NULL)
923 if (e->value.function.isym
924 && (e->value.function.isym->elemental
925 || e->value.function.isym->pure
926 || e->value.function.isym->inquiry
927 || e->value.function.isym->transformational))
937 return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
938 && gfc_is_constant_expr (e->ref->u.ss.end));
941 for (c = gfc_constructor_first (e->value.constructor);
942 c; c = gfc_constructor_next (c))
943 if (!gfc_is_constant_expr (c->expr))
949 return gfc_constant_ac (e);
952 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
958 /* Is true if an array reference is followed by a component or substring
961 is_subref_array (gfc_expr * e)
966 if (e->expr_type != EXPR_VARIABLE)
969 if (e->symtree->n.sym->attr.subref_array_pointer)
973 for (ref = e->ref; ref; ref = ref->next)
975 if (ref->type == REF_ARRAY
976 && ref->u.ar.type != AR_ELEMENT)
980 && ref->type != REF_ARRAY)
987 /* Try to collapse intrinsic expressions. */
990 simplify_intrinsic_op (gfc_expr *p, int type)
993 gfc_expr *op1, *op2, *result;
995 if (p->value.op.op == INTRINSIC_USER)
998 op1 = p->value.op.op1;
999 op2 = p->value.op.op2;
1000 op = p->value.op.op;
1002 if (gfc_simplify_expr (op1, type) == FAILURE)
1004 if (gfc_simplify_expr (op2, type) == FAILURE)
1007 if (!gfc_is_constant_expr (op1)
1008 || (op2 != NULL && !gfc_is_constant_expr (op2)))
1012 p->value.op.op1 = NULL;
1013 p->value.op.op2 = NULL;
1017 case INTRINSIC_PARENTHESES:
1018 result = gfc_parentheses (op1);
1021 case INTRINSIC_UPLUS:
1022 result = gfc_uplus (op1);
1025 case INTRINSIC_UMINUS:
1026 result = gfc_uminus (op1);
1029 case INTRINSIC_PLUS:
1030 result = gfc_add (op1, op2);
1033 case INTRINSIC_MINUS:
1034 result = gfc_subtract (op1, op2);
1037 case INTRINSIC_TIMES:
1038 result = gfc_multiply (op1, op2);
1041 case INTRINSIC_DIVIDE:
1042 result = gfc_divide (op1, op2);
1045 case INTRINSIC_POWER:
1046 result = gfc_power (op1, op2);
1049 case INTRINSIC_CONCAT:
1050 result = gfc_concat (op1, op2);
1054 case INTRINSIC_EQ_OS:
1055 result = gfc_eq (op1, op2, op);
1059 case INTRINSIC_NE_OS:
1060 result = gfc_ne (op1, op2, op);
1064 case INTRINSIC_GT_OS:
1065 result = gfc_gt (op1, op2, op);
1069 case INTRINSIC_GE_OS:
1070 result = gfc_ge (op1, op2, op);
1074 case INTRINSIC_LT_OS:
1075 result = gfc_lt (op1, op2, op);
1079 case INTRINSIC_LE_OS:
1080 result = gfc_le (op1, op2, op);
1084 result = gfc_not (op1);
1088 result = gfc_and (op1, op2);
1092 result = gfc_or (op1, op2);
1096 result = gfc_eqv (op1, op2);
1099 case INTRINSIC_NEQV:
1100 result = gfc_neqv (op1, op2);
1104 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1109 gfc_free_expr (op1);
1110 gfc_free_expr (op2);
1114 result->rank = p->rank;
1115 result->where = p->where;
1116 gfc_replace_expr (p, result);
1122 /* Subroutine to simplify constructor expressions. Mutually recursive
1123 with gfc_simplify_expr(). */
1126 simplify_constructor (gfc_constructor_base base, int type)
1131 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1134 && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
1135 || gfc_simplify_expr (c->iterator->end, type) == FAILURE
1136 || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
1141 /* Try and simplify a copy. Replace the original if successful
1142 but keep going through the constructor at all costs. Not
1143 doing so can make a dog's dinner of complicated things. */
1144 p = gfc_copy_expr (c->expr);
1146 if (gfc_simplify_expr (p, type) == FAILURE)
1152 gfc_replace_expr (c->expr, p);
1160 /* Pull a single array element out of an array constructor. */
1163 find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
1164 gfc_constructor **rval)
1166 unsigned long nelemen;
1172 gfc_constructor *cons;
1179 mpz_init_set_ui (offset, 0);
1182 mpz_init_set_ui (span, 1);
1183 for (i = 0; i < ar->dimen; i++)
1185 if (gfc_reduce_init_expr (ar->as->lower[i]) == FAILURE
1186 || gfc_reduce_init_expr (ar->as->upper[i]) == FAILURE)
1193 e = gfc_copy_expr (ar->start[i]);
1194 if (e->expr_type != EXPR_CONSTANT)
1200 gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
1201 && ar->as->lower[i]->expr_type == EXPR_CONSTANT);
1203 /* Check the bounds. */
1204 if ((ar->as->upper[i]
1205 && mpz_cmp (e->value.integer,
1206 ar->as->upper[i]->value.integer) > 0)
1207 || (mpz_cmp (e->value.integer,
1208 ar->as->lower[i]->value.integer) < 0))
1210 gfc_error ("Index in dimension %d is out of bounds "
1211 "at %L", i + 1, &ar->c_where[i]);
1217 mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1218 mpz_mul (delta, delta, span);
1219 mpz_add (offset, offset, delta);
1221 mpz_set_ui (tmp, 1);
1222 mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1223 mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1224 mpz_mul (span, span, tmp);
1227 for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset);
1228 cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
1249 /* Find a component of a structure constructor. */
1251 static gfc_constructor *
1252 find_component_ref (gfc_constructor_base base, gfc_ref *ref)
1254 gfc_component *comp;
1255 gfc_component *pick;
1256 gfc_constructor *c = gfc_constructor_first (base);
1258 comp = ref->u.c.sym->components;
1259 pick = ref->u.c.component;
1260 while (comp != pick)
1263 c = gfc_constructor_next (c);
1270 /* Replace an expression with the contents of a constructor, removing
1271 the subobject reference in the process. */
1274 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1284 e = gfc_copy_expr (p);
1285 e->ref = p->ref->next;
1286 p->ref->next = NULL;
1287 gfc_replace_expr (p, e);
1291 /* Pull an array section out of an array constructor. */
1294 find_array_section (gfc_expr *expr, gfc_ref *ref)
1301 long unsigned one = 1;
1303 mpz_t start[GFC_MAX_DIMENSIONS];
1304 mpz_t end[GFC_MAX_DIMENSIONS];
1305 mpz_t stride[GFC_MAX_DIMENSIONS];
1306 mpz_t delta[GFC_MAX_DIMENSIONS];
1307 mpz_t ctr[GFC_MAX_DIMENSIONS];
1312 gfc_constructor_base base;
1313 gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS];
1323 base = expr->value.constructor;
1324 expr->value.constructor = NULL;
1326 rank = ref->u.ar.as->rank;
1328 if (expr->shape == NULL)
1329 expr->shape = gfc_get_shape (rank);
1331 mpz_init_set_ui (delta_mpz, one);
1332 mpz_init_set_ui (nelts, one);
1335 /* Do the initialization now, so that we can cleanup without
1336 keeping track of where we were. */
1337 for (d = 0; d < rank; d++)
1339 mpz_init (delta[d]);
1340 mpz_init (start[d]);
1343 mpz_init (stride[d]);
1347 /* Build the counters to clock through the array reference. */
1349 for (d = 0; d < rank; d++)
1351 /* Make this stretch of code easier on the eye! */
1352 begin = ref->u.ar.start[d];
1353 finish = ref->u.ar.end[d];
1354 step = ref->u.ar.stride[d];
1355 lower = ref->u.ar.as->lower[d];
1356 upper = ref->u.ar.as->upper[d];
1358 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1360 gfc_constructor *ci;
1363 if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1369 gcc_assert (begin->rank == 1);
1370 /* Zero-sized arrays have no shape and no elements, stop early. */
1373 mpz_init_set_ui (nelts, 0);
1377 vecsub[d] = gfc_constructor_first (begin->value.constructor);
1378 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1379 mpz_mul (nelts, nelts, begin->shape[0]);
1380 mpz_set (expr->shape[shape_i++], begin->shape[0]);
1383 for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci))
1385 if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
1386 || mpz_cmp (ci->expr->value.integer,
1387 lower->value.integer) < 0)
1389 gfc_error ("index in dimension %d is out of bounds "
1390 "at %L", d + 1, &ref->u.ar.c_where[d]);
1398 if ((begin && begin->expr_type != EXPR_CONSTANT)
1399 || (finish && finish->expr_type != EXPR_CONSTANT)
1400 || (step && step->expr_type != EXPR_CONSTANT))
1406 /* Obtain the stride. */
1408 mpz_set (stride[d], step->value.integer);
1410 mpz_set_ui (stride[d], one);
1412 if (mpz_cmp_ui (stride[d], 0) == 0)
1413 mpz_set_ui (stride[d], one);
1415 /* Obtain the start value for the index. */
1417 mpz_set (start[d], begin->value.integer);
1419 mpz_set (start[d], lower->value.integer);
1421 mpz_set (ctr[d], start[d]);
1423 /* Obtain the end value for the index. */
1425 mpz_set (end[d], finish->value.integer);
1427 mpz_set (end[d], upper->value.integer);
1429 /* Separate 'if' because elements sometimes arrive with
1431 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1432 mpz_set (end [d], begin->value.integer);
1434 /* Check the bounds. */
1435 if (mpz_cmp (ctr[d], upper->value.integer) > 0
1436 || mpz_cmp (end[d], upper->value.integer) > 0
1437 || mpz_cmp (ctr[d], lower->value.integer) < 0
1438 || mpz_cmp (end[d], lower->value.integer) < 0)
1440 gfc_error ("index in dimension %d is out of bounds "
1441 "at %L", d + 1, &ref->u.ar.c_where[d]);
1446 /* Calculate the number of elements and the shape. */
1447 mpz_set (tmp_mpz, stride[d]);
1448 mpz_add (tmp_mpz, end[d], tmp_mpz);
1449 mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1450 mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1451 mpz_mul (nelts, nelts, tmp_mpz);
1453 /* An element reference reduces the rank of the expression; don't
1454 add anything to the shape array. */
1455 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1456 mpz_set (expr->shape[shape_i++], tmp_mpz);
1459 /* Calculate the 'stride' (=delta) for conversion of the
1460 counter values into the index along the constructor. */
1461 mpz_set (delta[d], delta_mpz);
1462 mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1463 mpz_add_ui (tmp_mpz, tmp_mpz, one);
1464 mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1468 cons = gfc_constructor_first (base);
1470 /* Now clock through the array reference, calculating the index in
1471 the source constructor and transferring the elements to the new
1473 for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1475 if (ref->u.ar.offset)
1476 mpz_set (ptr, ref->u.ar.offset->value.integer);
1478 mpz_init_set_ui (ptr, 0);
1481 for (d = 0; d < rank; d++)
1483 mpz_set (tmp_mpz, ctr[d]);
1484 mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1485 mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1486 mpz_add (ptr, ptr, tmp_mpz);
1488 if (!incr_ctr) continue;
1490 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1492 gcc_assert(vecsub[d]);
1494 if (!gfc_constructor_next (vecsub[d]))
1495 vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor);
1498 vecsub[d] = gfc_constructor_next (vecsub[d]);
1501 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1505 mpz_add (ctr[d], ctr[d], stride[d]);
1507 if (mpz_cmp_ui (stride[d], 0) > 0
1508 ? mpz_cmp (ctr[d], end[d]) > 0
1509 : mpz_cmp (ctr[d], end[d]) < 0)
1510 mpz_set (ctr[d], start[d]);
1516 limit = mpz_get_ui (ptr);
1517 if (limit >= gfc_option.flag_max_array_constructor)
1519 gfc_error ("The number of elements in the array constructor "
1520 "at %L requires an increase of the allowed %d "
1521 "upper limit. See -fmax-array-constructor "
1522 "option", &expr->where,
1523 gfc_option.flag_max_array_constructor);
1527 cons = gfc_constructor_lookup (base, limit);
1529 gfc_constructor_append_expr (&expr->value.constructor,
1530 gfc_copy_expr (cons->expr), NULL);
1537 mpz_clear (delta_mpz);
1538 mpz_clear (tmp_mpz);
1540 for (d = 0; d < rank; d++)
1542 mpz_clear (delta[d]);
1543 mpz_clear (start[d]);
1546 mpz_clear (stride[d]);
1548 gfc_constructor_free (base);
1552 /* Pull a substring out of an expression. */
1555 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1562 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1563 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1566 *newp = gfc_copy_expr (p);
1567 gfc_free ((*newp)->value.character.string);
1569 end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1570 start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1571 length = end - start + 1;
1573 chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1574 (*newp)->value.character.length = length;
1575 memcpy (chr, &p->value.character.string[start - 1],
1576 length * sizeof (gfc_char_t));
1583 /* Simplify a subobject reference of a constructor. This occurs when
1584 parameter variable values are substituted. */
1587 simplify_const_ref (gfc_expr *p)
1589 gfc_constructor *cons, *c;
1595 switch (p->ref->type)
1598 switch (p->ref->u.ar.type)
1601 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1602 will generate this. */
1603 if (p->expr_type != EXPR_ARRAY)
1605 remove_subobject_ref (p, NULL);
1608 if (find_array_element (p->value.constructor, &p->ref->u.ar,
1615 remove_subobject_ref (p, cons);
1619 if (find_array_section (p, p->ref) == FAILURE)
1621 p->ref->u.ar.type = AR_FULL;
1626 if (p->ref->next != NULL
1627 && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1629 for (c = gfc_constructor_first (p->value.constructor);
1630 c; c = gfc_constructor_next (c))
1632 c->expr->ref = gfc_copy_ref (p->ref->next);
1633 if (simplify_const_ref (c->expr) == FAILURE)
1637 if (p->ts.type == BT_DERIVED
1639 && (c = gfc_constructor_first (p->value.constructor)))
1641 /* There may have been component references. */
1642 p->ts = c->expr->ts;
1646 for (; last_ref->next; last_ref = last_ref->next) {};
1648 if (p->ts.type == BT_CHARACTER
1649 && last_ref->type == REF_SUBSTRING)
1651 /* If this is a CHARACTER array and we possibly took
1652 a substring out of it, update the type-spec's
1653 character length according to the first element
1654 (as all should have the same length). */
1656 if ((c = gfc_constructor_first (p->value.constructor)))
1658 const gfc_expr* first = c->expr;
1659 gcc_assert (first->expr_type == EXPR_CONSTANT);
1660 gcc_assert (first->ts.type == BT_CHARACTER);
1661 string_len = first->value.character.length;
1667 p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
1670 gfc_free_expr (p->ts.u.cl->length);
1673 = gfc_get_int_expr (gfc_default_integer_kind,
1677 gfc_free_ref_list (p->ref);
1688 cons = find_component_ref (p->value.constructor, p->ref);
1689 remove_subobject_ref (p, cons);
1693 if (find_substring_ref (p, &newp) == FAILURE)
1696 gfc_replace_expr (p, newp);
1697 gfc_free_ref_list (p->ref);
1707 /* Simplify a chain of references. */
1710 simplify_ref_chain (gfc_ref *ref, int type)
1714 for (; ref; ref = ref->next)
1719 for (n = 0; n < ref->u.ar.dimen; n++)
1721 if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1723 if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1725 if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1731 if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1733 if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1745 /* Try to substitute the value of a parameter variable. */
1748 simplify_parameter_variable (gfc_expr *p, int type)
1753 e = gfc_copy_expr (p->symtree->n.sym->value);
1759 /* Do not copy subobject refs for constant. */
1760 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1761 e->ref = gfc_copy_ref (p->ref);
1762 t = gfc_simplify_expr (e, type);
1764 /* Only use the simplification if it eliminated all subobject references. */
1765 if (t == SUCCESS && !e->ref)
1766 gfc_replace_expr (p, e);
1773 /* Given an expression, simplify it by collapsing constant
1774 expressions. Most simplification takes place when the expression
1775 tree is being constructed. If an intrinsic function is simplified
1776 at some point, we get called again to collapse the result against
1779 We work by recursively simplifying expression nodes, simplifying
1780 intrinsic functions where possible, which can lead to further
1781 constant collapsing. If an operator has constant operand(s), we
1782 rip the expression apart, and rebuild it, hoping that it becomes
1785 The expression type is defined for:
1786 0 Basic expression parsing
1787 1 Simplifying array constructors -- will substitute
1789 Returns FAILURE on error, SUCCESS otherwise.
1790 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1793 gfc_simplify_expr (gfc_expr *p, int type)
1795 gfc_actual_arglist *ap;
1800 switch (p->expr_type)
1807 for (ap = p->value.function.actual; ap; ap = ap->next)
1808 if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1811 if (p->value.function.isym != NULL
1812 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1817 case EXPR_SUBSTRING:
1818 if (simplify_ref_chain (p->ref, type) == FAILURE)
1821 if (gfc_is_constant_expr (p))
1827 if (p->ref && p->ref->u.ss.start)
1829 gfc_extract_int (p->ref->u.ss.start, &start);
1830 start--; /* Convert from one-based to zero-based. */
1833 end = p->value.character.length;
1834 if (p->ref && p->ref->u.ss.end)
1835 gfc_extract_int (p->ref->u.ss.end, &end);
1837 s = gfc_get_wide_string (end - start + 2);
1838 memcpy (s, p->value.character.string + start,
1839 (end - start) * sizeof (gfc_char_t));
1840 s[end - start + 1] = '\0'; /* TODO: C-style string. */
1841 gfc_free (p->value.character.string);
1842 p->value.character.string = s;
1843 p->value.character.length = end - start;
1844 p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1845 p->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
1847 p->value.character.length);
1848 gfc_free_ref_list (p->ref);
1850 p->expr_type = EXPR_CONSTANT;
1855 if (simplify_intrinsic_op (p, type) == FAILURE)
1860 /* Only substitute array parameter variables if we are in an
1861 initialization expression, or we want a subsection. */
1862 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1863 && (gfc_init_expr_flag || p->ref
1864 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1866 if (simplify_parameter_variable (p, type) == FAILURE)
1873 gfc_simplify_iterator_var (p);
1876 /* Simplify subcomponent references. */
1877 if (simplify_ref_chain (p->ref, type) == FAILURE)
1882 case EXPR_STRUCTURE:
1884 if (simplify_ref_chain (p->ref, type) == FAILURE)
1887 if (simplify_constructor (p->value.constructor, type) == FAILURE)
1890 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1891 && p->ref->u.ar.type == AR_FULL)
1892 gfc_expand_constructor (p, false);
1894 if (simplify_const_ref (p) == FAILURE)
1909 /* Returns the type of an expression with the exception that iterator
1910 variables are automatically integers no matter what else they may
1916 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1923 /* Check an intrinsic arithmetic operation to see if it is consistent
1924 with some type of expression. */
1926 static gfc_try check_init_expr (gfc_expr *);
1929 /* Scalarize an expression for an elemental intrinsic call. */
1932 scalarize_intrinsic_call (gfc_expr *e)
1934 gfc_actual_arglist *a, *b;
1935 gfc_constructor_base ctor;
1936 gfc_constructor *args[5];
1937 gfc_constructor *ci, *new_ctor;
1938 gfc_expr *expr, *old;
1939 int n, i, rank[5], array_arg;
1941 /* Find which, if any, arguments are arrays. Assume that the old
1942 expression carries the type information and that the first arg
1943 that is an array expression carries all the shape information.*/
1945 a = e->value.function.actual;
1946 for (; a; a = a->next)
1949 if (a->expr->expr_type != EXPR_ARRAY)
1952 expr = gfc_copy_expr (a->expr);
1959 old = gfc_copy_expr (e);
1961 gfc_constructor_free (expr->value.constructor);
1962 expr->value.constructor = NULL;
1964 expr->where = old->where;
1965 expr->expr_type = EXPR_ARRAY;
1967 /* Copy the array argument constructors into an array, with nulls
1970 a = old->value.function.actual;
1971 for (; a; a = a->next)
1973 /* Check that this is OK for an initialization expression. */
1974 if (a->expr && check_init_expr (a->expr) == FAILURE)
1978 if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
1980 rank[n] = a->expr->rank;
1981 ctor = a->expr->symtree->n.sym->value->value.constructor;
1982 args[n] = gfc_constructor_first (ctor);
1984 else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
1987 rank[n] = a->expr->rank;
1990 ctor = gfc_constructor_copy (a->expr->value.constructor);
1991 args[n] = gfc_constructor_first (ctor);
2000 /* Using the array argument as the master, step through the array
2001 calling the function for each element and advancing the array
2002 constructors together. */
2003 for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
2005 new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
2006 gfc_copy_expr (old), NULL);
2008 gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
2010 b = old->value.function.actual;
2011 for (i = 0; i < n; i++)
2014 new_ctor->expr->value.function.actual
2015 = a = gfc_get_actual_arglist ();
2018 a->next = gfc_get_actual_arglist ();
2023 a->expr = gfc_copy_expr (args[i]->expr);
2025 a->expr = gfc_copy_expr (b->expr);
2030 /* Simplify the function calls. If the simplification fails, the
2031 error will be flagged up down-stream or the library will deal
2033 gfc_simplify_expr (new_ctor->expr, 0);
2035 for (i = 0; i < n; i++)
2037 args[i] = gfc_constructor_next (args[i]);
2039 for (i = 1; i < n; i++)
2040 if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
2041 || (args[i] == NULL && args[array_arg - 1] != NULL)))
2047 gfc_free_expr (old);
2051 gfc_error_now ("elemental function arguments at %C are not compliant");
2054 gfc_free_expr (expr);
2055 gfc_free_expr (old);
2061 check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
2063 gfc_expr *op1 = e->value.op.op1;
2064 gfc_expr *op2 = e->value.op.op2;
2066 if ((*check_function) (op1) == FAILURE)
2069 switch (e->value.op.op)
2071 case INTRINSIC_UPLUS:
2072 case INTRINSIC_UMINUS:
2073 if (!numeric_type (et0 (op1)))
2078 case INTRINSIC_EQ_OS:
2080 case INTRINSIC_NE_OS:
2082 case INTRINSIC_GT_OS:
2084 case INTRINSIC_GE_OS:
2086 case INTRINSIC_LT_OS:
2088 case INTRINSIC_LE_OS:
2089 if ((*check_function) (op2) == FAILURE)
2092 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
2093 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
2095 gfc_error ("Numeric or CHARACTER operands are required in "
2096 "expression at %L", &e->where);
2101 case INTRINSIC_PLUS:
2102 case INTRINSIC_MINUS:
2103 case INTRINSIC_TIMES:
2104 case INTRINSIC_DIVIDE:
2105 case INTRINSIC_POWER:
2106 if ((*check_function) (op2) == FAILURE)
2109 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
2114 case INTRINSIC_CONCAT:
2115 if ((*check_function) (op2) == FAILURE)
2118 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
2120 gfc_error ("Concatenation operator in expression at %L "
2121 "must have two CHARACTER operands", &op1->where);
2125 if (op1->ts.kind != op2->ts.kind)
2127 gfc_error ("Concat operator at %L must concatenate strings of the "
2128 "same kind", &e->where);
2135 if (et0 (op1) != BT_LOGICAL)
2137 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2138 "operand", &op1->where);
2147 case INTRINSIC_NEQV:
2148 if ((*check_function) (op2) == FAILURE)
2151 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
2153 gfc_error ("LOGICAL operands are required in expression at %L",
2160 case INTRINSIC_PARENTHESES:
2164 gfc_error ("Only intrinsic operators can be used in expression at %L",
2172 gfc_error ("Numeric operands are required in expression at %L", &e->where);
2177 /* F2003, 7.1.7 (3): In init expression, allocatable components
2178 must not be data-initialized. */
2180 check_alloc_comp_init (gfc_expr *e)
2182 gfc_component *comp;
2183 gfc_constructor *ctor;
2185 gcc_assert (e->expr_type == EXPR_STRUCTURE);
2186 gcc_assert (e->ts.type == BT_DERIVED);
2188 for (comp = e->ts.u.derived->components,
2189 ctor = gfc_constructor_first (e->value.constructor);
2190 comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
2192 if (comp->attr.allocatable
2193 && ctor->expr->expr_type != EXPR_NULL)
2195 gfc_error("Invalid initialization expression for ALLOCATABLE "
2196 "component '%s' in structure constructor at %L",
2197 comp->name, &ctor->expr->where);
2206 check_init_expr_arguments (gfc_expr *e)
2208 gfc_actual_arglist *ap;
2210 for (ap = e->value.function.actual; ap; ap = ap->next)
2211 if (check_init_expr (ap->expr) == FAILURE)
2217 static gfc_try check_restricted (gfc_expr *);
2219 /* F95, 7.1.6.1, Initialization expressions, (7)
2220 F2003, 7.1.7 Initialization expression, (8) */
2223 check_inquiry (gfc_expr *e, int not_restricted)
2226 const char *const *functions;
2228 static const char *const inquiry_func_f95[] = {
2229 "lbound", "shape", "size", "ubound",
2230 "bit_size", "len", "kind",
2231 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2232 "precision", "radix", "range", "tiny",
2236 static const char *const inquiry_func_f2003[] = {
2237 "lbound", "shape", "size", "ubound",
2238 "bit_size", "len", "kind",
2239 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2240 "precision", "radix", "range", "tiny",
2245 gfc_actual_arglist *ap;
2247 if (!e->value.function.isym
2248 || !e->value.function.isym->inquiry)
2251 /* An undeclared parameter will get us here (PR25018). */
2252 if (e->symtree == NULL)
2255 name = e->symtree->n.sym->name;
2257 functions = (gfc_option.warn_std & GFC_STD_F2003)
2258 ? inquiry_func_f2003 : inquiry_func_f95;
2260 for (i = 0; functions[i]; i++)
2261 if (strcmp (functions[i], name) == 0)
2264 if (functions[i] == NULL)
2267 /* At this point we have an inquiry function with a variable argument. The
2268 type of the variable might be undefined, but we need it now, because the
2269 arguments of these functions are not allowed to be undefined. */
2271 for (ap = e->value.function.actual; ap; ap = ap->next)
2276 if (ap->expr->ts.type == BT_UNKNOWN)
2278 if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2279 && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)
2283 ap->expr->ts = ap->expr->symtree->n.sym->ts;
2286 /* Assumed character length will not reduce to a constant expression
2287 with LEN, as required by the standard. */
2288 if (i == 5 && not_restricted
2289 && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2290 && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL
2291 || ap->expr->symtree->n.sym->ts.deferred))
2293 gfc_error ("Assumed or deferred character length variable '%s' "
2294 " in constant expression at %L",
2295 ap->expr->symtree->n.sym->name,
2299 else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
2302 if (not_restricted == 0
2303 && ap->expr->expr_type != EXPR_VARIABLE
2304 && check_restricted (ap->expr) == FAILURE)
2307 if (not_restricted == 0
2308 && ap->expr->expr_type == EXPR_VARIABLE
2309 && ap->expr->symtree->n.sym->attr.dummy
2310 && ap->expr->symtree->n.sym->attr.optional)
2318 /* F95, 7.1.6.1, Initialization expressions, (5)
2319 F2003, 7.1.7 Initialization expression, (5) */
2322 check_transformational (gfc_expr *e)
2324 static const char * const trans_func_f95[] = {
2325 "repeat", "reshape", "selected_int_kind",
2326 "selected_real_kind", "transfer", "trim", NULL
2329 static const char * const trans_func_f2003[] = {
2330 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2331 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2332 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2333 "trim", "unpack", NULL
2338 const char *const *functions;
2340 if (!e->value.function.isym
2341 || !e->value.function.isym->transformational)
2344 name = e->symtree->n.sym->name;
2346 functions = (gfc_option.allow_std & GFC_STD_F2003)
2347 ? trans_func_f2003 : trans_func_f95;
2349 /* NULL() is dealt with below. */
2350 if (strcmp ("null", name) == 0)
2353 for (i = 0; functions[i]; i++)
2354 if (strcmp (functions[i], name) == 0)
2357 if (functions[i] == NULL)
2359 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2360 "in an initialization expression", name, &e->where);
2364 return check_init_expr_arguments (e);
2368 /* F95, 7.1.6.1, Initialization expressions, (6)
2369 F2003, 7.1.7 Initialization expression, (6) */
2372 check_null (gfc_expr *e)
2374 if (strcmp ("null", e->symtree->n.sym->name) != 0)
2377 return check_init_expr_arguments (e);
2382 check_elemental (gfc_expr *e)
2384 if (!e->value.function.isym
2385 || !e->value.function.isym->elemental)
2388 if (e->ts.type != BT_INTEGER
2389 && e->ts.type != BT_CHARACTER
2390 && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2391 "nonstandard initialization expression at %L",
2392 &e->where) == FAILURE)
2395 return check_init_expr_arguments (e);
2400 check_conversion (gfc_expr *e)
2402 if (!e->value.function.isym
2403 || !e->value.function.isym->conversion)
2406 return check_init_expr_arguments (e);
2410 /* Verify that an expression is an initialization expression. A side
2411 effect is that the expression tree is reduced to a single constant
2412 node if all goes well. This would normally happen when the
2413 expression is constructed but function references are assumed to be
2414 intrinsics in the context of initialization expressions. If
2415 FAILURE is returned an error message has been generated. */
2418 check_init_expr (gfc_expr *e)
2426 switch (e->expr_type)
2429 t = check_intrinsic_op (e, check_init_expr);
2431 t = gfc_simplify_expr (e, 0);
2439 gfc_intrinsic_sym* isym;
2442 sym = e->symtree->n.sym;
2443 if (!gfc_is_intrinsic (sym, 0, e->where)
2444 || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2446 gfc_error ("Function '%s' in initialization expression at %L "
2447 "must be an intrinsic function",
2448 e->symtree->n.sym->name, &e->where);
2452 if ((m = check_conversion (e)) == MATCH_NO
2453 && (m = check_inquiry (e, 1)) == MATCH_NO
2454 && (m = check_null (e)) == MATCH_NO
2455 && (m = check_transformational (e)) == MATCH_NO
2456 && (m = check_elemental (e)) == MATCH_NO)
2458 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2459 "in an initialization expression",
2460 e->symtree->n.sym->name, &e->where);
2464 /* Try to scalarize an elemental intrinsic function that has an
2466 isym = gfc_find_function (e->symtree->n.sym->name);
2467 if (isym && isym->elemental
2468 && (t = scalarize_intrinsic_call (e)) == SUCCESS)
2473 t = gfc_simplify_expr (e, 0);
2480 if (gfc_check_iter_variable (e) == SUCCESS)
2483 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2485 /* A PARAMETER shall not be used to define itself, i.e.
2486 REAL, PARAMETER :: x = transfer(0, x)
2488 if (!e->symtree->n.sym->value)
2490 gfc_error("PARAMETER '%s' is used at %L before its definition "
2491 "is complete", e->symtree->n.sym->name, &e->where);
2495 t = simplify_parameter_variable (e, 0);
2500 if (gfc_in_match_data ())
2505 if (e->symtree->n.sym->as)
2507 switch (e->symtree->n.sym->as->type)
2509 case AS_ASSUMED_SIZE:
2510 gfc_error ("Assumed size array '%s' at %L is not permitted "
2511 "in an initialization expression",
2512 e->symtree->n.sym->name, &e->where);
2515 case AS_ASSUMED_SHAPE:
2516 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2517 "in an initialization expression",
2518 e->symtree->n.sym->name, &e->where);
2522 gfc_error ("Deferred array '%s' at %L is not permitted "
2523 "in an initialization expression",
2524 e->symtree->n.sym->name, &e->where);
2528 gfc_error ("Array '%s' at %L is a variable, which does "
2529 "not reduce to a constant expression",
2530 e->symtree->n.sym->name, &e->where);
2538 gfc_error ("Parameter '%s' at %L has not been declared or is "
2539 "a variable, which does not reduce to a constant "
2540 "expression", e->symtree->n.sym->name, &e->where);
2549 case EXPR_SUBSTRING:
2550 t = check_init_expr (e->ref->u.ss.start);
2554 t = check_init_expr (e->ref->u.ss.end);
2556 t = gfc_simplify_expr (e, 0);
2560 case EXPR_STRUCTURE:
2561 t = e->ts.is_iso_c ? SUCCESS : FAILURE;
2565 t = check_alloc_comp_init (e);
2569 t = gfc_check_constructor (e, check_init_expr);
2576 t = gfc_check_constructor (e, check_init_expr);
2580 t = gfc_expand_constructor (e, true);
2584 t = gfc_check_constructor_type (e);
2588 gfc_internal_error ("check_init_expr(): Unknown expression type");
2594 /* Reduces a general expression to an initialization expression (a constant).
2595 This used to be part of gfc_match_init_expr.
2596 Note that this function doesn't free the given expression on FAILURE. */
2599 gfc_reduce_init_expr (gfc_expr *expr)
2603 gfc_init_expr_flag = true;
2604 t = gfc_resolve_expr (expr);
2606 t = check_init_expr (expr);
2607 gfc_init_expr_flag = false;
2612 if (expr->expr_type == EXPR_ARRAY)
2614 if (gfc_check_constructor_type (expr) == FAILURE)
2616 if (gfc_expand_constructor (expr, true) == FAILURE)
2624 /* Match an initialization expression. We work by first matching an
2625 expression, then reducing it to a constant. */
2628 gfc_match_init_expr (gfc_expr **result)
2636 gfc_init_expr_flag = true;
2638 m = gfc_match_expr (&expr);
2641 gfc_init_expr_flag = false;
2645 t = gfc_reduce_init_expr (expr);
2648 gfc_free_expr (expr);
2649 gfc_init_expr_flag = false;
2654 gfc_init_expr_flag = false;
2660 /* Given an actual argument list, test to see that each argument is a
2661 restricted expression and optionally if the expression type is
2662 integer or character. */
2665 restricted_args (gfc_actual_arglist *a)
2667 for (; a; a = a->next)
2669 if (check_restricted (a->expr) == FAILURE)
2677 /************* Restricted/specification expressions *************/
2680 /* Make sure a non-intrinsic function is a specification function. */
2683 external_spec_function (gfc_expr *e)
2687 f = e->value.function.esym;
2689 if (f->attr.proc == PROC_ST_FUNCTION)
2691 gfc_error ("Specification function '%s' at %L cannot be a statement "
2692 "function", f->name, &e->where);
2696 if (f->attr.proc == PROC_INTERNAL)
2698 gfc_error ("Specification function '%s' at %L cannot be an internal "
2699 "function", f->name, &e->where);
2703 if (!f->attr.pure && !f->attr.elemental)
2705 gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2710 if (f->attr.recursive)
2712 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2713 f->name, &e->where);
2717 return restricted_args (e->value.function.actual);
2721 /* Check to see that a function reference to an intrinsic is a
2722 restricted expression. */
2725 restricted_intrinsic (gfc_expr *e)
2727 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2728 if (check_inquiry (e, 0) == MATCH_YES)
2731 return restricted_args (e->value.function.actual);
2735 /* Check the expressions of an actual arglist. Used by check_restricted. */
2738 check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
2740 for (; arg; arg = arg->next)
2741 if (checker (arg->expr) == FAILURE)
2748 /* Check the subscription expressions of a reference chain with a checking
2749 function; used by check_restricted. */
2752 check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
2762 for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2764 if (checker (ref->u.ar.start[dim]) == FAILURE)
2766 if (checker (ref->u.ar.end[dim]) == FAILURE)
2768 if (checker (ref->u.ar.stride[dim]) == FAILURE)
2774 /* Nothing needed, just proceed to next reference. */
2778 if (checker (ref->u.ss.start) == FAILURE)
2780 if (checker (ref->u.ss.end) == FAILURE)
2789 return check_references (ref->next, checker);
2793 /* Verify that an expression is a restricted expression. Like its
2794 cousin check_init_expr(), an error message is generated if we
2798 check_restricted (gfc_expr *e)
2806 switch (e->expr_type)
2809 t = check_intrinsic_op (e, check_restricted);
2811 t = gfc_simplify_expr (e, 0);
2816 if (e->value.function.esym)
2818 t = check_arglist (e->value.function.actual, &check_restricted);
2820 t = external_spec_function (e);
2824 if (e->value.function.isym && e->value.function.isym->inquiry)
2827 t = check_arglist (e->value.function.actual, &check_restricted);
2830 t = restricted_intrinsic (e);
2835 sym = e->symtree->n.sym;
2838 /* If a dummy argument appears in a context that is valid for a
2839 restricted expression in an elemental procedure, it will have
2840 already been simplified away once we get here. Therefore we
2841 don't need to jump through hoops to distinguish valid from
2843 if (sym->attr.dummy && sym->ns == gfc_current_ns
2844 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2846 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2847 sym->name, &e->where);
2851 if (sym->attr.optional)
2853 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2854 sym->name, &e->where);
2858 if (sym->attr.intent == INTENT_OUT)
2860 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2861 sym->name, &e->where);
2865 /* Check reference chain if any. */
2866 if (check_references (e->ref, &check_restricted) == FAILURE)
2869 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2870 processed in resolve.c(resolve_formal_arglist). This is done so
2871 that host associated dummy array indices are accepted (PR23446).
2872 This mechanism also does the same for the specification expressions
2873 of array-valued functions. */
2875 || sym->attr.in_common
2876 || sym->attr.use_assoc
2878 || sym->attr.implied_index
2879 || sym->attr.flavor == FL_PARAMETER
2880 || (sym->ns && sym->ns == gfc_current_ns->parent)
2881 || (sym->ns && gfc_current_ns->parent
2882 && sym->ns == gfc_current_ns->parent->parent)
2883 || (sym->ns->proc_name != NULL
2884 && sym->ns->proc_name->attr.flavor == FL_MODULE)
2885 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2891 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2892 sym->name, &e->where);
2893 /* Prevent a repetition of the error. */
2902 case EXPR_SUBSTRING:
2903 t = gfc_specification_expr (e->ref->u.ss.start);
2907 t = gfc_specification_expr (e->ref->u.ss.end);
2909 t = gfc_simplify_expr (e, 0);
2913 case EXPR_STRUCTURE:
2914 t = gfc_check_constructor (e, check_restricted);
2918 t = gfc_check_constructor (e, check_restricted);
2922 gfc_internal_error ("check_restricted(): Unknown expression type");
2929 /* Check to see that an expression is a specification expression. If
2930 we return FAILURE, an error has been generated. */
2933 gfc_specification_expr (gfc_expr *e)
2935 gfc_component *comp;
2940 if (e->ts.type != BT_INTEGER)
2942 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2943 &e->where, gfc_basic_typename (e->ts.type));
2947 if (e->expr_type == EXPR_FUNCTION
2948 && !e->value.function.isym
2949 && !e->value.function.esym
2950 && !gfc_pure (e->symtree->n.sym)
2951 && (!gfc_is_proc_ptr_comp (e, &comp)
2952 || !comp->attr.pure))
2954 gfc_error ("Function '%s' at %L must be PURE",
2955 e->symtree->n.sym->name, &e->where);
2956 /* Prevent repeat error messages. */
2957 e->symtree->n.sym->attr.pure = 1;
2963 gfc_error ("Expression at %L must be scalar", &e->where);
2967 if (gfc_simplify_expr (e, 0) == FAILURE)
2970 return check_restricted (e);
2974 /************** Expression conformance checks. *************/
2976 /* Given two expressions, make sure that the arrays are conformable. */
2979 gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
2981 int op1_flag, op2_flag, d;
2982 mpz_t op1_size, op2_size;
2988 if (op1->rank == 0 || op2->rank == 0)
2991 va_start (argp, optype_msgid);
2992 vsnprintf (buffer, 240, optype_msgid, argp);
2995 if (op1->rank != op2->rank)
2997 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
2998 op1->rank, op2->rank, &op1->where);
3004 for (d = 0; d < op1->rank; d++)
3006 op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
3007 op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
3009 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
3011 gfc_error ("Different shape for %s at %L on dimension %d "
3012 "(%d and %d)", _(buffer), &op1->where, d + 1,
3013 (int) mpz_get_si (op1_size),
3014 (int) mpz_get_si (op2_size));
3020 mpz_clear (op1_size);
3022 mpz_clear (op2_size);
3032 /* Given an assignable expression and an arbitrary expression, make
3033 sure that the assignment can take place. */
3036 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
3042 sym = lvalue->symtree->n.sym;
3044 /* See if this is the component or subcomponent of a pointer. */
3045 has_pointer = sym->attr.pointer;
3046 for (ref = lvalue->ref; ref; ref = ref->next)
3047 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
3053 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3054 variable local to a function subprogram. Its existence begins when
3055 execution of the function is initiated and ends when execution of the
3056 function is terminated...
3057 Therefore, the left hand side is no longer a variable, when it is: */
3058 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
3059 && !sym->attr.external)
3064 /* (i) Use associated; */
3065 if (sym->attr.use_assoc)
3068 /* (ii) The assignment is in the main program; or */
3069 if (gfc_current_ns->proc_name->attr.is_main_program)
3072 /* (iii) A module or internal procedure... */
3073 if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
3074 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
3075 && gfc_current_ns->parent
3076 && (!(gfc_current_ns->parent->proc_name->attr.function
3077 || gfc_current_ns->parent->proc_name->attr.subroutine)
3078 || gfc_current_ns->parent->proc_name->attr.is_main_program))
3080 /* ... that is not a function... */
3081 if (!gfc_current_ns->proc_name->attr.function)
3084 /* ... or is not an entry and has a different name. */
3085 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
3089 /* (iv) Host associated and not the function symbol or the
3090 parent result. This picks up sibling references, which
3091 cannot be entries. */
3092 if (!sym->attr.entry
3093 && sym->ns == gfc_current_ns->parent
3094 && sym != gfc_current_ns->proc_name
3095 && sym != gfc_current_ns->parent->proc_name->result)
3100 gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
3105 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
3107 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3108 lvalue->rank, rvalue->rank, &lvalue->where);
3112 if (lvalue->ts.type == BT_UNKNOWN)
3114 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3119 if (rvalue->expr_type == EXPR_NULL)
3121 if (has_pointer && (ref == NULL || ref->next == NULL)
3122 && lvalue->symtree->n.sym->attr.data)
3126 gfc_error ("NULL appears on right-hand side in assignment at %L",
3132 /* This is possibly a typo: x = f() instead of x => f(). */
3133 if (gfc_option.warn_surprising
3134 && rvalue->expr_type == EXPR_FUNCTION
3135 && rvalue->symtree->n.sym->attr.pointer)
3136 gfc_warning ("POINTER valued function appears on right-hand side of "
3137 "assignment at %L", &rvalue->where);
3139 /* Check size of array assignments. */
3140 if (lvalue->rank != 0 && rvalue->rank != 0
3141 && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
3144 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
3145 && lvalue->symtree->n.sym->attr.data
3146 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
3147 "initialize non-integer variable '%s'",
3148 &rvalue->where, lvalue->symtree->n.sym->name)
3151 else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
3152 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
3153 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3154 &rvalue->where) == FAILURE)
3157 /* Handle the case of a BOZ literal on the RHS. */
3158 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
3161 if (gfc_option.warn_surprising)
3162 gfc_warning ("BOZ literal at %L is bitwise transferred "
3163 "non-integer symbol '%s'", &rvalue->where,
3164 lvalue->symtree->n.sym->name);
3165 if (!gfc_convert_boz (rvalue, &lvalue->ts))
3167 if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
3169 if (rc == ARITH_UNDERFLOW)
3170 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3171 ". This check can be disabled with the option "
3172 "-fno-range-check", &rvalue->where);
3173 else if (rc == ARITH_OVERFLOW)
3174 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3175 ". This check can be disabled with the option "
3176 "-fno-range-check", &rvalue->where);
3177 else if (rc == ARITH_NAN)
3178 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3179 ". This check can be disabled with the option "
3180 "-fno-range-check", &rvalue->where);
3185 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
3188 /* Only DATA Statements come here. */
3191 /* Numeric can be converted to any other numeric. And Hollerith can be
3192 converted to any other type. */
3193 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3194 || rvalue->ts.type == BT_HOLLERITH)
3197 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3200 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3201 "conversion of %s to %s", &lvalue->where,
3202 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3207 /* Assignment is the only case where character variables of different
3208 kind values can be converted into one another. */
3209 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3211 if (lvalue->ts.kind != rvalue->ts.kind)
3212 gfc_convert_chartype (rvalue, &lvalue->ts);
3217 return gfc_convert_type (rvalue, &lvalue->ts, 1);
3221 /* Check that a pointer assignment is OK. We first check lvalue, and
3222 we only check rvalue if it's not an assignment to NULL() or a
3223 NULLIFY statement. */
3226 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3228 symbol_attribute attr;
3230 bool is_pure, rank_remap;
3233 if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3234 && !lvalue->symtree->n.sym->attr.proc_pointer)
3236 gfc_error ("Pointer assignment target is not a POINTER at %L",
3241 if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3242 && lvalue->symtree->n.sym->attr.use_assoc
3243 && !lvalue->symtree->n.sym->attr.proc_pointer)
3245 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3246 "l-value since it is a procedure",
3247 lvalue->symtree->n.sym->name, &lvalue->where);
3251 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3254 for (ref = lvalue->ref; ref; ref = ref->next)
3256 if (ref->type == REF_COMPONENT)
3257 proc_pointer = ref->u.c.component->attr.proc_pointer;
3259 if (ref->type == REF_ARRAY && ref->next == NULL)
3263 if (ref->u.ar.type == AR_FULL)
3266 if (ref->u.ar.type != AR_SECTION)
3268 gfc_error ("Expected bounds specification for '%s' at %L",
3269 lvalue->symtree->n.sym->name, &lvalue->where);
3273 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3274 "specification for '%s' in pointer assignment "
3275 "at %L", lvalue->symtree->n.sym->name,
3276 &lvalue->where) == FAILURE)
3279 /* When bounds are given, all lbounds are necessary and either all
3280 or none of the upper bounds; no strides are allowed. If the
3281 upper bounds are present, we may do rank remapping. */
3282 for (dim = 0; dim < ref->u.ar.dimen; ++dim)
3284 if (!ref->u.ar.start[dim])
3286 gfc_error ("Lower bound has to be present at %L",
3290 if (ref->u.ar.stride[dim])
3292 gfc_error ("Stride must not be present at %L",
3298 rank_remap = (ref->u.ar.end[dim] != NULL);
3301 if ((rank_remap && !ref->u.ar.end[dim])
3302 || (!rank_remap && ref->u.ar.end[dim]))
3304 gfc_error ("Either all or none of the upper bounds"
3305 " must be specified at %L", &lvalue->where);
3313 is_pure = gfc_pure (NULL);
3315 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3316 kind, etc for lvalue and rvalue must match, and rvalue must be a
3317 pure variable if we're in a pure function. */
3318 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3321 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3322 if (lvalue->expr_type == EXPR_VARIABLE
3323 && gfc_is_coindexed (lvalue))
3326 for (ref = lvalue->ref; ref; ref = ref->next)
3327 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3329 gfc_error ("Pointer object at %L shall not have a coindex",
3335 /* Checks on rvalue for procedure pointer assignments. */
3340 gfc_component *comp;
3343 attr = gfc_expr_attr (rvalue);
3344 if (!((rvalue->expr_type == EXPR_NULL)
3345 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3346 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
3347 || (rvalue->expr_type == EXPR_VARIABLE
3348 && attr.flavor == FL_PROCEDURE)))
3350 gfc_error ("Invalid procedure pointer assignment at %L",
3356 gfc_error ("Abstract interface '%s' is invalid "
3357 "in procedure pointer assignment at %L",
3358 rvalue->symtree->name, &rvalue->where);
3361 /* Check for C727. */
3362 if (attr.flavor == FL_PROCEDURE)
3364 if (attr.proc == PROC_ST_FUNCTION)
3366 gfc_error ("Statement function '%s' is invalid "
3367 "in procedure pointer assignment at %L",
3368 rvalue->symtree->name, &rvalue->where);
3371 if (attr.proc == PROC_INTERNAL &&
3372 gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
3373 "invalid in procedure pointer assignment at %L",
3374 rvalue->symtree->name, &rvalue->where) == FAILURE)
3378 /* Ensure that the calling convention is the same. As other attributes
3379 such as DLLEXPORT may differ, one explicitly only tests for the
3380 calling conventions. */
3381 if (rvalue->expr_type == EXPR_VARIABLE
3382 && lvalue->symtree->n.sym->attr.ext_attr
3383 != rvalue->symtree->n.sym->attr.ext_attr)
3385 symbol_attribute calls;
3388 gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
3389 gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
3390 gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
3392 if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
3393 != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
3395 gfc_error ("Mismatch in the procedure pointer assignment "
3396 "at %L: mismatch in the calling convention",
3402 if (gfc_is_proc_ptr_comp (lvalue, &comp))
3403 s1 = comp->ts.interface;
3405 s1 = lvalue->symtree->n.sym;
3407 if (gfc_is_proc_ptr_comp (rvalue, &comp))
3409 s2 = comp->ts.interface;
3412 else if (rvalue->expr_type == EXPR_FUNCTION)
3414 s2 = rvalue->symtree->n.sym->result;
3415 name = rvalue->symtree->n.sym->result->name;
3419 s2 = rvalue->symtree->n.sym;
3420 name = rvalue->symtree->n.sym->name;
3423 if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
3426 gfc_error ("Interface mismatch in procedure pointer assignment "
3427 "at %L: %s", &rvalue->where, err);
3434 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3436 gfc_error ("Different types in pointer assignment at %L; attempted "
3437 "assignment of %s to %s", &lvalue->where,
3438 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3442 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
3444 gfc_error ("Different kind type parameters in pointer "
3445 "assignment at %L", &lvalue->where);
3449 if (lvalue->rank != rvalue->rank && !rank_remap)
3451 gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
3455 if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
3456 /* Make sure the vtab is present. */
3457 gfc_find_derived_vtab (rvalue->ts.u.derived);
3459 /* Check rank remapping. */
3464 /* If this can be determined, check that the target must be at least as
3465 large as the pointer assigned to it is. */
3466 if (gfc_array_size (lvalue, &lsize) == SUCCESS
3467 && gfc_array_size (rvalue, &rsize) == SUCCESS
3468 && mpz_cmp (rsize, lsize) < 0)
3470 gfc_error ("Rank remapping target is smaller than size of the"
3471 " pointer (%ld < %ld) at %L",
3472 mpz_get_si (rsize), mpz_get_si (lsize),
3477 /* The target must be either rank one or it must be simply contiguous
3478 and F2008 must be allowed. */
3479 if (rvalue->rank != 1)
3481 if (!gfc_is_simply_contiguous (rvalue, true))
3483 gfc_error ("Rank remapping target must be rank 1 or"
3484 " simply contiguous at %L", &rvalue->where);
3487 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Rank remapping"
3488 " target is not rank 1 at %L", &rvalue->where)
3494 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3495 if (rvalue->expr_type == EXPR_NULL)
3498 if (lvalue->ts.type == BT_CHARACTER)
3500 gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3505 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3506 lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3508 attr = gfc_expr_attr (rvalue);
3509 if (!attr.target && !attr.pointer)
3511 gfc_error ("Pointer assignment target is neither TARGET "
3512 "nor POINTER at %L", &rvalue->where);
3516 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3518 gfc_error ("Bad target in pointer assignment in PURE "
3519 "procedure at %L", &rvalue->where);
3522 if (gfc_has_vector_index (rvalue))
3524 gfc_error ("Pointer assignment with vector subscript "
3525 "on rhs at %L", &rvalue->where);
3529 if (attr.is_protected && attr.use_assoc
3530 && !(attr.pointer || attr.proc_pointer))
3532 gfc_error ("Pointer assignment target has PROTECTED "
3533 "attribute at %L", &rvalue->where);
3537 /* F2008, C725. For PURE also C1283. */
3538 if (rvalue->expr_type == EXPR_VARIABLE
3539 && gfc_is_coindexed (rvalue))
3542 for (ref = rvalue->ref; ref; ref = ref->next)
3543 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3545 gfc_error ("Data target at %L shall not have a coindex",
3555 /* Relative of gfc_check_assign() except that the lvalue is a single
3556 symbol. Used for initialization assignments. */
3559 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3564 memset (&lvalue, '\0', sizeof (gfc_expr));
3566 lvalue.expr_type = EXPR_VARIABLE;
3567 lvalue.ts = sym->ts;
3569 lvalue.rank = sym->as->rank;
3570 lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3571 lvalue.symtree->n.sym = sym;
3572 lvalue.where = sym->declared_at;
3574 if (sym->attr.pointer || sym->attr.proc_pointer
3575 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer
3576 && rvalue->expr_type == EXPR_NULL))
3577 r = gfc_check_pointer_assign (&lvalue, rvalue);
3579 r = gfc_check_assign (&lvalue, rvalue, 1);
3581 gfc_free (lvalue.symtree);
3586 if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL)
3588 /* F08:C461. Additional checks for pointer initialization. */
3589 symbol_attribute attr;
3590 attr = gfc_expr_attr (rvalue);
3591 if (attr.allocatable)
3593 gfc_error ("Pointer initialization target at %C "
3594 "must not be ALLOCATABLE ");
3599 gfc_error ("Pointer initialization target at %C "
3600 "must have the TARGET attribute");
3605 gfc_error ("Pointer initialization target at %C "
3606 "must have the SAVE attribute");
3615 /* Check for default initializer; sym->value is not enough
3616 as it is also set for EXPR_NULL of allocatables. */
3619 gfc_has_default_initializer (gfc_symbol *der)
3623 gcc_assert (der->attr.flavor == FL_DERIVED);
3624 for (c = der->components; c; c = c->next)
3625 if (c->ts.type == BT_DERIVED)
3627 if (!c->attr.pointer
3628 && gfc_has_default_initializer (c->ts.u.derived))
3640 /* Get an expression for a default initializer. */
3643 gfc_default_initializer (gfc_typespec *ts)
3646 gfc_component *comp;
3648 /* See if we have a default initializer in this, but not in nested
3649 types (otherwise we could use gfc_has_default_initializer()). */
3650 for (comp = ts->u.derived->components; comp; comp = comp->next)
3651 if (comp->initializer || comp->attr.allocatable)
3657 init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
3658 &ts->u.derived->declared_at);
3661 for (comp = ts->u.derived->components; comp; comp = comp->next)
3663 gfc_constructor *ctor = gfc_constructor_get();
3665 if (comp->initializer)
3666 ctor->expr = gfc_copy_expr (comp->initializer);
3668 if (comp->attr.allocatable)
3670 ctor->expr = gfc_get_expr ();
3671 ctor->expr->expr_type = EXPR_NULL;
3672 ctor->expr->ts = comp->ts;
3675 gfc_constructor_append (&init->value.constructor, ctor);
3682 /* Given a symbol, create an expression node with that symbol as a
3683 variable. If the symbol is array valued, setup a reference of the
3687 gfc_get_variable_expr (gfc_symtree *var)
3691 e = gfc_get_expr ();
3692 e->expr_type = EXPR_VARIABLE;
3694 e->ts = var->n.sym->ts;
3696 if (var->n.sym->as != NULL)
3698 e->rank = var->n.sym->as->rank;
3699 e->ref = gfc_get_ref ();
3700 e->ref->type = REF_ARRAY;
3701 e->ref->u.ar.type = AR_FULL;
3708 /* Returns the array_spec of a full array expression. A NULL is
3709 returned otherwise. */
3711 gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
3716 if (expr->rank == 0)
3719 /* Follow any component references. */
3720 if (expr->expr_type == EXPR_VARIABLE
3721 || expr->expr_type == EXPR_CONSTANT)
3723 as = expr->symtree->n.sym->as;
3724 for (ref = expr->ref; ref; ref = ref->next)
3729 as = ref->u.c.component->as;
3737 switch (ref->u.ar.type)
3760 /* General expression traversal function. */
3763 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3764 bool (*func)(gfc_expr *, gfc_symbol *, int*),
3769 gfc_actual_arglist *args;
3776 if ((*func) (expr, sym, &f))
3779 if (expr->ts.type == BT_CHARACTER
3781 && expr->ts.u.cl->length
3782 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
3783 && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
3786 switch (expr->expr_type)
3791 for (args = expr->value.function.actual; args; args = args->next)
3793 if (gfc_traverse_expr (args->expr, sym, func, f))
3801 case EXPR_SUBSTRING:
3804 case EXPR_STRUCTURE:
3806 for (c = gfc_constructor_first (expr->value.constructor);
3807 c; c = gfc_constructor_next (c))
3809 if (gfc_traverse_expr (c->expr, sym, func, f))
3813 if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3815 if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3817 if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3819 if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3826 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3828 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3844 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3846 if (gfc_traverse_expr (ar.start[i], sym, func, f))
3848 if (gfc_traverse_expr (ar.end[i], sym, func, f))
3850 if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3856 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3858 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3863 if (ref->u.c.component->ts.type == BT_CHARACTER
3864 && ref->u.c.component->ts.u.cl
3865 && ref->u.c.component->ts.u.cl->length
3866 && ref->u.c.component->ts.u.cl->length->expr_type
3868 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
3872 if (ref->u.c.component->as)
3873 for (i = 0; i < ref->u.c.component->as->rank
3874 + ref->u.c.component->as->corank; i++)
3876 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3879 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3893 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3896 expr_set_symbols_referenced (gfc_expr *expr,
3897 gfc_symbol *sym ATTRIBUTE_UNUSED,
3898 int *f ATTRIBUTE_UNUSED)
3900 if (expr->expr_type != EXPR_VARIABLE)
3902 gfc_set_sym_referenced (expr->symtree->n.sym);
3907 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3909 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3913 /* Determine if an expression is a procedure pointer component. If yes, the
3914 argument 'comp' will point to the component (provided that 'comp' was
3918 gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
3923 if (!expr || !expr->ref)
3930 if (ref->type == REF_COMPONENT)
3932 ppc = ref->u.c.component->attr.proc_pointer;
3934 *comp = ref->u.c.component;
3941 /* Walk an expression tree and check each variable encountered for being typed.
3942 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3943 mode as is a basic arithmetic expression using those; this is for things in
3946 INTEGER :: arr(n), n
3947 INTEGER :: arr(n + 1), n
3949 The namespace is needed for IMPLICIT typing. */
3951 static gfc_namespace* check_typed_ns;
3954 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3955 int* f ATTRIBUTE_UNUSED)
3959 if (e->expr_type != EXPR_VARIABLE)
3962 gcc_assert (e->symtree);
3963 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3966 return (t == FAILURE);
3970 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3974 /* If this is a top-level variable or EXPR_OP, do the check with strict given
3978 if (e->expr_type == EXPR_VARIABLE && !e->ref)
3979 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3981 if (e->expr_type == EXPR_OP)
3983 gfc_try t = SUCCESS;
3985 gcc_assert (e->value.op.op1);
3986 t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
3988 if (t == SUCCESS && e->value.op.op2)
3989 t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
3995 /* Otherwise, walk the expression and do it strictly. */
3996 check_typed_ns = ns;
3997 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3999 return error_found ? FAILURE : SUCCESS;
4002 /* Walk an expression tree and replace all symbols with a corresponding symbol
4003 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
4004 statements. The boolean return value is required by gfc_traverse_expr. */
4007 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
4009 if ((expr->expr_type == EXPR_VARIABLE
4010 || (expr->expr_type == EXPR_FUNCTION
4011 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
4012 && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
4015 gfc_namespace *ns = sym->formal_ns;
4016 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4017 the symtree rather than create a new one (and probably fail later). */
4018 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
4019 expr->symtree->n.sym->name);
4021 stree->n.sym->attr = expr->symtree->n.sym->attr;
4022 expr->symtree = stree;
4028 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
4030 gfc_traverse_expr (expr, dest, &replace_symbol, 0);
4033 /* The following is analogous to 'replace_symbol', and needed for copying
4034 interfaces for procedure pointer components. The argument 'sym' must formally
4035 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
4036 However, it gets actually passed a gfc_component (i.e. the procedure pointer
4037 component in whose formal_ns the arguments have to be). */
4040 replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
4042 gfc_component *comp;
4043 comp = (gfc_component *)sym;
4044 if ((expr->expr_type == EXPR_VARIABLE
4045 || (expr->expr_type == EXPR_FUNCTION
4046 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
4047 && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
4050 gfc_namespace *ns = comp->formal_ns;
4051 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4052 the symtree rather than create a new one (and probably fail later). */
4053 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
4054 expr->symtree->n.sym->name);
4056 stree->n.sym->attr = expr->symtree->n.sym->attr;
4057 expr->symtree = stree;
4063 gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
4065 gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
4070 gfc_is_coindexed (gfc_expr *e)
4074 for (ref = e->ref; ref; ref = ref->next)
4075 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
4083 gfc_get_corank (gfc_expr *e)
4087 corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
4088 for (ref = e->ref; ref; ref = ref->next)
4090 if (ref->type == REF_ARRAY)
4091 corank = ref->u.ar.as->corank;
4092 gcc_assert (ref->type != REF_SUBSTRING);
4098 /* Check whether the expression has an ultimate allocatable component.
4099 Being itself allocatable does not count. */
4101 gfc_has_ultimate_allocatable (gfc_expr *e)
4103 gfc_ref *ref, *last = NULL;
4105 if (e->expr_type != EXPR_VARIABLE)
4108 for (ref = e->ref; ref; ref = ref->next)
4109 if (ref->type == REF_COMPONENT)
4112 if (last && last->u.c.component->ts.type == BT_CLASS)
4113 return CLASS_DATA (last->u.c.component)->attr.alloc_comp;
4114 else if (last && last->u.c.component->ts.type == BT_DERIVED)
4115 return last->u.c.component->ts.u.derived->attr.alloc_comp;
4119 if (e->ts.type == BT_CLASS)
4120 return CLASS_DATA (e)->attr.alloc_comp;
4121 else if (e->ts.type == BT_DERIVED)
4122 return e->ts.u.derived->attr.alloc_comp;
4128 /* Check whether the expression has an pointer component.
4129 Being itself a pointer does not count. */
4131 gfc_has_ultimate_pointer (gfc_expr *e)
4133 gfc_ref *ref, *last = NULL;
4135 if (e->expr_type != EXPR_VARIABLE)
4138 for (ref = e->ref; ref; ref = ref->next)
4139 if (ref->type == REF_COMPONENT)
4142 if (last && last->u.c.component->ts.type == BT_CLASS)
4143 return CLASS_DATA (last->u.c.component)->attr.pointer_comp;
4144 else if (last && last->u.c.component->ts.type == BT_DERIVED)
4145 return last->u.c.component->ts.u.derived->attr.pointer_comp;
4149 if (e->ts.type == BT_CLASS)
4150 return CLASS_DATA (e)->attr.pointer_comp;
4151 else if (e->ts.type == BT_DERIVED)
4152 return e->ts.u.derived->attr.pointer_comp;
4158 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4159 Note: A scalar is not regarded as "simply contiguous" by the standard.
4160 if bool is not strict, some futher checks are done - for instance,
4161 a "(::1)" is accepted. */
4164 gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
4168 gfc_array_ref *ar = NULL;
4169 gfc_ref *ref, *part_ref = NULL;
4171 if (expr->expr_type == EXPR_FUNCTION)
4172 return expr->value.function.esym
4173 ? expr->value.function.esym->result->attr.contiguous : false;
4174 else if (expr->expr_type != EXPR_VARIABLE)
4177 if (expr->rank == 0)
4180 for (ref = expr->ref; ref; ref = ref->next)
4183 return false; /* Array shall be last part-ref. */
4185 if (ref->type == REF_COMPONENT)
4187 else if (ref->type == REF_SUBSTRING)
4189 else if (ref->u.ar.type != AR_ELEMENT)
4193 if ((part_ref && !part_ref->u.c.component->attr.contiguous
4194 && part_ref->u.c.component->attr.pointer)
4195 || (!part_ref && !expr->symtree->n.sym->attr.contiguous
4196 && (expr->symtree->n.sym->attr.pointer
4197 || expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)))
4200 if (!ar || ar->type == AR_FULL)
4203 gcc_assert (ar->type == AR_SECTION);
4205 /* Check for simply contiguous array */
4207 for (i = 0; i < ar->dimen; i++)
4209 if (ar->dimen_type[i] == DIMEN_VECTOR)
4212 if (ar->dimen_type[i] == DIMEN_ELEMENT)
4218 gcc_assert (ar->dimen_type[i] == DIMEN_RANGE);
4221 /* If the previous section was not contiguous, that's an error,
4222 unless we have effective only one element and checking is not
4224 if (!colon && (strict || !ar->start[i] || !ar->end[i]
4225 || ar->start[i]->expr_type != EXPR_CONSTANT
4226 || ar->end[i]->expr_type != EXPR_CONSTANT
4227 || mpz_cmp (ar->start[i]->value.integer,
4228 ar->end[i]->value.integer) != 0))
4231 /* Following the standard, "(::1)" or - if known at compile time -
4232 "(lbound:ubound)" are not simply contigous; if strict
4233 is false, they are regarded as simply contiguous. */
4234 if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT
4235 || ar->stride[i]->ts.type != BT_INTEGER
4236 || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0))
4240 && (strict || ar->start[i]->expr_type != EXPR_CONSTANT
4241 || !ar->as->lower[i]
4242 || ar->as->lower[i]->expr_type != EXPR_CONSTANT
4243 || mpz_cmp (ar->start[i]->value.integer,
4244 ar->as->lower[i]->value.integer) != 0))
4248 && (strict || ar->end[i]->expr_type != EXPR_CONSTANT
4249 || !ar->as->upper[i]
4250 || ar->as->upper[i]->expr_type != EXPR_CONSTANT
4251 || mpz_cmp (ar->end[i]->value.integer,
4252 ar->as->upper[i]->value.integer) != 0))
4260 /* Build call to an intrinsic procedure. The number of arguments has to be
4261 passed (rather than ending the list with a NULL value) because we may
4262 want to add arguments but with a NULL-expression. */
4265 gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
4268 gfc_actual_arglist* atail;
4269 gfc_intrinsic_sym* isym;
4273 isym = gfc_find_function (name);
4276 result = gfc_get_expr ();
4277 result->expr_type = EXPR_FUNCTION;
4278 result->ts = isym->ts;
4279 result->where = where;
4280 result->value.function.name = name;
4281 result->value.function.isym = isym;
4283 va_start (ap, numarg);
4285 for (i = 0; i < numarg; ++i)
4289 atail->next = gfc_get_actual_arglist ();
4290 atail = atail->next;
4293 atail = result->value.function.actual = gfc_get_actual_arglist ();
4295 atail->expr = va_arg (ap, gfc_expr*);
4303 /* Check if an expression may appear in a variable definition context
4304 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
4305 This is called from the various places when resolving
4306 the pieces that make up such a context.
4308 Optionally, a possible error message can be suppressed if context is NULL
4309 and just the return status (SUCCESS / FAILURE) be requested. */
4312 gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
4316 bool check_intentin;
4318 symbol_attribute attr;
4321 if (!pointer && e->expr_type == EXPR_FUNCTION
4322 && e->symtree->n.sym->result->attr.pointer)
4324 if (!(gfc_option.allow_std & GFC_STD_F2008))
4327 gfc_error ("Fortran 2008: Pointer functions in variable definition"
4328 " context (%s) at %L", context, &e->where);
4332 else if (e->expr_type != EXPR_VARIABLE)
4335 gfc_error ("Non-variable expression in variable definition context (%s)"
4336 " at %L", context, &e->where);
4340 gcc_assert (e->symtree);
4341 sym = e->symtree->n.sym;
4343 if (!pointer && sym->attr.flavor == FL_PARAMETER)
4346 gfc_error ("Named constant '%s' in variable definition context (%s)"
4347 " at %L", sym->name, context, &e->where);
4350 if (!pointer && sym->attr.flavor != FL_VARIABLE
4351 && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result)
4352 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
4355 gfc_error ("'%s' in variable definition context (%s) at %L is not"
4356 " a variable", sym->name, context, &e->where);
4360 /* Find out whether the expr is a pointer; this also means following
4361 component references to the last one. */
4362 attr = gfc_expr_attr (e);
4363 is_pointer = (attr.pointer || attr.proc_pointer);
4364 if (pointer && !is_pointer)
4367 gfc_error ("Non-POINTER in pointer association context (%s)"
4368 " at %L", context, &e->where);
4372 /* INTENT(IN) dummy argument. Check this, unless the object itself is
4373 the component of sub-component of a pointer. Obviously,
4374 procedure pointers are of no interest here. */
4375 check_intentin = true;
4376 ptr_component = sym->attr.pointer;
4377 for (ref = e->ref; ref && check_intentin; ref = ref->next)
4379 if (ptr_component && ref->type == REF_COMPONENT)
4380 check_intentin = false;
4381 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
4382 ptr_component = true;
4384 if (check_intentin && sym->attr.intent == INTENT_IN)
4386 if (pointer && is_pointer)
4389 gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
4390 " association context (%s) at %L",
4391 sym->name, context, &e->where);
4394 if (!pointer && !is_pointer)
4397 gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
4398 " definition context (%s) at %L",
4399 sym->name, context, &e->where);
4404 /* PROTECTED and use-associated. */
4405 if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin)
4407 if (pointer && is_pointer)
4410 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4411 " pointer association context (%s) at %L",
4412 sym->name, context, &e->where);
4415 if (!pointer && !is_pointer)
4418 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4419 " variable definition context (%s) at %L",
4420 sym->name, context, &e->where);
4425 /* Variable not assignable from a PURE procedure but appears in
4426 variable definition context. */
4427 if (!pointer && gfc_pure (NULL) && gfc_impure_variable (sym))
4430 gfc_error ("Variable '%s' can not appear in a variable definition"
4431 " context (%s) at %L in PURE procedure",
4432 sym->name, context, &e->where);
4436 /* Check variable definition context for associate-names. */
4437 if (!pointer && sym->assoc)
4440 gfc_association_list* assoc;
4442 gcc_assert (sym->assoc->target);
4444 /* If this is a SELECT TYPE temporary (the association is used internally
4445 for SELECT TYPE), silently go over to the target. */
4446 if (sym->attr.select_type_temporary)
4448 gfc_expr* t = sym->assoc->target;
4450 gcc_assert (t->expr_type == EXPR_VARIABLE);
4451 name = t->symtree->name;
4453 if (t->symtree->n.sym->assoc)
4454 assoc = t->symtree->n.sym->assoc;
4463 gcc_assert (name && assoc);
4465 /* Is association to a valid variable? */
4466 if (!assoc->variable)
4470 if (assoc->target->expr_type == EXPR_VARIABLE)
4471 gfc_error ("'%s' at %L associated to vector-indexed target can"
4472 " not be used in a variable definition context (%s)",
4473 name, &e->where, context);
4475 gfc_error ("'%s' at %L associated to expression can"
4476 " not be used in a variable definition context (%s)",
4477 name, &e->where, context);
4482 /* Target must be allowed to appear in a variable definition context. */
4483 if (gfc_check_vardef_context (assoc->target, pointer, NULL) == FAILURE)
4486 gfc_error ("Associate-name '%s' can not appear in a variable"
4487 " definition context (%s) at %L because its target"
4488 " at %L can not, either",
4489 name, context, &e->where,
4490 &assoc->target->where);