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, is_implicit_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);
3314 is_implicit_pure = gfc_implicit_pure (NULL);
3316 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3317 kind, etc for lvalue and rvalue must match, and rvalue must be a
3318 pure variable if we're in a pure function. */
3319 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3322 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3323 if (lvalue->expr_type == EXPR_VARIABLE
3324 && gfc_is_coindexed (lvalue))
3327 for (ref = lvalue->ref; ref; ref = ref->next)
3328 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3330 gfc_error ("Pointer object at %L shall not have a coindex",
3336 /* Checks on rvalue for procedure pointer assignments. */
3341 gfc_component *comp;
3344 attr = gfc_expr_attr (rvalue);
3345 if (!((rvalue->expr_type == EXPR_NULL)
3346 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3347 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
3348 || (rvalue->expr_type == EXPR_VARIABLE
3349 && attr.flavor == FL_PROCEDURE)))
3351 gfc_error ("Invalid procedure pointer assignment at %L",
3357 gfc_error ("Abstract interface '%s' is invalid "
3358 "in procedure pointer assignment at %L",
3359 rvalue->symtree->name, &rvalue->where);
3362 /* Check for C727. */
3363 if (attr.flavor == FL_PROCEDURE)
3365 if (attr.proc == PROC_ST_FUNCTION)
3367 gfc_error ("Statement function '%s' is invalid "
3368 "in procedure pointer assignment at %L",
3369 rvalue->symtree->name, &rvalue->where);
3372 if (attr.proc == PROC_INTERNAL &&
3373 gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
3374 "invalid in procedure pointer assignment at %L",
3375 rvalue->symtree->name, &rvalue->where) == FAILURE)
3379 /* Ensure that the calling convention is the same. As other attributes
3380 such as DLLEXPORT may differ, one explicitly only tests for the
3381 calling conventions. */
3382 if (rvalue->expr_type == EXPR_VARIABLE
3383 && lvalue->symtree->n.sym->attr.ext_attr
3384 != rvalue->symtree->n.sym->attr.ext_attr)
3386 symbol_attribute calls;
3389 gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
3390 gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
3391 gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
3393 if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
3394 != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
3396 gfc_error ("Mismatch in the procedure pointer assignment "
3397 "at %L: mismatch in the calling convention",
3403 if (gfc_is_proc_ptr_comp (lvalue, &comp))
3404 s1 = comp->ts.interface;
3406 s1 = lvalue->symtree->n.sym;
3408 if (gfc_is_proc_ptr_comp (rvalue, &comp))
3410 s2 = comp->ts.interface;
3413 else if (rvalue->expr_type == EXPR_FUNCTION)
3415 s2 = rvalue->symtree->n.sym->result;
3416 name = rvalue->symtree->n.sym->result->name;
3420 s2 = rvalue->symtree->n.sym;
3421 name = rvalue->symtree->n.sym->name;
3424 if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
3427 gfc_error ("Interface mismatch in procedure pointer assignment "
3428 "at %L: %s", &rvalue->where, err);
3435 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3437 gfc_error ("Different types in pointer assignment at %L; attempted "
3438 "assignment of %s to %s", &lvalue->where,
3439 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3443 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
3445 gfc_error ("Different kind type parameters in pointer "
3446 "assignment at %L", &lvalue->where);
3450 if (lvalue->rank != rvalue->rank && !rank_remap)
3452 gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
3456 if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
3457 /* Make sure the vtab is present. */
3458 gfc_find_derived_vtab (rvalue->ts.u.derived);
3460 /* Check rank remapping. */
3465 /* If this can be determined, check that the target must be at least as
3466 large as the pointer assigned to it is. */
3467 if (gfc_array_size (lvalue, &lsize) == SUCCESS
3468 && gfc_array_size (rvalue, &rsize) == SUCCESS
3469 && mpz_cmp (rsize, lsize) < 0)
3471 gfc_error ("Rank remapping target is smaller than size of the"
3472 " pointer (%ld < %ld) at %L",
3473 mpz_get_si (rsize), mpz_get_si (lsize),
3478 /* The target must be either rank one or it must be simply contiguous
3479 and F2008 must be allowed. */
3480 if (rvalue->rank != 1)
3482 if (!gfc_is_simply_contiguous (rvalue, true))
3484 gfc_error ("Rank remapping target must be rank 1 or"
3485 " simply contiguous at %L", &rvalue->where);
3488 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Rank remapping"
3489 " target is not rank 1 at %L", &rvalue->where)
3495 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3496 if (rvalue->expr_type == EXPR_NULL)
3499 if (lvalue->ts.type == BT_CHARACTER)
3501 gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3506 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3507 lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3509 attr = gfc_expr_attr (rvalue);
3511 if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer)
3513 gfc_error ("Target expression in pointer assignment "
3514 "at %L must deliver a pointer result",
3519 if (!attr.target && !attr.pointer)
3521 gfc_error ("Pointer assignment target is neither TARGET "
3522 "nor POINTER at %L", &rvalue->where);
3526 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3528 gfc_error ("Bad target in pointer assignment in PURE "
3529 "procedure at %L", &rvalue->where);
3532 if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3533 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3536 if (gfc_has_vector_index (rvalue))
3538 gfc_error ("Pointer assignment with vector subscript "
3539 "on rhs at %L", &rvalue->where);
3543 if (attr.is_protected && attr.use_assoc
3544 && !(attr.pointer || attr.proc_pointer))
3546 gfc_error ("Pointer assignment target has PROTECTED "
3547 "attribute at %L", &rvalue->where);
3551 /* F2008, C725. For PURE also C1283. */
3552 if (rvalue->expr_type == EXPR_VARIABLE
3553 && gfc_is_coindexed (rvalue))
3556 for (ref = rvalue->ref; ref; ref = ref->next)
3557 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3559 gfc_error ("Data target at %L shall not have a coindex",
3569 /* Relative of gfc_check_assign() except that the lvalue is a single
3570 symbol. Used for initialization assignments. */
3573 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3578 memset (&lvalue, '\0', sizeof (gfc_expr));
3580 lvalue.expr_type = EXPR_VARIABLE;
3581 lvalue.ts = sym->ts;
3583 lvalue.rank = sym->as->rank;
3584 lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3585 lvalue.symtree->n.sym = sym;
3586 lvalue.where = sym->declared_at;
3588 if (sym->attr.pointer || sym->attr.proc_pointer
3589 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer
3590 && rvalue->expr_type == EXPR_NULL))
3591 r = gfc_check_pointer_assign (&lvalue, rvalue);
3593 r = gfc_check_assign (&lvalue, rvalue, 1);
3595 gfc_free (lvalue.symtree);
3600 if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL)
3602 /* F08:C461. Additional checks for pointer initialization. */
3603 symbol_attribute attr;
3604 attr = gfc_expr_attr (rvalue);
3605 if (attr.allocatable)
3607 gfc_error ("Pointer initialization target at %C "
3608 "must not be ALLOCATABLE ");
3611 if (!attr.target || attr.pointer)
3613 gfc_error ("Pointer initialization target at %C "
3614 "must have the TARGET attribute");
3619 gfc_error ("Pointer initialization target at %C "
3620 "must have the SAVE attribute");
3625 if (sym->attr.proc_pointer && rvalue->expr_type != EXPR_NULL)
3627 /* F08:C1220. Additional checks for procedure pointer initialization. */
3628 symbol_attribute attr = gfc_expr_attr (rvalue);
3629 if (attr.proc_pointer)
3631 gfc_error ("Procedure pointer initialization target at %L "
3632 "may not be a procedure pointer", &rvalue->where);
3641 /* Check for default initializer; sym->value is not enough
3642 as it is also set for EXPR_NULL of allocatables. */
3645 gfc_has_default_initializer (gfc_symbol *der)
3649 gcc_assert (der->attr.flavor == FL_DERIVED);
3650 for (c = der->components; c; c = c->next)
3651 if (c->ts.type == BT_DERIVED)
3653 if (!c->attr.pointer
3654 && gfc_has_default_initializer (c->ts.u.derived))
3666 /* Get an expression for a default initializer. */
3669 gfc_default_initializer (gfc_typespec *ts)
3672 gfc_component *comp;
3674 /* See if we have a default initializer in this, but not in nested
3675 types (otherwise we could use gfc_has_default_initializer()). */
3676 for (comp = ts->u.derived->components; comp; comp = comp->next)
3677 if (comp->initializer || comp->attr.allocatable
3678 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
3684 init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
3685 &ts->u.derived->declared_at);
3688 for (comp = ts->u.derived->components; comp; comp = comp->next)
3690 gfc_constructor *ctor = gfc_constructor_get();
3692 if (comp->initializer)
3693 ctor->expr = gfc_copy_expr (comp->initializer);
3695 if (comp->attr.allocatable
3696 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
3698 ctor->expr = gfc_get_expr ();
3699 ctor->expr->expr_type = EXPR_NULL;
3700 ctor->expr->ts = comp->ts;
3703 gfc_constructor_append (&init->value.constructor, ctor);
3710 /* Given a symbol, create an expression node with that symbol as a
3711 variable. If the symbol is array valued, setup a reference of the
3715 gfc_get_variable_expr (gfc_symtree *var)
3719 e = gfc_get_expr ();
3720 e->expr_type = EXPR_VARIABLE;
3722 e->ts = var->n.sym->ts;
3724 if (var->n.sym->as != NULL)
3726 e->rank = var->n.sym->as->rank;
3727 e->ref = gfc_get_ref ();
3728 e->ref->type = REF_ARRAY;
3729 e->ref->u.ar.type = AR_FULL;
3737 gfc_lval_expr_from_sym (gfc_symbol *sym)
3740 lval = gfc_get_expr ();
3741 lval->expr_type = EXPR_VARIABLE;
3742 lval->where = sym->declared_at;
3744 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
3746 /* It will always be a full array. */
3747 lval->rank = sym->as ? sym->as->rank : 0;
3750 lval->ref = gfc_get_ref ();
3751 lval->ref->type = REF_ARRAY;
3752 lval->ref->u.ar.type = AR_FULL;
3753 lval->ref->u.ar.dimen = lval->rank;
3754 lval->ref->u.ar.where = sym->declared_at;
3755 lval->ref->u.ar.as = sym->as;
3762 /* Returns the array_spec of a full array expression. A NULL is
3763 returned otherwise. */
3765 gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
3770 if (expr->rank == 0)
3773 /* Follow any component references. */
3774 if (expr->expr_type == EXPR_VARIABLE
3775 || expr->expr_type == EXPR_CONSTANT)
3777 as = expr->symtree->n.sym->as;
3778 for (ref = expr->ref; ref; ref = ref->next)
3783 as = ref->u.c.component->as;
3791 switch (ref->u.ar.type)
3814 /* General expression traversal function. */
3817 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3818 bool (*func)(gfc_expr *, gfc_symbol *, int*),
3823 gfc_actual_arglist *args;
3830 if ((*func) (expr, sym, &f))
3833 if (expr->ts.type == BT_CHARACTER
3835 && expr->ts.u.cl->length
3836 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
3837 && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
3840 switch (expr->expr_type)
3845 for (args = expr->value.function.actual; args; args = args->next)
3847 if (gfc_traverse_expr (args->expr, sym, func, f))
3855 case EXPR_SUBSTRING:
3858 case EXPR_STRUCTURE:
3860 for (c = gfc_constructor_first (expr->value.constructor);
3861 c; c = gfc_constructor_next (c))
3863 if (gfc_traverse_expr (c->expr, sym, func, f))
3867 if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3869 if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3871 if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3873 if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3880 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3882 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3898 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3900 if (gfc_traverse_expr (ar.start[i], sym, func, f))
3902 if (gfc_traverse_expr (ar.end[i], sym, func, f))
3904 if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3910 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3912 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3917 if (ref->u.c.component->ts.type == BT_CHARACTER
3918 && ref->u.c.component->ts.u.cl
3919 && ref->u.c.component->ts.u.cl->length
3920 && ref->u.c.component->ts.u.cl->length->expr_type
3922 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
3926 if (ref->u.c.component->as)
3927 for (i = 0; i < ref->u.c.component->as->rank
3928 + ref->u.c.component->as->corank; i++)
3930 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3933 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3947 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3950 expr_set_symbols_referenced (gfc_expr *expr,
3951 gfc_symbol *sym ATTRIBUTE_UNUSED,
3952 int *f ATTRIBUTE_UNUSED)
3954 if (expr->expr_type != EXPR_VARIABLE)
3956 gfc_set_sym_referenced (expr->symtree->n.sym);
3961 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3963 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3967 /* Determine if an expression is a procedure pointer component. If yes, the
3968 argument 'comp' will point to the component (provided that 'comp' was
3972 gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
3977 if (!expr || !expr->ref)
3984 if (ref->type == REF_COMPONENT)
3986 ppc = ref->u.c.component->attr.proc_pointer;
3988 *comp = ref->u.c.component;
3995 /* Walk an expression tree and check each variable encountered for being typed.
3996 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3997 mode as is a basic arithmetic expression using those; this is for things in
4000 INTEGER :: arr(n), n
4001 INTEGER :: arr(n + 1), n
4003 The namespace is needed for IMPLICIT typing. */
4005 static gfc_namespace* check_typed_ns;
4008 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
4009 int* f ATTRIBUTE_UNUSED)
4013 if (e->expr_type != EXPR_VARIABLE)
4016 gcc_assert (e->symtree);
4017 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
4020 return (t == FAILURE);
4024 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
4028 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4032 if (e->expr_type == EXPR_VARIABLE && !e->ref)
4033 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
4035 if (e->expr_type == EXPR_OP)
4037 gfc_try t = SUCCESS;
4039 gcc_assert (e->value.op.op1);
4040 t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
4042 if (t == SUCCESS && e->value.op.op2)
4043 t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
4049 /* Otherwise, walk the expression and do it strictly. */
4050 check_typed_ns = ns;
4051 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
4053 return error_found ? FAILURE : SUCCESS;
4056 /* Walk an expression tree and replace all symbols with a corresponding symbol
4057 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
4058 statements. The boolean return value is required by gfc_traverse_expr. */
4061 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
4063 if ((expr->expr_type == EXPR_VARIABLE
4064 || (expr->expr_type == EXPR_FUNCTION
4065 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
4066 && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
4069 gfc_namespace *ns = sym->formal_ns;
4070 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4071 the symtree rather than create a new one (and probably fail later). */
4072 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
4073 expr->symtree->n.sym->name);
4075 stree->n.sym->attr = expr->symtree->n.sym->attr;
4076 expr->symtree = stree;
4082 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
4084 gfc_traverse_expr (expr, dest, &replace_symbol, 0);
4087 /* The following is analogous to 'replace_symbol', and needed for copying
4088 interfaces for procedure pointer components. The argument 'sym' must formally
4089 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
4090 However, it gets actually passed a gfc_component (i.e. the procedure pointer
4091 component in whose formal_ns the arguments have to be). */
4094 replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
4096 gfc_component *comp;
4097 comp = (gfc_component *)sym;
4098 if ((expr->expr_type == EXPR_VARIABLE
4099 || (expr->expr_type == EXPR_FUNCTION
4100 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
4101 && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
4104 gfc_namespace *ns = comp->formal_ns;
4105 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4106 the symtree rather than create a new one (and probably fail later). */
4107 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
4108 expr->symtree->n.sym->name);
4110 stree->n.sym->attr = expr->symtree->n.sym->attr;
4111 expr->symtree = stree;
4117 gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
4119 gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
4124 gfc_is_coindexed (gfc_expr *e)
4128 for (ref = e->ref; ref; ref = ref->next)
4129 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
4137 gfc_get_corank (gfc_expr *e)
4141 corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
4142 for (ref = e->ref; ref; ref = ref->next)
4144 if (ref->type == REF_ARRAY)
4145 corank = ref->u.ar.as->corank;
4146 gcc_assert (ref->type != REF_SUBSTRING);
4152 /* Check whether the expression has an ultimate allocatable component.
4153 Being itself allocatable does not count. */
4155 gfc_has_ultimate_allocatable (gfc_expr *e)
4157 gfc_ref *ref, *last = NULL;
4159 if (e->expr_type != EXPR_VARIABLE)
4162 for (ref = e->ref; ref; ref = ref->next)
4163 if (ref->type == REF_COMPONENT)
4166 if (last && last->u.c.component->ts.type == BT_CLASS)
4167 return CLASS_DATA (last->u.c.component)->attr.alloc_comp;
4168 else if (last && last->u.c.component->ts.type == BT_DERIVED)
4169 return last->u.c.component->ts.u.derived->attr.alloc_comp;
4173 if (e->ts.type == BT_CLASS)
4174 return CLASS_DATA (e)->attr.alloc_comp;
4175 else if (e->ts.type == BT_DERIVED)
4176 return e->ts.u.derived->attr.alloc_comp;
4182 /* Check whether the expression has an pointer component.
4183 Being itself a pointer does not count. */
4185 gfc_has_ultimate_pointer (gfc_expr *e)
4187 gfc_ref *ref, *last = NULL;
4189 if (e->expr_type != EXPR_VARIABLE)
4192 for (ref = e->ref; ref; ref = ref->next)
4193 if (ref->type == REF_COMPONENT)
4196 if (last && last->u.c.component->ts.type == BT_CLASS)
4197 return CLASS_DATA (last->u.c.component)->attr.pointer_comp;
4198 else if (last && last->u.c.component->ts.type == BT_DERIVED)
4199 return last->u.c.component->ts.u.derived->attr.pointer_comp;
4203 if (e->ts.type == BT_CLASS)
4204 return CLASS_DATA (e)->attr.pointer_comp;
4205 else if (e->ts.type == BT_DERIVED)
4206 return e->ts.u.derived->attr.pointer_comp;
4212 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4213 Note: A scalar is not regarded as "simply contiguous" by the standard.
4214 if bool is not strict, some futher checks are done - for instance,
4215 a "(::1)" is accepted. */
4218 gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
4222 gfc_array_ref *ar = NULL;
4223 gfc_ref *ref, *part_ref = NULL;
4225 if (expr->expr_type == EXPR_FUNCTION)
4226 return expr->value.function.esym
4227 ? expr->value.function.esym->result->attr.contiguous : false;
4228 else if (expr->expr_type != EXPR_VARIABLE)
4231 if (expr->rank == 0)
4234 for (ref = expr->ref; ref; ref = ref->next)
4237 return false; /* Array shall be last part-ref. */
4239 if (ref->type == REF_COMPONENT)
4241 else if (ref->type == REF_SUBSTRING)
4243 else if (ref->u.ar.type != AR_ELEMENT)
4247 if ((part_ref && !part_ref->u.c.component->attr.contiguous
4248 && part_ref->u.c.component->attr.pointer)
4249 || (!part_ref && !expr->symtree->n.sym->attr.contiguous
4250 && (expr->symtree->n.sym->attr.pointer
4251 || expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)))
4254 if (!ar || ar->type == AR_FULL)
4257 gcc_assert (ar->type == AR_SECTION);
4259 /* Check for simply contiguous array */
4261 for (i = 0; i < ar->dimen; i++)
4263 if (ar->dimen_type[i] == DIMEN_VECTOR)
4266 if (ar->dimen_type[i] == DIMEN_ELEMENT)
4272 gcc_assert (ar->dimen_type[i] == DIMEN_RANGE);
4275 /* If the previous section was not contiguous, that's an error,
4276 unless we have effective only one element and checking is not
4278 if (!colon && (strict || !ar->start[i] || !ar->end[i]
4279 || ar->start[i]->expr_type != EXPR_CONSTANT
4280 || ar->end[i]->expr_type != EXPR_CONSTANT
4281 || mpz_cmp (ar->start[i]->value.integer,
4282 ar->end[i]->value.integer) != 0))
4285 /* Following the standard, "(::1)" or - if known at compile time -
4286 "(lbound:ubound)" are not simply contigous; if strict
4287 is false, they are regarded as simply contiguous. */
4288 if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT
4289 || ar->stride[i]->ts.type != BT_INTEGER
4290 || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0))
4294 && (strict || ar->start[i]->expr_type != EXPR_CONSTANT
4295 || !ar->as->lower[i]
4296 || ar->as->lower[i]->expr_type != EXPR_CONSTANT
4297 || mpz_cmp (ar->start[i]->value.integer,
4298 ar->as->lower[i]->value.integer) != 0))
4302 && (strict || ar->end[i]->expr_type != EXPR_CONSTANT
4303 || !ar->as->upper[i]
4304 || ar->as->upper[i]->expr_type != EXPR_CONSTANT
4305 || mpz_cmp (ar->end[i]->value.integer,
4306 ar->as->upper[i]->value.integer) != 0))
4314 /* Build call to an intrinsic procedure. The number of arguments has to be
4315 passed (rather than ending the list with a NULL value) because we may
4316 want to add arguments but with a NULL-expression. */
4319 gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
4322 gfc_actual_arglist* atail;
4323 gfc_intrinsic_sym* isym;
4327 isym = gfc_find_function (name);
4330 result = gfc_get_expr ();
4331 result->expr_type = EXPR_FUNCTION;
4332 result->ts = isym->ts;
4333 result->where = where;
4334 result->value.function.name = name;
4335 result->value.function.isym = isym;
4337 va_start (ap, numarg);
4339 for (i = 0; i < numarg; ++i)
4343 atail->next = gfc_get_actual_arglist ();
4344 atail = atail->next;
4347 atail = result->value.function.actual = gfc_get_actual_arglist ();
4349 atail->expr = va_arg (ap, gfc_expr*);
4357 /* Check if an expression may appear in a variable definition context
4358 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
4359 This is called from the various places when resolving
4360 the pieces that make up such a context.
4362 Optionally, a possible error message can be suppressed if context is NULL
4363 and just the return status (SUCCESS / FAILURE) be requested. */
4366 gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
4370 bool check_intentin;
4372 symbol_attribute attr;
4375 if (!pointer && e->expr_type == EXPR_FUNCTION
4376 && e->symtree->n.sym->result->attr.pointer)
4378 if (!(gfc_option.allow_std & GFC_STD_F2008))
4381 gfc_error ("Fortran 2008: Pointer functions in variable definition"
4382 " context (%s) at %L", context, &e->where);
4386 else if (e->expr_type != EXPR_VARIABLE)
4389 gfc_error ("Non-variable expression in variable definition context (%s)"
4390 " at %L", context, &e->where);
4394 gcc_assert (e->symtree);
4395 sym = e->symtree->n.sym;
4397 if (!pointer && sym->attr.flavor == FL_PARAMETER)
4400 gfc_error ("Named constant '%s' in variable definition context (%s)"
4401 " at %L", sym->name, context, &e->where);
4404 if (!pointer && sym->attr.flavor != FL_VARIABLE
4405 && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result)
4406 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
4409 gfc_error ("'%s' in variable definition context (%s) at %L is not"
4410 " a variable", sym->name, context, &e->where);
4414 /* Find out whether the expr is a pointer; this also means following
4415 component references to the last one. */
4416 attr = gfc_expr_attr (e);
4417 is_pointer = (attr.pointer || attr.proc_pointer);
4418 if (pointer && !is_pointer)
4421 gfc_error ("Non-POINTER in pointer association context (%s)"
4422 " at %L", context, &e->where);
4426 /* INTENT(IN) dummy argument. Check this, unless the object itself is
4427 the component of sub-component of a pointer. Obviously,
4428 procedure pointers are of no interest here. */
4429 check_intentin = true;
4430 ptr_component = sym->attr.pointer;
4431 for (ref = e->ref; ref && check_intentin; ref = ref->next)
4433 if (ptr_component && ref->type == REF_COMPONENT)
4434 check_intentin = false;
4435 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
4436 ptr_component = true;
4438 if (check_intentin && sym->attr.intent == INTENT_IN)
4440 if (pointer && is_pointer)
4443 gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
4444 " association context (%s) at %L",
4445 sym->name, context, &e->where);
4448 if (!pointer && !is_pointer)
4451 gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
4452 " definition context (%s) at %L",
4453 sym->name, context, &e->where);
4458 /* PROTECTED and use-associated. */
4459 if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin)
4461 if (pointer && is_pointer)
4464 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4465 " pointer association context (%s) at %L",
4466 sym->name, context, &e->where);
4469 if (!pointer && !is_pointer)
4472 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4473 " variable definition context (%s) at %L",
4474 sym->name, context, &e->where);
4479 /* Variable not assignable from a PURE procedure but appears in
4480 variable definition context. */
4481 if (!pointer && gfc_pure (NULL) && gfc_impure_variable (sym))
4484 gfc_error ("Variable '%s' can not appear in a variable definition"
4485 " context (%s) at %L in PURE procedure",
4486 sym->name, context, &e->where);
4490 if (!pointer && gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
4491 gfc_current_ns->proc_name->attr.implicit_pure = 0;
4493 /* Check variable definition context for associate-names. */
4494 if (!pointer && sym->assoc)
4497 gfc_association_list* assoc;
4499 gcc_assert (sym->assoc->target);
4501 /* If this is a SELECT TYPE temporary (the association is used internally
4502 for SELECT TYPE), silently go over to the target. */
4503 if (sym->attr.select_type_temporary)
4505 gfc_expr* t = sym->assoc->target;
4507 gcc_assert (t->expr_type == EXPR_VARIABLE);
4508 name = t->symtree->name;
4510 if (t->symtree->n.sym->assoc)
4511 assoc = t->symtree->n.sym->assoc;
4520 gcc_assert (name && assoc);
4522 /* Is association to a valid variable? */
4523 if (!assoc->variable)
4527 if (assoc->target->expr_type == EXPR_VARIABLE)
4528 gfc_error ("'%s' at %L associated to vector-indexed target can"
4529 " not be used in a variable definition context (%s)",
4530 name, &e->where, context);
4532 gfc_error ("'%s' at %L associated to expression can"
4533 " not be used in a variable definition context (%s)",
4534 name, &e->where, context);
4539 /* Target must be allowed to appear in a variable definition context. */
4540 if (gfc_check_vardef_context (assoc->target, pointer, NULL) == FAILURE)
4543 gfc_error ("Associate-name '%s' can not appear in a variable"
4544 " definition context (%s) at %L because its target"
4545 " at %L can not, either",
4546 name, context, &e->where,
4547 &assoc->target->where);