Mercurial > hg > CbC > CbC_gcc
diff gcc/fortran/expr.c @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/fortran/expr.c Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,5647 @@ +/* Routines for manipulation of expression nodes. + Copyright (C) 2000-2017 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +<http://www.gnu.org/licenses/>. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "gfortran.h" +#include "arith.h" +#include "match.h" +#include "target-memory.h" /* for gfc_convert_boz */ +#include "constructor.h" + + +/* The following set of functions provide access to gfc_expr* of + various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE. + + There are two functions available elsewhere that provide + slightly different flavours of variables. Namely: + expr.c (gfc_get_variable_expr) + symbol.c (gfc_lval_expr_from_sym) + TODO: Merge these functions, if possible. */ + +/* Get a new expression node. */ + +gfc_expr * +gfc_get_expr (void) +{ + gfc_expr *e; + + e = XCNEW (gfc_expr); + gfc_clear_ts (&e->ts); + e->shape = NULL; + e->ref = NULL; + e->symtree = NULL; + return e; +} + + +/* Get a new expression node that is an array constructor + of given type and kind. */ + +gfc_expr * +gfc_get_array_expr (bt type, int kind, locus *where) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_ARRAY; + e->value.constructor = NULL; + e->rank = 1; + e->shape = NULL; + + e->ts.type = type; + e->ts.kind = kind; + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is the NULL expression. */ + +gfc_expr * +gfc_get_null_expr (locus *where) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_NULL; + e->ts.type = BT_UNKNOWN; + + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is an operator expression node. */ + +gfc_expr * +gfc_get_operator_expr (locus *where, gfc_intrinsic_op op, + gfc_expr *op1, gfc_expr *op2) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_OP; + e->value.op.op = op; + e->value.op.op1 = op1; + e->value.op.op2 = op2; + + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is an structure constructor + of given type and kind. */ + +gfc_expr * +gfc_get_structure_constructor_expr (bt type, int kind, locus *where) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_STRUCTURE; + e->value.constructor = NULL; + + e->ts.type = type; + e->ts.kind = kind; + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is an constant of given type and kind. */ + +gfc_expr * +gfc_get_constant_expr (bt type, int kind, locus *where) +{ + gfc_expr *e; + + if (!where) + gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be " + "NULL"); + + e = gfc_get_expr (); + + e->expr_type = EXPR_CONSTANT; + e->ts.type = type; + e->ts.kind = kind; + e->where = *where; + + switch (type) + { + case BT_INTEGER: + mpz_init (e->value.integer); + break; + + case BT_REAL: + gfc_set_model_kind (kind); + mpfr_init (e->value.real); + break; + + case BT_COMPLEX: + gfc_set_model_kind (kind); + mpc_init2 (e->value.complex, mpfr_get_default_prec()); + break; + + default: + break; + } + + return e; +} + + +/* Get a new expression node that is an string constant. + If no string is passed, a string of len is allocated, + blanked and null-terminated. */ + +gfc_expr * +gfc_get_character_expr (int kind, locus *where, const char *src, int len) +{ + gfc_expr *e; + gfc_char_t *dest; + + if (!src) + { + dest = gfc_get_wide_string (len + 1); + gfc_wide_memset (dest, ' ', len); + dest[len] = '\0'; + } + else + dest = gfc_char_to_widechar (src); + + e = gfc_get_constant_expr (BT_CHARACTER, kind, + where ? where : &gfc_current_locus); + e->value.character.string = dest; + e->value.character.length = len; + + return e; +} + + +/* Get a new expression node that is an integer constant. */ + +gfc_expr * +gfc_get_int_expr (int kind, locus *where, int value) +{ + gfc_expr *p; + p = gfc_get_constant_expr (BT_INTEGER, kind, + where ? where : &gfc_current_locus); + + mpz_set_si (p->value.integer, value); + + return p; +} + + +/* Get a new expression node that is a logical constant. */ + +gfc_expr * +gfc_get_logical_expr (int kind, locus *where, bool value) +{ + gfc_expr *p; + p = gfc_get_constant_expr (BT_LOGICAL, kind, + where ? where : &gfc_current_locus); + + p->value.logical = value; + + return p; +} + + +gfc_expr * +gfc_get_iokind_expr (locus *where, io_kind k) +{ + gfc_expr *e; + + /* Set the types to something compatible with iokind. This is needed to + get through gfc_free_expr later since iokind really has no Basic Type, + BT, of its own. */ + + e = gfc_get_expr (); + e->expr_type = EXPR_CONSTANT; + e->ts.type = BT_LOGICAL; + e->value.iokind = k; + e->where = *where; + + return e; +} + + +/* Given an expression pointer, return a copy of the expression. This + subroutine is recursive. */ + +gfc_expr * +gfc_copy_expr (gfc_expr *p) +{ + gfc_expr *q; + gfc_char_t *s; + char *c; + + if (p == NULL) + return NULL; + + q = gfc_get_expr (); + *q = *p; + + switch (q->expr_type) + { + case EXPR_SUBSTRING: + s = gfc_get_wide_string (p->value.character.length + 1); + q->value.character.string = s; + memcpy (s, p->value.character.string, + (p->value.character.length + 1) * sizeof (gfc_char_t)); + break; + + case EXPR_CONSTANT: + /* Copy target representation, if it exists. */ + if (p->representation.string) + { + c = XCNEWVEC (char, p->representation.length + 1); + q->representation.string = c; + memcpy (c, p->representation.string, (p->representation.length + 1)); + } + + /* Copy the values of any pointer components of p->value. */ + switch (q->ts.type) + { + case BT_INTEGER: + mpz_init_set (q->value.integer, p->value.integer); + break; + + case BT_REAL: + gfc_set_model_kind (q->ts.kind); + mpfr_init (q->value.real); + mpfr_set (q->value.real, p->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + gfc_set_model_kind (q->ts.kind); + mpc_init2 (q->value.complex, mpfr_get_default_prec()); + mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE); + break; + + case BT_CHARACTER: + if (p->representation.string) + q->value.character.string + = gfc_char_to_widechar (q->representation.string); + else + { + s = gfc_get_wide_string (p->value.character.length + 1); + q->value.character.string = s; + + /* This is the case for the C_NULL_CHAR named constant. */ + if (p->value.character.length == 0 + && (p->ts.is_c_interop || p->ts.is_iso_c)) + { + *s = '\0'; + /* Need to set the length to 1 to make sure the NUL + terminator is copied. */ + q->value.character.length = 1; + } + else + memcpy (s, p->value.character.string, + (p->value.character.length + 1) * sizeof (gfc_char_t)); + } + break; + + case BT_HOLLERITH: + case BT_LOGICAL: + case_bt_struct: + case BT_CLASS: + case BT_ASSUMED: + break; /* Already done. */ + + case BT_PROCEDURE: + case BT_VOID: + /* Should never be reached. */ + case BT_UNKNOWN: + gfc_internal_error ("gfc_copy_expr(): Bad expr node"); + /* Not reached. */ + } + + break; + + case EXPR_OP: + switch (q->value.op.op) + { + case INTRINSIC_NOT: + case INTRINSIC_PARENTHESES: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + q->value.op.op1 = gfc_copy_expr (p->value.op.op1); + break; + + default: /* Binary operators. */ + q->value.op.op1 = gfc_copy_expr (p->value.op.op1); + q->value.op.op2 = gfc_copy_expr (p->value.op.op2); + break; + } + + break; + + case EXPR_FUNCTION: + q->value.function.actual = + gfc_copy_actual_arglist (p->value.function.actual); + break; + + case EXPR_COMPCALL: + case EXPR_PPC: + q->value.compcall.actual = + gfc_copy_actual_arglist (p->value.compcall.actual); + q->value.compcall.tbp = p->value.compcall.tbp; + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + q->value.constructor = gfc_constructor_copy (p->value.constructor); + break; + + case EXPR_VARIABLE: + case EXPR_NULL: + break; + } + + q->shape = gfc_copy_shape (p->shape, p->rank); + + q->ref = gfc_copy_ref (p->ref); + + if (p->param_list) + q->param_list = gfc_copy_actual_arglist (p->param_list); + + return q; +} + + +void +gfc_clear_shape (mpz_t *shape, int rank) +{ + int i; + + for (i = 0; i < rank; i++) + mpz_clear (shape[i]); +} + + +void +gfc_free_shape (mpz_t **shape, int rank) +{ + if (*shape == NULL) + return; + + gfc_clear_shape (*shape, rank); + free (*shape); + *shape = NULL; +} + + +/* Workhorse function for gfc_free_expr() that frees everything + beneath an expression node, but not the node itself. This is + useful when we want to simplify a node and replace it with + something else or the expression node belongs to another structure. */ + +static void +free_expr0 (gfc_expr *e) +{ + switch (e->expr_type) + { + case EXPR_CONSTANT: + /* Free any parts of the value that need freeing. */ + switch (e->ts.type) + { + case BT_INTEGER: + mpz_clear (e->value.integer); + break; + + case BT_REAL: + mpfr_clear (e->value.real); + break; + + case BT_CHARACTER: + free (e->value.character.string); + break; + + case BT_COMPLEX: + mpc_clear (e->value.complex); + break; + + default: + break; + } + + /* Free the representation. */ + free (e->representation.string); + + break; + + case EXPR_OP: + if (e->value.op.op1 != NULL) + gfc_free_expr (e->value.op.op1); + if (e->value.op.op2 != NULL) + gfc_free_expr (e->value.op.op2); + break; + + case EXPR_FUNCTION: + gfc_free_actual_arglist (e->value.function.actual); + break; + + case EXPR_COMPCALL: + case EXPR_PPC: + gfc_free_actual_arglist (e->value.compcall.actual); + break; + + case EXPR_VARIABLE: + break; + + case EXPR_ARRAY: + case EXPR_STRUCTURE: + gfc_constructor_free (e->value.constructor); + break; + + case EXPR_SUBSTRING: + free (e->value.character.string); + break; + + case EXPR_NULL: + break; + + default: + gfc_internal_error ("free_expr0(): Bad expr type"); + } + + /* Free a shape array. */ + gfc_free_shape (&e->shape, e->rank); + + gfc_free_ref_list (e->ref); + + gfc_free_actual_arglist (e->param_list); + + memset (e, '\0', sizeof (gfc_expr)); +} + + +/* Free an expression node and everything beneath it. */ + +void +gfc_free_expr (gfc_expr *e) +{ + if (e == NULL) + return; + free_expr0 (e); + free (e); +} + + +/* Free an argument list and everything below it. */ + +void +gfc_free_actual_arglist (gfc_actual_arglist *a1) +{ + gfc_actual_arglist *a2; + + while (a1) + { + a2 = a1->next; + if (a1->expr) + gfc_free_expr (a1->expr); + free (a1); + a1 = a2; + } +} + + +/* Copy an arglist structure and all of the arguments. */ + +gfc_actual_arglist * +gfc_copy_actual_arglist (gfc_actual_arglist *p) +{ + gfc_actual_arglist *head, *tail, *new_arg; + + head = tail = NULL; + + for (; p; p = p->next) + { + new_arg = gfc_get_actual_arglist (); + *new_arg = *p; + + new_arg->expr = gfc_copy_expr (p->expr); + new_arg->next = NULL; + + if (head == NULL) + head = new_arg; + else + tail->next = new_arg; + + tail = new_arg; + } + + return head; +} + + +/* Free a list of reference structures. */ + +void +gfc_free_ref_list (gfc_ref *p) +{ + gfc_ref *q; + int i; + + for (; p; p = q) + { + q = p->next; + + switch (p->type) + { + case REF_ARRAY: + for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + { + gfc_free_expr (p->u.ar.start[i]); + gfc_free_expr (p->u.ar.end[i]); + gfc_free_expr (p->u.ar.stride[i]); + } + + break; + + case REF_SUBSTRING: + gfc_free_expr (p->u.ss.start); + gfc_free_expr (p->u.ss.end); + break; + + case REF_COMPONENT: + break; + } + + free (p); + } +} + + +/* Graft the *src expression onto the *dest subexpression. */ + +void +gfc_replace_expr (gfc_expr *dest, gfc_expr *src) +{ + free_expr0 (dest); + *dest = *src; + free (src); +} + + +/* Try to extract an integer constant from the passed expression node. + Return true if some error occurred, false on success. If REPORT_ERROR + is non-zero, emit error, for positive REPORT_ERROR using gfc_error, + for negative using gfc_error_now. */ + +bool +gfc_extract_int (gfc_expr *expr, int *result, int report_error) +{ + gfc_ref *ref; + + /* A KIND component is a parameter too. The expression for it + is stored in the initializer and should be consistent with + the tests below. */ + if (gfc_expr_attr(expr).pdt_kind) + { + for (ref = expr->ref; ref; ref = ref->next) + { + if (ref->u.c.component->attr.pdt_kind) + expr = ref->u.c.component->initializer; + } + } + + if (expr->expr_type != EXPR_CONSTANT) + { + if (report_error > 0) + gfc_error ("Constant expression required at %C"); + else if (report_error < 0) + gfc_error_now ("Constant expression required at %C"); + return true; + } + + if (expr->ts.type != BT_INTEGER) + { + if (report_error > 0) + gfc_error ("Integer expression required at %C"); + else if (report_error < 0) + gfc_error_now ("Integer expression required at %C"); + return true; + } + + if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0) + || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0)) + { + if (report_error > 0) + gfc_error ("Integer value too large in expression at %C"); + else if (report_error < 0) + gfc_error_now ("Integer value too large in expression at %C"); + return true; + } + + *result = (int) mpz_get_si (expr->value.integer); + + return false; +} + + +/* Recursively copy a list of reference structures. */ + +gfc_ref * +gfc_copy_ref (gfc_ref *src) +{ + gfc_array_ref *ar; + gfc_ref *dest; + + if (src == NULL) + return NULL; + + dest = gfc_get_ref (); + dest->type = src->type; + + switch (src->type) + { + case REF_ARRAY: + ar = gfc_copy_array_ref (&src->u.ar); + dest->u.ar = *ar; + free (ar); + break; + + case REF_COMPONENT: + dest->u.c = src->u.c; + break; + + case REF_SUBSTRING: + dest->u.ss = src->u.ss; + dest->u.ss.start = gfc_copy_expr (src->u.ss.start); + dest->u.ss.end = gfc_copy_expr (src->u.ss.end); + break; + } + + dest->next = gfc_copy_ref (src->next); + + return dest; +} + + +/* Detect whether an expression has any vector index array references. */ + +int +gfc_has_vector_index (gfc_expr *e) +{ + gfc_ref *ref; + int i; + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY) + for (i = 0; i < ref->u.ar.dimen; i++) + if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) + return 1; + return 0; +} + + +/* Copy a shape array. */ + +mpz_t * +gfc_copy_shape (mpz_t *shape, int rank) +{ + mpz_t *new_shape; + int n; + + if (shape == NULL) + return NULL; + + new_shape = gfc_get_shape (rank); + + for (n = 0; n < rank; n++) + mpz_init_set (new_shape[n], shape[n]); + + return new_shape; +} + + +/* Copy a shape array excluding dimension N, where N is an integer + constant expression. Dimensions are numbered in Fortran style -- + starting with ONE. + + So, if the original shape array contains R elements + { s1 ... sN-1 sN sN+1 ... sR-1 sR} + the result contains R-1 elements: + { s1 ... sN-1 sN+1 ... sR-1} + + If anything goes wrong -- N is not a constant, its value is out + of range -- or anything else, just returns NULL. */ + +mpz_t * +gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim) +{ + mpz_t *new_shape, *s; + int i, n; + + if (shape == NULL + || rank <= 1 + || dim == NULL + || dim->expr_type != EXPR_CONSTANT + || dim->ts.type != BT_INTEGER) + return NULL; + + n = mpz_get_si (dim->value.integer); + n--; /* Convert to zero based index. */ + if (n < 0 || n >= rank) + return NULL; + + s = new_shape = gfc_get_shape (rank - 1); + + for (i = 0; i < rank; i++) + { + if (i == n) + continue; + mpz_init_set (*s, shape[i]); + s++; + } + + return new_shape; +} + + +/* Return the maximum kind of two expressions. In general, higher + kind numbers mean more precision for numeric types. */ + +int +gfc_kind_max (gfc_expr *e1, gfc_expr *e2) +{ + return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind; +} + + +/* Returns nonzero if the type is numeric, zero otherwise. */ + +static int +numeric_type (bt type) +{ + return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER; +} + + +/* Returns nonzero if the typespec is a numeric type, zero otherwise. */ + +int +gfc_numeric_ts (gfc_typespec *ts) +{ + return numeric_type (ts->type); +} + + +/* Return an expression node with an optional argument list attached. + A variable number of gfc_expr pointers are strung together in an + argument list with a NULL pointer terminating the list. */ + +gfc_expr * +gfc_build_conversion (gfc_expr *e) +{ + gfc_expr *p; + + p = gfc_get_expr (); + p->expr_type = EXPR_FUNCTION; + p->symtree = NULL; + p->value.function.actual = gfc_get_actual_arglist (); + p->value.function.actual->expr = e; + + return p; +} + + +/* Given an expression node with some sort of numeric binary + expression, insert type conversions required to make the operands + have the same type. Conversion warnings are disabled if wconversion + is set to 0. + + The exception is that the operands of an exponential don't have to + have the same type. If possible, the base is promoted to the type + of the exponent. For example, 1**2.3 becomes 1.0**2.3, but + 1.0**2 stays as it is. */ + +void +gfc_type_convert_binary (gfc_expr *e, int wconversion) +{ + gfc_expr *op1, *op2; + + op1 = e->value.op.op1; + op2 = e->value.op.op2; + + if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN) + { + gfc_clear_ts (&e->ts); + return; + } + + /* Kind conversions of same type. */ + if (op1->ts.type == op2->ts.type) + { + if (op1->ts.kind == op2->ts.kind) + { + /* No type conversions. */ + e->ts = op1->ts; + goto done; + } + + if (op1->ts.kind > op2->ts.kind) + gfc_convert_type_warn (op2, &op1->ts, 2, wconversion); + else + gfc_convert_type_warn (op1, &op2->ts, 2, wconversion); + + e->ts = op1->ts; + goto done; + } + + /* Integer combined with real or complex. */ + if (op2->ts.type == BT_INTEGER) + { + e->ts = op1->ts; + + /* Special case for ** operator. */ + if (e->value.op.op == INTRINSIC_POWER) + goto done; + + gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); + goto done; + } + + if (op1->ts.type == BT_INTEGER) + { + e->ts = op2->ts; + gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); + goto done; + } + + /* Real combined with complex. */ + e->ts.type = BT_COMPLEX; + if (op1->ts.kind > op2->ts.kind) + e->ts.kind = op1->ts.kind; + else + e->ts.kind = op2->ts.kind; + if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind) + gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); + if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind) + gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); + +done: + return; +} + + +/* Determine if an expression is constant in the sense of F08:7.1.12. + * This function expects that the expression has already been simplified. */ + +bool +gfc_is_constant_expr (gfc_expr *e) +{ + gfc_constructor *c; + gfc_actual_arglist *arg; + + if (e == NULL) + return true; + + switch (e->expr_type) + { + case EXPR_OP: + return (gfc_is_constant_expr (e->value.op.op1) + && (e->value.op.op2 == NULL + || gfc_is_constant_expr (e->value.op.op2))); + + case EXPR_VARIABLE: + /* The only context in which this can occur is in a parameterized + derived type declaration, so returning true is OK. */ + if (e->symtree->n.sym->attr.pdt_len + || e->symtree->n.sym->attr.pdt_kind) + return true; + return false; + + case EXPR_FUNCTION: + case EXPR_PPC: + case EXPR_COMPCALL: + gcc_assert (e->symtree || e->value.function.esym + || e->value.function.isym); + + /* Call to intrinsic with at least one argument. */ + if (e->value.function.isym && e->value.function.actual) + { + for (arg = e->value.function.actual; arg; arg = arg->next) + if (!gfc_is_constant_expr (arg->expr)) + return false; + } + + if (e->value.function.isym + && (e->value.function.isym->elemental + || e->value.function.isym->pure + || e->value.function.isym->inquiry + || e->value.function.isym->transformational)) + return true; + + return false; + + case EXPR_CONSTANT: + case EXPR_NULL: + return true; + + case EXPR_SUBSTRING: + return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start) + && gfc_is_constant_expr (e->ref->u.ss.end)); + + case EXPR_ARRAY: + case EXPR_STRUCTURE: + c = gfc_constructor_first (e->value.constructor); + if ((e->expr_type == EXPR_ARRAY) && c && c->iterator) + return gfc_constant_ac (e); + + for (; c; c = gfc_constructor_next (c)) + if (!gfc_is_constant_expr (c->expr)) + return false; + + return true; + + + default: + gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type"); + return false; + } +} + + +/* Is true if an array reference is followed by a component or substring + reference. */ +bool +is_subref_array (gfc_expr * e) +{ + gfc_ref * ref; + bool seen_array; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + if (e->symtree->n.sym->attr.subref_array_pointer) + return true; + + if (e->symtree->n.sym->ts.type == BT_CLASS + && e->symtree->n.sym->attr.dummy + && CLASS_DATA (e->symtree->n.sym)->attr.class_pointer) + return true; + + seen_array = false; + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY + && ref->u.ar.type != AR_ELEMENT) + seen_array = true; + + if (seen_array + && ref->type != REF_ARRAY) + return seen_array; + } + return false; +} + + +/* Try to collapse intrinsic expressions. */ + +static bool +simplify_intrinsic_op (gfc_expr *p, int type) +{ + gfc_intrinsic_op op; + gfc_expr *op1, *op2, *result; + + if (p->value.op.op == INTRINSIC_USER) + return true; + + op1 = p->value.op.op1; + op2 = p->value.op.op2; + op = p->value.op.op; + + if (!gfc_simplify_expr (op1, type)) + return false; + if (!gfc_simplify_expr (op2, type)) + return false; + + if (!gfc_is_constant_expr (op1) + || (op2 != NULL && !gfc_is_constant_expr (op2))) + return true; + + /* Rip p apart. */ + p->value.op.op1 = NULL; + p->value.op.op2 = NULL; + + switch (op) + { + case INTRINSIC_PARENTHESES: + result = gfc_parentheses (op1); + break; + + case INTRINSIC_UPLUS: + result = gfc_uplus (op1); + break; + + case INTRINSIC_UMINUS: + result = gfc_uminus (op1); + break; + + case INTRINSIC_PLUS: + result = gfc_add (op1, op2); + break; + + case INTRINSIC_MINUS: + result = gfc_subtract (op1, op2); + break; + + case INTRINSIC_TIMES: + result = gfc_multiply (op1, op2); + break; + + case INTRINSIC_DIVIDE: + result = gfc_divide (op1, op2); + break; + + case INTRINSIC_POWER: + result = gfc_power (op1, op2); + break; + + case INTRINSIC_CONCAT: + result = gfc_concat (op1, op2); + break; + + case INTRINSIC_EQ: + case INTRINSIC_EQ_OS: + result = gfc_eq (op1, op2, op); + break; + + case INTRINSIC_NE: + case INTRINSIC_NE_OS: + result = gfc_ne (op1, op2, op); + break; + + case INTRINSIC_GT: + case INTRINSIC_GT_OS: + result = gfc_gt (op1, op2, op); + break; + + case INTRINSIC_GE: + case INTRINSIC_GE_OS: + result = gfc_ge (op1, op2, op); + break; + + case INTRINSIC_LT: + case INTRINSIC_LT_OS: + result = gfc_lt (op1, op2, op); + break; + + case INTRINSIC_LE: + case INTRINSIC_LE_OS: + result = gfc_le (op1, op2, op); + break; + + case INTRINSIC_NOT: + result = gfc_not (op1); + break; + + case INTRINSIC_AND: + result = gfc_and (op1, op2); + break; + + case INTRINSIC_OR: + result = gfc_or (op1, op2); + break; + + case INTRINSIC_EQV: + result = gfc_eqv (op1, op2); + break; + + case INTRINSIC_NEQV: + result = gfc_neqv (op1, op2); + break; + + default: + gfc_internal_error ("simplify_intrinsic_op(): Bad operator"); + } + + if (result == NULL) + { + gfc_free_expr (op1); + gfc_free_expr (op2); + return false; + } + + result->rank = p->rank; + result->where = p->where; + gfc_replace_expr (p, result); + + return true; +} + + +/* Subroutine to simplify constructor expressions. Mutually recursive + with gfc_simplify_expr(). */ + +static bool +simplify_constructor (gfc_constructor_base base, int type) +{ + gfc_constructor *c; + gfc_expr *p; + + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + { + if (c->iterator + && (!gfc_simplify_expr(c->iterator->start, type) + || !gfc_simplify_expr (c->iterator->end, type) + || !gfc_simplify_expr (c->iterator->step, type))) + return false; + + if (c->expr) + { + /* Try and simplify a copy. Replace the original if successful + but keep going through the constructor at all costs. Not + doing so can make a dog's dinner of complicated things. */ + p = gfc_copy_expr (c->expr); + + if (!gfc_simplify_expr (p, type)) + { + gfc_free_expr (p); + continue; + } + + gfc_replace_expr (c->expr, p); + } + } + + return true; +} + + +/* Pull a single array element out of an array constructor. */ + +static bool +find_array_element (gfc_constructor_base base, gfc_array_ref *ar, + gfc_constructor **rval) +{ + unsigned long nelemen; + int i; + mpz_t delta; + mpz_t offset; + mpz_t span; + mpz_t tmp; + gfc_constructor *cons; + gfc_expr *e; + bool t; + + t = true; + e = NULL; + + mpz_init_set_ui (offset, 0); + mpz_init (delta); + mpz_init (tmp); + mpz_init_set_ui (span, 1); + for (i = 0; i < ar->dimen; i++) + { + if (!gfc_reduce_init_expr (ar->as->lower[i]) + || !gfc_reduce_init_expr (ar->as->upper[i])) + { + t = false; + cons = NULL; + goto depart; + } + + e = ar->start[i]; + if (e->expr_type != EXPR_CONSTANT) + { + cons = NULL; + goto depart; + } + + gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT + && ar->as->lower[i]->expr_type == EXPR_CONSTANT); + + /* Check the bounds. */ + if ((ar->as->upper[i] + && mpz_cmp (e->value.integer, + ar->as->upper[i]->value.integer) > 0) + || (mpz_cmp (e->value.integer, + ar->as->lower[i]->value.integer) < 0)) + { + gfc_error ("Index in dimension %d is out of bounds " + "at %L", i + 1, &ar->c_where[i]); + cons = NULL; + t = false; + goto depart; + } + + mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer); + mpz_mul (delta, delta, span); + mpz_add (offset, offset, delta); + + mpz_set_ui (tmp, 1); + mpz_add (tmp, tmp, ar->as->upper[i]->value.integer); + mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer); + mpz_mul (span, span, tmp); + } + + for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset); + cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--) + { + if (cons->iterator) + { + cons = NULL; + goto depart; + } + } + +depart: + mpz_clear (delta); + mpz_clear (offset); + mpz_clear (span); + mpz_clear (tmp); + *rval = cons; + return t; +} + + +/* Find a component of a structure constructor. */ + +static gfc_constructor * +find_component_ref (gfc_constructor_base base, gfc_ref *ref) +{ + gfc_component *pick = ref->u.c.component; + gfc_constructor *c = gfc_constructor_first (base); + + gfc_symbol *dt = ref->u.c.sym; + int ext = dt->attr.extension; + + /* For extended types, check if the desired component is in one of the + * parent types. */ + while (ext > 0 && gfc_find_component (dt->components->ts.u.derived, + pick->name, true, true, NULL)) + { + dt = dt->components->ts.u.derived; + c = gfc_constructor_first (c->expr->value.constructor); + ext--; + } + + gfc_component *comp = dt->components; + while (comp != pick) + { + comp = comp->next; + c = gfc_constructor_next (c); + } + + return c; +} + + +/* Replace an expression with the contents of a constructor, removing + the subobject reference in the process. */ + +static void +remove_subobject_ref (gfc_expr *p, gfc_constructor *cons) +{ + gfc_expr *e; + + if (cons) + { + e = cons->expr; + cons->expr = NULL; + } + else + e = gfc_copy_expr (p); + e->ref = p->ref->next; + p->ref->next = NULL; + gfc_replace_expr (p, e); +} + + +/* Pull an array section out of an array constructor. */ + +static bool +find_array_section (gfc_expr *expr, gfc_ref *ref) +{ + int idx; + int rank; + int d; + int shape_i; + int limit; + long unsigned one = 1; + bool incr_ctr; + mpz_t start[GFC_MAX_DIMENSIONS]; + mpz_t end[GFC_MAX_DIMENSIONS]; + mpz_t stride[GFC_MAX_DIMENSIONS]; + mpz_t delta[GFC_MAX_DIMENSIONS]; + mpz_t ctr[GFC_MAX_DIMENSIONS]; + mpz_t delta_mpz; + mpz_t tmp_mpz; + mpz_t nelts; + mpz_t ptr; + gfc_constructor_base base; + gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS]; + gfc_expr *begin; + gfc_expr *finish; + gfc_expr *step; + gfc_expr *upper; + gfc_expr *lower; + bool t; + + t = true; + + base = expr->value.constructor; + expr->value.constructor = NULL; + + rank = ref->u.ar.as->rank; + + if (expr->shape == NULL) + expr->shape = gfc_get_shape (rank); + + mpz_init_set_ui (delta_mpz, one); + mpz_init_set_ui (nelts, one); + mpz_init (tmp_mpz); + + /* Do the initialization now, so that we can cleanup without + keeping track of where we were. */ + for (d = 0; d < rank; d++) + { + mpz_init (delta[d]); + mpz_init (start[d]); + mpz_init (end[d]); + mpz_init (ctr[d]); + mpz_init (stride[d]); + vecsub[d] = NULL; + } + + /* Build the counters to clock through the array reference. */ + shape_i = 0; + for (d = 0; d < rank; d++) + { + /* Make this stretch of code easier on the eye! */ + begin = ref->u.ar.start[d]; + finish = ref->u.ar.end[d]; + step = ref->u.ar.stride[d]; + lower = ref->u.ar.as->lower[d]; + upper = ref->u.ar.as->upper[d]; + + if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ + { + gfc_constructor *ci; + gcc_assert (begin); + + if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin)) + { + t = false; + goto cleanup; + } + + gcc_assert (begin->rank == 1); + /* Zero-sized arrays have no shape and no elements, stop early. */ + if (!begin->shape) + { + mpz_init_set_ui (nelts, 0); + break; + } + + vecsub[d] = gfc_constructor_first (begin->value.constructor); + mpz_set (ctr[d], vecsub[d]->expr->value.integer); + mpz_mul (nelts, nelts, begin->shape[0]); + mpz_set (expr->shape[shape_i++], begin->shape[0]); + + /* Check bounds. */ + for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci)) + { + if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0 + || mpz_cmp (ci->expr->value.integer, + lower->value.integer) < 0) + { + gfc_error ("index in dimension %d is out of bounds " + "at %L", d + 1, &ref->u.ar.c_where[d]); + t = false; + goto cleanup; + } + } + } + else + { + if ((begin && begin->expr_type != EXPR_CONSTANT) + || (finish && finish->expr_type != EXPR_CONSTANT) + || (step && step->expr_type != EXPR_CONSTANT)) + { + t = false; + goto cleanup; + } + + /* Obtain the stride. */ + if (step) + mpz_set (stride[d], step->value.integer); + else + mpz_set_ui (stride[d], one); + + if (mpz_cmp_ui (stride[d], 0) == 0) + mpz_set_ui (stride[d], one); + + /* Obtain the start value for the index. */ + if (begin) + mpz_set (start[d], begin->value.integer); + else + mpz_set (start[d], lower->value.integer); + + mpz_set (ctr[d], start[d]); + + /* Obtain the end value for the index. */ + if (finish) + mpz_set (end[d], finish->value.integer); + else + mpz_set (end[d], upper->value.integer); + + /* Separate 'if' because elements sometimes arrive with + non-null end. */ + if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT) + mpz_set (end [d], begin->value.integer); + + /* Check the bounds. */ + if (mpz_cmp (ctr[d], upper->value.integer) > 0 + || mpz_cmp (end[d], upper->value.integer) > 0 + || mpz_cmp (ctr[d], lower->value.integer) < 0 + || mpz_cmp (end[d], lower->value.integer) < 0) + { + gfc_error ("index in dimension %d is out of bounds " + "at %L", d + 1, &ref->u.ar.c_where[d]); + t = false; + goto cleanup; + } + + /* Calculate the number of elements and the shape. */ + mpz_set (tmp_mpz, stride[d]); + mpz_add (tmp_mpz, end[d], tmp_mpz); + mpz_sub (tmp_mpz, tmp_mpz, ctr[d]); + mpz_div (tmp_mpz, tmp_mpz, stride[d]); + mpz_mul (nelts, nelts, tmp_mpz); + + /* An element reference reduces the rank of the expression; don't + add anything to the shape array. */ + if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT) + mpz_set (expr->shape[shape_i++], tmp_mpz); + } + + /* Calculate the 'stride' (=delta) for conversion of the + counter values into the index along the constructor. */ + mpz_set (delta[d], delta_mpz); + mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer); + mpz_add_ui (tmp_mpz, tmp_mpz, one); + mpz_mul (delta_mpz, delta_mpz, tmp_mpz); + } + + mpz_init (ptr); + cons = gfc_constructor_first (base); + + /* Now clock through the array reference, calculating the index in + the source constructor and transferring the elements to the new + constructor. */ + for (idx = 0; idx < (int) mpz_get_si (nelts); idx++) + { + mpz_init_set_ui (ptr, 0); + + incr_ctr = true; + for (d = 0; d < rank; d++) + { + mpz_set (tmp_mpz, ctr[d]); + mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer); + mpz_mul (tmp_mpz, tmp_mpz, delta[d]); + mpz_add (ptr, ptr, tmp_mpz); + + if (!incr_ctr) continue; + + if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ + { + gcc_assert(vecsub[d]); + + if (!gfc_constructor_next (vecsub[d])) + vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor); + else + { + vecsub[d] = gfc_constructor_next (vecsub[d]); + incr_ctr = false; + } + mpz_set (ctr[d], vecsub[d]->expr->value.integer); + } + else + { + mpz_add (ctr[d], ctr[d], stride[d]); + + if (mpz_cmp_ui (stride[d], 0) > 0 + ? mpz_cmp (ctr[d], end[d]) > 0 + : mpz_cmp (ctr[d], end[d]) < 0) + mpz_set (ctr[d], start[d]); + else + incr_ctr = false; + } + } + + limit = mpz_get_ui (ptr); + if (limit >= flag_max_array_constructor) + { + gfc_error ("The number of elements in the array constructor " + "at %L requires an increase of the allowed %d " + "upper limit. See -fmax-array-constructor " + "option", &expr->where, flag_max_array_constructor); + return false; + } + + cons = gfc_constructor_lookup (base, limit); + gcc_assert (cons); + gfc_constructor_append_expr (&expr->value.constructor, + gfc_copy_expr (cons->expr), NULL); + } + + mpz_clear (ptr); + +cleanup: + + mpz_clear (delta_mpz); + mpz_clear (tmp_mpz); + mpz_clear (nelts); + for (d = 0; d < rank; d++) + { + mpz_clear (delta[d]); + mpz_clear (start[d]); + mpz_clear (end[d]); + mpz_clear (ctr[d]); + mpz_clear (stride[d]); + } + gfc_constructor_free (base); + return t; +} + +/* Pull a substring out of an expression. */ + +static bool +find_substring_ref (gfc_expr *p, gfc_expr **newp) +{ + int end; + int start; + int length; + gfc_char_t *chr; + + if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT + || p->ref->u.ss.end->expr_type != EXPR_CONSTANT) + return false; + + *newp = gfc_copy_expr (p); + free ((*newp)->value.character.string); + + end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer); + start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer); + length = end - start + 1; + + chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1); + (*newp)->value.character.length = length; + memcpy (chr, &p->value.character.string[start - 1], + length * sizeof (gfc_char_t)); + chr[length] = '\0'; + return true; +} + + + +/* Simplify a subobject reference of a constructor. This occurs when + parameter variable values are substituted. */ + +static bool +simplify_const_ref (gfc_expr *p) +{ + gfc_constructor *cons, *c; + gfc_expr *newp; + gfc_ref *last_ref; + + while (p->ref) + { + switch (p->ref->type) + { + case REF_ARRAY: + switch (p->ref->u.ar.type) + { + case AR_ELEMENT: + /* <type/kind spec>, parameter :: x(<int>) = scalar_expr + will generate this. */ + if (p->expr_type != EXPR_ARRAY) + { + remove_subobject_ref (p, NULL); + break; + } + if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons)) + return false; + + if (!cons) + return true; + + remove_subobject_ref (p, cons); + break; + + case AR_SECTION: + if (!find_array_section (p, p->ref)) + return false; + p->ref->u.ar.type = AR_FULL; + + /* Fall through. */ + + case AR_FULL: + if (p->ref->next != NULL + && (p->ts.type == BT_CHARACTER || gfc_bt_struct (p->ts.type))) + { + for (c = gfc_constructor_first (p->value.constructor); + c; c = gfc_constructor_next (c)) + { + c->expr->ref = gfc_copy_ref (p->ref->next); + if (!simplify_const_ref (c->expr)) + return false; + } + + if (gfc_bt_struct (p->ts.type) + && p->ref->next + && (c = gfc_constructor_first (p->value.constructor))) + { + /* There may have been component references. */ + p->ts = c->expr->ts; + } + + last_ref = p->ref; + for (; last_ref->next; last_ref = last_ref->next) {}; + + if (p->ts.type == BT_CHARACTER + && last_ref->type == REF_SUBSTRING) + { + /* If this is a CHARACTER array and we possibly took + a substring out of it, update the type-spec's + character length according to the first element + (as all should have the same length). */ + int string_len; + if ((c = gfc_constructor_first (p->value.constructor))) + { + const gfc_expr* first = c->expr; + gcc_assert (first->expr_type == EXPR_CONSTANT); + gcc_assert (first->ts.type == BT_CHARACTER); + string_len = first->value.character.length; + } + else + string_len = 0; + + if (!p->ts.u.cl) + p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns, + NULL); + else + gfc_free_expr (p->ts.u.cl->length); + + p->ts.u.cl->length + = gfc_get_int_expr (gfc_default_integer_kind, + NULL, string_len); + } + } + gfc_free_ref_list (p->ref); + p->ref = NULL; + break; + + default: + return true; + } + + break; + + case REF_COMPONENT: + cons = find_component_ref (p->value.constructor, p->ref); + remove_subobject_ref (p, cons); + break; + + case REF_SUBSTRING: + if (!find_substring_ref (p, &newp)) + return false; + + gfc_replace_expr (p, newp); + gfc_free_ref_list (p->ref); + p->ref = NULL; + break; + } + } + + return true; +} + + +/* Simplify a chain of references. */ + +static bool +simplify_ref_chain (gfc_ref *ref, int type) +{ + int n; + + for (; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + for (n = 0; n < ref->u.ar.dimen; n++) + { + if (!gfc_simplify_expr (ref->u.ar.start[n], type)) + return false; + if (!gfc_simplify_expr (ref->u.ar.end[n], type)) + return false; + if (!gfc_simplify_expr (ref->u.ar.stride[n], type)) + return false; + } + break; + + case REF_SUBSTRING: + if (!gfc_simplify_expr (ref->u.ss.start, type)) + return false; + if (!gfc_simplify_expr (ref->u.ss.end, type)) + return false; + break; + + default: + break; + } + } + return true; +} + + +/* Try to substitute the value of a parameter variable. */ + +static bool +simplify_parameter_variable (gfc_expr *p, int type) +{ + gfc_expr *e; + bool t; + + e = gfc_copy_expr (p->symtree->n.sym->value); + if (e == NULL) + return false; + + e->rank = p->rank; + + /* Do not copy subobject refs for constant. */ + if (e->expr_type != EXPR_CONSTANT && p->ref != NULL) + e->ref = gfc_copy_ref (p->ref); + t = gfc_simplify_expr (e, type); + + /* Only use the simplification if it eliminated all subobject references. */ + if (t && !e->ref) + gfc_replace_expr (p, e); + else + gfc_free_expr (e); + + return t; +} + +/* Given an expression, simplify it by collapsing constant + expressions. Most simplification takes place when the expression + tree is being constructed. If an intrinsic function is simplified + at some point, we get called again to collapse the result against + other constants. + + We work by recursively simplifying expression nodes, simplifying + intrinsic functions where possible, which can lead to further + constant collapsing. If an operator has constant operand(s), we + rip the expression apart, and rebuild it, hoping that it becomes + something simpler. + + The expression type is defined for: + 0 Basic expression parsing + 1 Simplifying array constructors -- will substitute + iterator values. + Returns false on error, true otherwise. + NOTE: Will return true even if the expression can not be simplified. */ + +bool +gfc_simplify_expr (gfc_expr *p, int type) +{ + gfc_actual_arglist *ap; + + if (p == NULL) + return true; + + switch (p->expr_type) + { + case EXPR_CONSTANT: + case EXPR_NULL: + break; + + case EXPR_FUNCTION: + for (ap = p->value.function.actual; ap; ap = ap->next) + if (!gfc_simplify_expr (ap->expr, type)) + return false; + + if (p->value.function.isym != NULL + && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR) + return false; + + break; + + case EXPR_SUBSTRING: + if (!simplify_ref_chain (p->ref, type)) + return false; + + if (gfc_is_constant_expr (p)) + { + gfc_char_t *s; + int start, end; + + start = 0; + if (p->ref && p->ref->u.ss.start) + { + gfc_extract_int (p->ref->u.ss.start, &start); + start--; /* Convert from one-based to zero-based. */ + } + + end = p->value.character.length; + if (p->ref && p->ref->u.ss.end) + gfc_extract_int (p->ref->u.ss.end, &end); + + if (end < start) + end = start; + + s = gfc_get_wide_string (end - start + 2); + memcpy (s, p->value.character.string + start, + (end - start) * sizeof (gfc_char_t)); + s[end - start + 1] = '\0'; /* TODO: C-style string. */ + free (p->value.character.string); + p->value.character.string = s; + p->value.character.length = end - start; + p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + p->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + NULL, + p->value.character.length); + gfc_free_ref_list (p->ref); + p->ref = NULL; + p->expr_type = EXPR_CONSTANT; + } + break; + + case EXPR_OP: + if (!simplify_intrinsic_op (p, type)) + return false; + break; + + case EXPR_VARIABLE: + /* Only substitute array parameter variables if we are in an + initialization expression, or we want a subsection. */ + if (p->symtree->n.sym->attr.flavor == FL_PARAMETER + && (gfc_init_expr_flag || p->ref + || p->symtree->n.sym->value->expr_type != EXPR_ARRAY)) + { + if (!simplify_parameter_variable (p, type)) + return false; + break; + } + + if (type == 1) + { + gfc_simplify_iterator_var (p); + } + + /* Simplify subcomponent references. */ + if (!simplify_ref_chain (p->ref, type)) + return false; + + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + if (!simplify_ref_chain (p->ref, type)) + return false; + + if (!simplify_constructor (p->value.constructor, type)) + return false; + + if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY + && p->ref->u.ar.type == AR_FULL) + gfc_expand_constructor (p, false); + + if (!simplify_const_ref (p)) + return false; + + break; + + case EXPR_COMPCALL: + case EXPR_PPC: + break; + } + + return true; +} + + +/* Returns the type of an expression with the exception that iterator + variables are automatically integers no matter what else they may + be declared as. */ + +static bt +et0 (gfc_expr *e) +{ + if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e)) + return BT_INTEGER; + + return e->ts.type; +} + + +/* Scalarize an expression for an elemental intrinsic call. */ + +static bool +scalarize_intrinsic_call (gfc_expr *e) +{ + gfc_actual_arglist *a, *b; + gfc_constructor_base ctor; + gfc_constructor *args[5] = {}; /* Avoid uninitialized warnings. */ + gfc_constructor *ci, *new_ctor; + gfc_expr *expr, *old; + int n, i, rank[5], array_arg; + + /* Find which, if any, arguments are arrays. Assume that the old + expression carries the type information and that the first arg + that is an array expression carries all the shape information.*/ + n = array_arg = 0; + a = e->value.function.actual; + for (; a; a = a->next) + { + n++; + if (!a->expr || a->expr->expr_type != EXPR_ARRAY) + continue; + array_arg = n; + expr = gfc_copy_expr (a->expr); + break; + } + + if (!array_arg) + return false; + + old = gfc_copy_expr (e); + + gfc_constructor_free (expr->value.constructor); + expr->value.constructor = NULL; + expr->ts = old->ts; + expr->where = old->where; + expr->expr_type = EXPR_ARRAY; + + /* Copy the array argument constructors into an array, with nulls + for the scalars. */ + n = 0; + a = old->value.function.actual; + for (; a; a = a->next) + { + /* Check that this is OK for an initialization expression. */ + if (a->expr && !gfc_check_init_expr (a->expr)) + goto cleanup; + + rank[n] = 0; + if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE) + { + rank[n] = a->expr->rank; + ctor = a->expr->symtree->n.sym->value->value.constructor; + args[n] = gfc_constructor_first (ctor); + } + else if (a->expr && a->expr->expr_type == EXPR_ARRAY) + { + if (a->expr->rank) + rank[n] = a->expr->rank; + else + rank[n] = 1; + ctor = gfc_constructor_copy (a->expr->value.constructor); + args[n] = gfc_constructor_first (ctor); + } + else + args[n] = NULL; + + n++; + } + + + /* Using the array argument as the master, step through the array + calling the function for each element and advancing the array + constructors together. */ + for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci)) + { + new_ctor = gfc_constructor_append_expr (&expr->value.constructor, + gfc_copy_expr (old), NULL); + + gfc_free_actual_arglist (new_ctor->expr->value.function.actual); + a = NULL; + b = old->value.function.actual; + for (i = 0; i < n; i++) + { + if (a == NULL) + new_ctor->expr->value.function.actual + = a = gfc_get_actual_arglist (); + else + { + a->next = gfc_get_actual_arglist (); + a = a->next; + } + + if (args[i]) + a->expr = gfc_copy_expr (args[i]->expr); + else + a->expr = gfc_copy_expr (b->expr); + + b = b->next; + } + + /* Simplify the function calls. If the simplification fails, the + error will be flagged up down-stream or the library will deal + with it. */ + gfc_simplify_expr (new_ctor->expr, 0); + + for (i = 0; i < n; i++) + if (args[i]) + args[i] = gfc_constructor_next (args[i]); + + for (i = 1; i < n; i++) + if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL) + || (args[i] == NULL && args[array_arg - 1] != NULL))) + goto compliance; + } + + free_expr0 (e); + *e = *expr; + /* Free "expr" but not the pointers it contains. */ + free (expr); + gfc_free_expr (old); + return true; + +compliance: + gfc_error_now ("elemental function arguments at %C are not compliant"); + +cleanup: + gfc_free_expr (expr); + gfc_free_expr (old); + return false; +} + + +static bool +check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *)) +{ + gfc_expr *op1 = e->value.op.op1; + gfc_expr *op2 = e->value.op.op2; + + if (!(*check_function)(op1)) + return false; + + switch (e->value.op.op) + { + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + if (!numeric_type (et0 (op1))) + goto not_numeric; + break; + + case INTRINSIC_EQ: + case INTRINSIC_EQ_OS: + case INTRINSIC_NE: + case INTRINSIC_NE_OS: + case INTRINSIC_GT: + case INTRINSIC_GT_OS: + case INTRINSIC_GE: + case INTRINSIC_GE_OS: + case INTRINSIC_LT: + case INTRINSIC_LT_OS: + case INTRINSIC_LE: + case INTRINSIC_LE_OS: + if (!(*check_function)(op2)) + return false; + + if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER) + && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2)))) + { + gfc_error ("Numeric or CHARACTER operands are required in " + "expression at %L", &e->where); + return false; + } + break; + + case INTRINSIC_PLUS: + case INTRINSIC_MINUS: + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + case INTRINSIC_POWER: + if (!(*check_function)(op2)) + return false; + + if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2))) + goto not_numeric; + + break; + + case INTRINSIC_CONCAT: + if (!(*check_function)(op2)) + return false; + + if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER) + { + gfc_error ("Concatenation operator in expression at %L " + "must have two CHARACTER operands", &op1->where); + return false; + } + + if (op1->ts.kind != op2->ts.kind) + { + gfc_error ("Concat operator at %L must concatenate strings of the " + "same kind", &e->where); + return false; + } + + break; + + case INTRINSIC_NOT: + if (et0 (op1) != BT_LOGICAL) + { + gfc_error (".NOT. operator in expression at %L must have a LOGICAL " + "operand", &op1->where); + return false; + } + + break; + + case INTRINSIC_AND: + case INTRINSIC_OR: + case INTRINSIC_EQV: + case INTRINSIC_NEQV: + if (!(*check_function)(op2)) + return false; + + if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL) + { + gfc_error ("LOGICAL operands are required in expression at %L", + &e->where); + return false; + } + + break; + + case INTRINSIC_PARENTHESES: + break; + + default: + gfc_error ("Only intrinsic operators can be used in expression at %L", + &e->where); + return false; + } + + return true; + +not_numeric: + gfc_error ("Numeric operands are required in expression at %L", &e->where); + + return false; +} + +/* F2003, 7.1.7 (3): In init expression, allocatable components + must not be data-initialized. */ +static bool +check_alloc_comp_init (gfc_expr *e) +{ + gfc_component *comp; + gfc_constructor *ctor; + + gcc_assert (e->expr_type == EXPR_STRUCTURE); + gcc_assert (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS); + + for (comp = e->ts.u.derived->components, + ctor = gfc_constructor_first (e->value.constructor); + comp; comp = comp->next, ctor = gfc_constructor_next (ctor)) + { + if (comp->attr.allocatable && ctor->expr + && ctor->expr->expr_type != EXPR_NULL) + { + gfc_error ("Invalid initialization expression for ALLOCATABLE " + "component %qs in structure constructor at %L", + comp->name, &ctor->expr->where); + return false; + } + } + + return true; +} + +static match +check_init_expr_arguments (gfc_expr *e) +{ + gfc_actual_arglist *ap; + + for (ap = e->value.function.actual; ap; ap = ap->next) + if (!gfc_check_init_expr (ap->expr)) + return MATCH_ERROR; + + return MATCH_YES; +} + +static bool check_restricted (gfc_expr *); + +/* F95, 7.1.6.1, Initialization expressions, (7) + F2003, 7.1.7 Initialization expression, (8) */ + +static match +check_inquiry (gfc_expr *e, int not_restricted) +{ + const char *name; + const char *const *functions; + + static const char *const inquiry_func_f95[] = { + "lbound", "shape", "size", "ubound", + "bit_size", "len", "kind", + "digits", "epsilon", "huge", "maxexponent", "minexponent", + "precision", "radix", "range", "tiny", + NULL + }; + + static const char *const inquiry_func_f2003[] = { + "lbound", "shape", "size", "ubound", + "bit_size", "len", "kind", + "digits", "epsilon", "huge", "maxexponent", "minexponent", + "precision", "radix", "range", "tiny", + "new_line", NULL + }; + + int i = 0; + gfc_actual_arglist *ap; + + if (!e->value.function.isym + || !e->value.function.isym->inquiry) + return MATCH_NO; + + /* An undeclared parameter will get us here (PR25018). */ + if (e->symtree == NULL) + return MATCH_NO; + + if (e->symtree->n.sym->from_intmod) + { + if (e->symtree->n.sym->from_intmod == INTMOD_ISO_FORTRAN_ENV + && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS + && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION) + return MATCH_NO; + + if (e->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING + && e->symtree->n.sym->intmod_sym_id != ISOCBINDING_C_SIZEOF) + return MATCH_NO; + } + else + { + name = e->symtree->n.sym->name; + + functions = (gfc_option.warn_std & GFC_STD_F2003) + ? inquiry_func_f2003 : inquiry_func_f95; + + for (i = 0; functions[i]; i++) + if (strcmp (functions[i], name) == 0) + break; + + if (functions[i] == NULL) + return MATCH_ERROR; + } + + /* At this point we have an inquiry function with a variable argument. The + type of the variable might be undefined, but we need it now, because the + arguments of these functions are not allowed to be undefined. */ + + for (ap = e->value.function.actual; ap; ap = ap->next) + { + if (!ap->expr) + continue; + + if (ap->expr->ts.type == BT_UNKNOWN) + { + if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN + && !gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)) + return MATCH_NO; + + ap->expr->ts = ap->expr->symtree->n.sym->ts; + } + + /* Assumed character length will not reduce to a constant expression + with LEN, as required by the standard. */ + if (i == 5 && not_restricted + && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER + && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL + || ap->expr->symtree->n.sym->ts.deferred)) + { + gfc_error ("Assumed or deferred character length variable %qs " + "in constant expression at %L", + ap->expr->symtree->n.sym->name, + &ap->expr->where); + return MATCH_ERROR; + } + else if (not_restricted && !gfc_check_init_expr (ap->expr)) + return MATCH_ERROR; + + if (not_restricted == 0 + && ap->expr->expr_type != EXPR_VARIABLE + && !check_restricted (ap->expr)) + return MATCH_ERROR; + + if (not_restricted == 0 + && ap->expr->expr_type == EXPR_VARIABLE + && ap->expr->symtree->n.sym->attr.dummy + && ap->expr->symtree->n.sym->attr.optional) + return MATCH_NO; + } + + return MATCH_YES; +} + + +/* F95, 7.1.6.1, Initialization expressions, (5) + F2003, 7.1.7 Initialization expression, (5) */ + +static match +check_transformational (gfc_expr *e) +{ + static const char * const trans_func_f95[] = { + "repeat", "reshape", "selected_int_kind", + "selected_real_kind", "transfer", "trim", NULL + }; + + static const char * const trans_func_f2003[] = { + "all", "any", "count", "dot_product", "matmul", "null", "pack", + "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", + "selected_real_kind", "spread", "sum", "transfer", "transpose", + "trim", "unpack", NULL + }; + + int i; + const char *name; + const char *const *functions; + + if (!e->value.function.isym + || !e->value.function.isym->transformational) + return MATCH_NO; + + name = e->symtree->n.sym->name; + + functions = (gfc_option.allow_std & GFC_STD_F2003) + ? trans_func_f2003 : trans_func_f95; + + /* NULL() is dealt with below. */ + if (strcmp ("null", name) == 0) + return MATCH_NO; + + for (i = 0; functions[i]; i++) + if (strcmp (functions[i], name) == 0) + break; + + if (functions[i] == NULL) + { + gfc_error ("transformational intrinsic %qs at %L is not permitted " + "in an initialization expression", name, &e->where); + return MATCH_ERROR; + } + + return check_init_expr_arguments (e); +} + + +/* F95, 7.1.6.1, Initialization expressions, (6) + F2003, 7.1.7 Initialization expression, (6) */ + +static match +check_null (gfc_expr *e) +{ + if (strcmp ("null", e->symtree->n.sym->name) != 0) + return MATCH_NO; + + return check_init_expr_arguments (e); +} + + +static match +check_elemental (gfc_expr *e) +{ + if (!e->value.function.isym + || !e->value.function.isym->elemental) + return MATCH_NO; + + if (e->ts.type != BT_INTEGER + && e->ts.type != BT_CHARACTER + && !gfc_notify_std (GFC_STD_F2003, "Evaluation of nonstandard " + "initialization expression at %L", &e->where)) + return MATCH_ERROR; + + return check_init_expr_arguments (e); +} + + +static match +check_conversion (gfc_expr *e) +{ + if (!e->value.function.isym + || !e->value.function.isym->conversion) + return MATCH_NO; + + return check_init_expr_arguments (e); +} + + +/* Verify that an expression is an initialization expression. A side + effect is that the expression tree is reduced to a single constant + node if all goes well. This would normally happen when the + expression is constructed but function references are assumed to be + intrinsics in the context of initialization expressions. If + false is returned an error message has been generated. */ + +bool +gfc_check_init_expr (gfc_expr *e) +{ + match m; + bool t; + + if (e == NULL) + return true; + + switch (e->expr_type) + { + case EXPR_OP: + t = check_intrinsic_op (e, gfc_check_init_expr); + if (t) + t = gfc_simplify_expr (e, 0); + + break; + + case EXPR_FUNCTION: + t = false; + + { + bool conversion; + gfc_intrinsic_sym* isym = NULL; + gfc_symbol* sym = e->symtree->n.sym; + + /* Simplify here the intrinsics from the IEEE_ARITHMETIC and + IEEE_EXCEPTIONS modules. */ + int mod = sym->from_intmod; + if (mod == INTMOD_NONE && sym->generic) + mod = sym->generic->sym->from_intmod; + if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS) + { + gfc_expr *new_expr = gfc_simplify_ieee_functions (e); + if (new_expr) + { + gfc_replace_expr (e, new_expr); + t = true; + break; + } + } + + /* If a conversion function, e.g., __convert_i8_i4, was inserted + into an array constructor, we need to skip the error check here. + Conversion errors are caught below in scalarize_intrinsic_call. */ + conversion = e->value.function.isym + && (e->value.function.isym->conversion == 1); + + if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where) + || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)) + { + gfc_error ("Function %qs in initialization expression at %L " + "must be an intrinsic function", + e->symtree->n.sym->name, &e->where); + break; + } + + if ((m = check_conversion (e)) == MATCH_NO + && (m = check_inquiry (e, 1)) == MATCH_NO + && (m = check_null (e)) == MATCH_NO + && (m = check_transformational (e)) == MATCH_NO + && (m = check_elemental (e)) == MATCH_NO) + { + gfc_error ("Intrinsic function %qs at %L is not permitted " + "in an initialization expression", + e->symtree->n.sym->name, &e->where); + m = MATCH_ERROR; + } + + if (m == MATCH_ERROR) + return false; + + /* Try to scalarize an elemental intrinsic function that has an + array argument. */ + isym = gfc_find_function (e->symtree->n.sym->name); + if (isym && isym->elemental + && (t = scalarize_intrinsic_call (e))) + break; + } + + if (m == MATCH_YES) + t = gfc_simplify_expr (e, 0); + + break; + + case EXPR_VARIABLE: + t = true; + + /* This occurs when parsing pdt templates. */ + if (gfc_expr_attr (e).pdt_kind) + break; + + if (gfc_check_iter_variable (e)) + break; + + if (e->symtree->n.sym->attr.flavor == FL_PARAMETER) + { + /* A PARAMETER shall not be used to define itself, i.e. + REAL, PARAMETER :: x = transfer(0, x) + is invalid. */ + if (!e->symtree->n.sym->value) + { + gfc_error ("PARAMETER %qs is used at %L before its definition " + "is complete", e->symtree->n.sym->name, &e->where); + t = false; + } + else + t = simplify_parameter_variable (e, 0); + + break; + } + + if (gfc_in_match_data ()) + break; + + t = false; + + if (e->symtree->n.sym->as) + { + switch (e->symtree->n.sym->as->type) + { + case AS_ASSUMED_SIZE: + gfc_error ("Assumed size array %qs at %L is not permitted " + "in an initialization expression", + e->symtree->n.sym->name, &e->where); + break; + + case AS_ASSUMED_SHAPE: + gfc_error ("Assumed shape array %qs at %L is not permitted " + "in an initialization expression", + e->symtree->n.sym->name, &e->where); + break; + + case AS_DEFERRED: + gfc_error ("Deferred array %qs at %L is not permitted " + "in an initialization expression", + e->symtree->n.sym->name, &e->where); + break; + + case AS_EXPLICIT: + gfc_error ("Array %qs at %L is a variable, which does " + "not reduce to a constant expression", + e->symtree->n.sym->name, &e->where); + break; + + default: + gcc_unreachable(); + } + } + else + gfc_error ("Parameter %qs at %L has not been declared or is " + "a variable, which does not reduce to a constant " + "expression", e->symtree->name, &e->where); + + break; + + case EXPR_CONSTANT: + case EXPR_NULL: + t = true; + break; + + case EXPR_SUBSTRING: + if (e->ref) + { + t = gfc_check_init_expr (e->ref->u.ss.start); + if (!t) + break; + + t = gfc_check_init_expr (e->ref->u.ss.end); + if (t) + t = gfc_simplify_expr (e, 0); + } + else + t = false; + break; + + case EXPR_STRUCTURE: + t = e->ts.is_iso_c ? true : false; + if (t) + break; + + t = check_alloc_comp_init (e); + if (!t) + break; + + t = gfc_check_constructor (e, gfc_check_init_expr); + if (!t) + break; + + break; + + case EXPR_ARRAY: + t = gfc_check_constructor (e, gfc_check_init_expr); + if (!t) + break; + + t = gfc_expand_constructor (e, true); + if (!t) + break; + + t = gfc_check_constructor_type (e); + break; + + default: + gfc_internal_error ("check_init_expr(): Unknown expression type"); + } + + return t; +} + +/* Reduces a general expression to an initialization expression (a constant). + This used to be part of gfc_match_init_expr. + Note that this function doesn't free the given expression on false. */ + +bool +gfc_reduce_init_expr (gfc_expr *expr) +{ + bool t; + + gfc_init_expr_flag = true; + t = gfc_resolve_expr (expr); + if (t) + t = gfc_check_init_expr (expr); + gfc_init_expr_flag = false; + + if (!t) + return false; + + if (expr->expr_type == EXPR_ARRAY) + { + if (!gfc_check_constructor_type (expr)) + return false; + if (!gfc_expand_constructor (expr, true)) + return false; + } + + return true; +} + + +/* Match an initialization expression. We work by first matching an + expression, then reducing it to a constant. */ + +match +gfc_match_init_expr (gfc_expr **result) +{ + gfc_expr *expr; + match m; + bool t; + + expr = NULL; + + gfc_init_expr_flag = true; + + m = gfc_match_expr (&expr); + if (m != MATCH_YES) + { + gfc_init_expr_flag = false; + return m; + } + + if (gfc_derived_parameter_expr (expr)) + { + *result = expr; + gfc_init_expr_flag = false; + return m; + } + + t = gfc_reduce_init_expr (expr); + if (!t) + { + gfc_free_expr (expr); + gfc_init_expr_flag = false; + return MATCH_ERROR; + } + + *result = expr; + gfc_init_expr_flag = false; + + return MATCH_YES; +} + + +/* Given an actual argument list, test to see that each argument is a + restricted expression and optionally if the expression type is + integer or character. */ + +static bool +restricted_args (gfc_actual_arglist *a) +{ + for (; a; a = a->next) + { + if (!check_restricted (a->expr)) + return false; + } + + return true; +} + + +/************* Restricted/specification expressions *************/ + + +/* Make sure a non-intrinsic function is a specification function, + * see F08:7.1.11.5. */ + +static bool +external_spec_function (gfc_expr *e) +{ + gfc_symbol *f; + + f = e->value.function.esym; + + /* IEEE functions allowed are "a reference to a transformational function + from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and + "inquiry function from the intrinsic modules IEEE_ARITHMETIC and + IEEE_EXCEPTIONS". */ + if (f->from_intmod == INTMOD_IEEE_ARITHMETIC + || f->from_intmod == INTMOD_IEEE_EXCEPTIONS) + { + if (!strcmp (f->name, "ieee_selected_real_kind") + || !strcmp (f->name, "ieee_support_rounding") + || !strcmp (f->name, "ieee_support_flag") + || !strcmp (f->name, "ieee_support_halting") + || !strcmp (f->name, "ieee_support_datatype") + || !strcmp (f->name, "ieee_support_denormal") + || !strcmp (f->name, "ieee_support_divide") + || !strcmp (f->name, "ieee_support_inf") + || !strcmp (f->name, "ieee_support_io") + || !strcmp (f->name, "ieee_support_nan") + || !strcmp (f->name, "ieee_support_sqrt") + || !strcmp (f->name, "ieee_support_standard") + || !strcmp (f->name, "ieee_support_underflow_control")) + goto function_allowed; + } + + if (f->attr.proc == PROC_ST_FUNCTION) + { + gfc_error ("Specification function %qs at %L cannot be a statement " + "function", f->name, &e->where); + return false; + } + + if (f->attr.proc == PROC_INTERNAL) + { + gfc_error ("Specification function %qs at %L cannot be an internal " + "function", f->name, &e->where); + return false; + } + + if (!f->attr.pure && !f->attr.elemental) + { + gfc_error ("Specification function %qs at %L must be PURE", f->name, + &e->where); + return false; + } + + /* F08:7.1.11.6. */ + if (f->attr.recursive + && !gfc_notify_std (GFC_STD_F2003, + "Specification function %qs " + "at %L cannot be RECURSIVE", f->name, &e->where)) + return false; + +function_allowed: + return restricted_args (e->value.function.actual); +} + + +/* Check to see that a function reference to an intrinsic is a + restricted expression. */ + +static bool +restricted_intrinsic (gfc_expr *e) +{ + /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */ + if (check_inquiry (e, 0) == MATCH_YES) + return true; + + return restricted_args (e->value.function.actual); +} + + +/* Check the expressions of an actual arglist. Used by check_restricted. */ + +static bool +check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*)) +{ + for (; arg; arg = arg->next) + if (!checker (arg->expr)) + return false; + + return true; +} + + +/* Check the subscription expressions of a reference chain with a checking + function; used by check_restricted. */ + +static bool +check_references (gfc_ref* ref, bool (*checker) (gfc_expr*)) +{ + int dim; + + if (!ref) + return true; + + switch (ref->type) + { + case REF_ARRAY: + for (dim = 0; dim != ref->u.ar.dimen; ++dim) + { + if (!checker (ref->u.ar.start[dim])) + return false; + if (!checker (ref->u.ar.end[dim])) + return false; + if (!checker (ref->u.ar.stride[dim])) + return false; + } + break; + + case REF_COMPONENT: + /* Nothing needed, just proceed to next reference. */ + break; + + case REF_SUBSTRING: + if (!checker (ref->u.ss.start)) + return false; + if (!checker (ref->u.ss.end)) + return false; + break; + + default: + gcc_unreachable (); + break; + } + + return check_references (ref->next, checker); +} + +/* Return true if ns is a parent of the current ns. */ + +static bool +is_parent_of_current_ns (gfc_namespace *ns) +{ + gfc_namespace *p; + for (p = gfc_current_ns->parent; p; p = p->parent) + if (ns == p) + return true; + + return false; +} + +/* Verify that an expression is a restricted expression. Like its + cousin check_init_expr(), an error message is generated if we + return false. */ + +static bool +check_restricted (gfc_expr *e) +{ + gfc_symbol* sym; + bool t; + + if (e == NULL) + return true; + + switch (e->expr_type) + { + case EXPR_OP: + t = check_intrinsic_op (e, check_restricted); + if (t) + t = gfc_simplify_expr (e, 0); + + break; + + case EXPR_FUNCTION: + if (e->value.function.esym) + { + t = check_arglist (e->value.function.actual, &check_restricted); + if (t) + t = external_spec_function (e); + } + else + { + if (e->value.function.isym && e->value.function.isym->inquiry) + t = true; + else + t = check_arglist (e->value.function.actual, &check_restricted); + + if (t) + t = restricted_intrinsic (e); + } + break; + + case EXPR_VARIABLE: + sym = e->symtree->n.sym; + t = false; + + /* If a dummy argument appears in a context that is valid for a + restricted expression in an elemental procedure, it will have + already been simplified away once we get here. Therefore we + don't need to jump through hoops to distinguish valid from + invalid cases. */ + if (sym->attr.dummy && sym->ns == gfc_current_ns + && sym->ns->proc_name && sym->ns->proc_name->attr.elemental) + { + gfc_error ("Dummy argument %qs not allowed in expression at %L", + sym->name, &e->where); + break; + } + + if (sym->attr.optional) + { + gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL", + sym->name, &e->where); + break; + } + + if (sym->attr.intent == INTENT_OUT) + { + gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)", + sym->name, &e->where); + break; + } + + /* Check reference chain if any. */ + if (!check_references (e->ref, &check_restricted)) + break; + + /* gfc_is_formal_arg broadcasts that a formal argument list is being + processed in resolve.c(resolve_formal_arglist). This is done so + that host associated dummy array indices are accepted (PR23446). + This mechanism also does the same for the specification expressions + of array-valued functions. */ + if (e->error + || sym->attr.in_common + || sym->attr.use_assoc + || sym->attr.dummy + || sym->attr.implied_index + || sym->attr.flavor == FL_PARAMETER + || is_parent_of_current_ns (sym->ns) + || (sym->ns->proc_name != NULL + && sym->ns->proc_name->attr.flavor == FL_MODULE) + || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns))) + { + t = true; + break; + } + + gfc_error ("Variable %qs cannot appear in the expression at %L", + sym->name, &e->where); + /* Prevent a repetition of the error. */ + e->error = 1; + break; + + case EXPR_NULL: + case EXPR_CONSTANT: + t = true; + break; + + case EXPR_SUBSTRING: + t = gfc_specification_expr (e->ref->u.ss.start); + if (!t) + break; + + t = gfc_specification_expr (e->ref->u.ss.end); + if (t) + t = gfc_simplify_expr (e, 0); + + break; + + case EXPR_STRUCTURE: + t = gfc_check_constructor (e, check_restricted); + break; + + case EXPR_ARRAY: + t = gfc_check_constructor (e, check_restricted); + break; + + default: + gfc_internal_error ("check_restricted(): Unknown expression type"); + } + + return t; +} + + +/* Check to see that an expression is a specification expression. If + we return false, an error has been generated. */ + +bool +gfc_specification_expr (gfc_expr *e) +{ + gfc_component *comp; + + if (e == NULL) + return true; + + if (e->ts.type != BT_INTEGER) + { + gfc_error ("Expression at %L must be of INTEGER type, found %s", + &e->where, gfc_basic_typename (e->ts.type)); + return false; + } + + comp = gfc_get_proc_ptr_comp (e); + if (e->expr_type == EXPR_FUNCTION + && !e->value.function.isym + && !e->value.function.esym + && !gfc_pure (e->symtree->n.sym) + && (!comp || !comp->attr.pure)) + { + gfc_error ("Function %qs at %L must be PURE", + e->symtree->n.sym->name, &e->where); + /* Prevent repeat error messages. */ + e->symtree->n.sym->attr.pure = 1; + return false; + } + + if (e->rank != 0) + { + gfc_error ("Expression at %L must be scalar", &e->where); + return false; + } + + if (!gfc_simplify_expr (e, 0)) + return false; + + return check_restricted (e); +} + + +/************** Expression conformance checks. *************/ + +/* Given two expressions, make sure that the arrays are conformable. */ + +bool +gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...) +{ + int op1_flag, op2_flag, d; + mpz_t op1_size, op2_size; + bool t; + + va_list argp; + char buffer[240]; + + if (op1->rank == 0 || op2->rank == 0) + return true; + + va_start (argp, optype_msgid); + vsnprintf (buffer, 240, optype_msgid, argp); + va_end (argp); + + if (op1->rank != op2->rank) + { + gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer), + op1->rank, op2->rank, &op1->where); + return false; + } + + t = true; + + for (d = 0; d < op1->rank; d++) + { + op1_flag = gfc_array_dimen_size(op1, d, &op1_size); + op2_flag = gfc_array_dimen_size(op2, d, &op2_size); + + if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0) + { + gfc_error ("Different shape for %s at %L on dimension %d " + "(%d and %d)", _(buffer), &op1->where, d + 1, + (int) mpz_get_si (op1_size), + (int) mpz_get_si (op2_size)); + + t = false; + } + + if (op1_flag) + mpz_clear (op1_size); + if (op2_flag) + mpz_clear (op2_size); + + if (!t) + return false; + } + + return true; +} + + +/* Given an assignable expression and an arbitrary expression, make + sure that the assignment can take place. Only add a call to the intrinsic + conversion routines, when allow_convert is set. When this assign is a + coarray call, then the convert is done by the coarray routine implictly and + adding the intrinsic conversion would do harm in most cases. */ + +bool +gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, + bool allow_convert) +{ + gfc_symbol *sym; + gfc_ref *ref; + int has_pointer; + + sym = lvalue->symtree->n.sym; + + /* See if this is the component or subcomponent of a pointer. */ + has_pointer = sym->attr.pointer; + for (ref = lvalue->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) + { + has_pointer = 1; + break; + } + + /* 12.5.2.2, Note 12.26: The result variable is very similar to any other + variable local to a function subprogram. Its existence begins when + execution of the function is initiated and ends when execution of the + function is terminated... + Therefore, the left hand side is no longer a variable, when it is: */ + if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION + && !sym->attr.external) + { + bool bad_proc; + bad_proc = false; + + /* (i) Use associated; */ + if (sym->attr.use_assoc) + bad_proc = true; + + /* (ii) The assignment is in the main program; or */ + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.is_main_program) + bad_proc = true; + + /* (iii) A module or internal procedure... */ + if (gfc_current_ns->proc_name + && (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL + || gfc_current_ns->proc_name->attr.proc == PROC_MODULE) + && gfc_current_ns->parent + && (!(gfc_current_ns->parent->proc_name->attr.function + || gfc_current_ns->parent->proc_name->attr.subroutine) + || gfc_current_ns->parent->proc_name->attr.is_main_program)) + { + /* ... that is not a function... */ + if (gfc_current_ns->proc_name + && !gfc_current_ns->proc_name->attr.function) + bad_proc = true; + + /* ... or is not an entry and has a different name. */ + if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name) + bad_proc = true; + } + + /* (iv) Host associated and not the function symbol or the + parent result. This picks up sibling references, which + cannot be entries. */ + if (!sym->attr.entry + && sym->ns == gfc_current_ns->parent + && sym != gfc_current_ns->proc_name + && sym != gfc_current_ns->parent->proc_name->result) + bad_proc = true; + + if (bad_proc) + { + gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where); + return false; + } + } + + if (rvalue->rank != 0 && lvalue->rank != rvalue->rank) + { + gfc_error ("Incompatible ranks %d and %d in assignment at %L", + lvalue->rank, rvalue->rank, &lvalue->where); + return false; + } + + if (lvalue->ts.type == BT_UNKNOWN) + { + gfc_error ("Variable type is UNKNOWN in assignment at %L", + &lvalue->where); + return false; + } + + if (rvalue->expr_type == EXPR_NULL) + { + if (has_pointer && (ref == NULL || ref->next == NULL) + && lvalue->symtree->n.sym->attr.data) + return true; + else + { + gfc_error ("NULL appears on right-hand side in assignment at %L", + &rvalue->where); + return false; + } + } + + /* This is possibly a typo: x = f() instead of x => f(). */ + if (warn_surprising + && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer) + gfc_warning (OPT_Wsurprising, + "POINTER-valued function appears on right-hand side of " + "assignment at %L", &rvalue->where); + + /* Check size of array assignments. */ + if (lvalue->rank != 0 && rvalue->rank != 0 + && !gfc_check_conformance (lvalue, rvalue, "array assignment")) + return false; + + if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER + && lvalue->symtree->n.sym->attr.data + && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to " + "initialize non-integer variable %qs", + &rvalue->where, lvalue->symtree->n.sym->name)) + return false; + else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data + && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside " + "a DATA statement and outside INT/REAL/DBLE/CMPLX", + &rvalue->where)) + return false; + + /* Handle the case of a BOZ literal on the RHS. */ + if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER) + { + int rc; + if (warn_surprising) + gfc_warning (OPT_Wsurprising, + "BOZ literal at %L is bitwise transferred " + "non-integer symbol %qs", &rvalue->where, + lvalue->symtree->n.sym->name); + if (!gfc_convert_boz (rvalue, &lvalue->ts)) + return false; + if ((rc = gfc_range_check (rvalue)) != ARITH_OK) + { + if (rc == ARITH_UNDERFLOW) + gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L" + ". This check can be disabled with the option " + "%<-fno-range-check%>", &rvalue->where); + else if (rc == ARITH_OVERFLOW) + gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L" + ". This check can be disabled with the option " + "%<-fno-range-check%>", &rvalue->where); + else if (rc == ARITH_NAN) + gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L" + ". This check can be disabled with the option " + "%<-fno-range-check%>", &rvalue->where); + return false; + } + } + + if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len) + { + gfc_error ("The assignment to a KIND or LEN component of a " + "parameterized type at %L is not allowed", + &lvalue->where); + return false; + } + + if (gfc_compare_types (&lvalue->ts, &rvalue->ts)) + return true; + + /* Only DATA Statements come here. */ + if (!conform) + { + /* Numeric can be converted to any other numeric. And Hollerith can be + converted to any other type. */ + if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts)) + || rvalue->ts.type == BT_HOLLERITH) + return true; + + if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) + return true; + + gfc_error ("Incompatible types in DATA statement at %L; attempted " + "conversion of %s to %s", &lvalue->where, + gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts)); + + return false; + } + + /* Assignment is the only case where character variables of different + kind values can be converted into one another. */ + if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER) + { + if (lvalue->ts.kind != rvalue->ts.kind && allow_convert) + return gfc_convert_chartype (rvalue, &lvalue->ts); + else + return true; + } + + if (!allow_convert) + return true; + + return gfc_convert_type (rvalue, &lvalue->ts, 1); +} + + +/* Check that a pointer assignment is OK. We first check lvalue, and + we only check rvalue if it's not an assignment to NULL() or a + NULLIFY statement. */ + +bool +gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) +{ + symbol_attribute attr, lhs_attr; + gfc_ref *ref; + bool is_pure, is_implicit_pure, rank_remap; + int proc_pointer; + + lhs_attr = gfc_expr_attr (lvalue); + if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer) + { + gfc_error ("Pointer assignment target is not a POINTER at %L", + &lvalue->where); + return false; + } + + if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc + && !lhs_attr.proc_pointer) + { + gfc_error ("%qs in the pointer assignment at %L cannot be an " + "l-value since it is a procedure", + lvalue->symtree->n.sym->name, &lvalue->where); + return false; + } + + proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer; + + rank_remap = false; + for (ref = lvalue->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT) + proc_pointer = ref->u.c.component->attr.proc_pointer; + + if (ref->type == REF_ARRAY && ref->next == NULL) + { + int dim; + + if (ref->u.ar.type == AR_FULL) + break; + + if (ref->u.ar.type != AR_SECTION) + { + gfc_error ("Expected bounds specification for %qs at %L", + lvalue->symtree->n.sym->name, &lvalue->where); + return false; + } + + if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification " + "for %qs in pointer assignment at %L", + lvalue->symtree->n.sym->name, &lvalue->where)) + return false; + + /* When bounds are given, all lbounds are necessary and either all + or none of the upper bounds; no strides are allowed. If the + upper bounds are present, we may do rank remapping. */ + for (dim = 0; dim < ref->u.ar.dimen; ++dim) + { + if (!ref->u.ar.start[dim] + || ref->u.ar.dimen_type[dim] != DIMEN_RANGE) + { + gfc_error ("Lower bound has to be present at %L", + &lvalue->where); + return false; + } + if (ref->u.ar.stride[dim]) + { + gfc_error ("Stride must not be present at %L", + &lvalue->where); + return false; + } + + if (dim == 0) + rank_remap = (ref->u.ar.end[dim] != NULL); + else + { + if ((rank_remap && !ref->u.ar.end[dim]) + || (!rank_remap && ref->u.ar.end[dim])) + { + gfc_error ("Either all or none of the upper bounds" + " must be specified at %L", &lvalue->where); + return false; + } + } + } + } + } + + is_pure = gfc_pure (NULL); + is_implicit_pure = gfc_implicit_pure (NULL); + + /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type, + kind, etc for lvalue and rvalue must match, and rvalue must be a + pure variable if we're in a pure function. */ + if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) + return true; + + /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */ + if (lvalue->expr_type == EXPR_VARIABLE + && gfc_is_coindexed (lvalue)) + { + gfc_ref *ref; + for (ref = lvalue->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + { + gfc_error ("Pointer object at %L shall not have a coindex", + &lvalue->where); + return false; + } + } + + /* Checks on rvalue for procedure pointer assignments. */ + if (proc_pointer) + { + char err[200]; + gfc_symbol *s1,*s2; + gfc_component *comp1, *comp2; + const char *name; + + attr = gfc_expr_attr (rvalue); + if (!((rvalue->expr_type == EXPR_NULL) + || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer) + || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer) + || (rvalue->expr_type == EXPR_VARIABLE + && attr.flavor == FL_PROCEDURE))) + { + gfc_error ("Invalid procedure pointer assignment at %L", + &rvalue->where); + return false; + } + if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer) + { + /* Check for intrinsics. */ + gfc_symbol *sym = rvalue->symtree->n.sym; + if (!sym->attr.intrinsic + && (gfc_is_intrinsic (sym, 0, sym->declared_at) + || gfc_is_intrinsic (sym, 1, sym->declared_at))) + { + sym->attr.intrinsic = 1; + gfc_resolve_intrinsic (sym, &rvalue->where); + attr = gfc_expr_attr (rvalue); + } + /* Check for result of embracing function. */ + if (sym->attr.function && sym->result == sym) + { + gfc_namespace *ns; + + for (ns = gfc_current_ns; ns; ns = ns->parent) + if (sym == ns->proc_name) + { + gfc_error ("Function result %qs is invalid as proc-target " + "in procedure pointer assignment at %L", + sym->name, &rvalue->where); + return false; + } + } + } + if (attr.abstract) + { + gfc_error ("Abstract interface %qs is invalid " + "in procedure pointer assignment at %L", + rvalue->symtree->name, &rvalue->where); + return false; + } + /* Check for F08:C729. */ + if (attr.flavor == FL_PROCEDURE) + { + if (attr.proc == PROC_ST_FUNCTION) + { + gfc_error ("Statement function %qs is invalid " + "in procedure pointer assignment at %L", + rvalue->symtree->name, &rvalue->where); + return false; + } + if (attr.proc == PROC_INTERNAL && + !gfc_notify_std(GFC_STD_F2008, "Internal procedure %qs " + "is invalid in procedure pointer assignment " + "at %L", rvalue->symtree->name, &rvalue->where)) + return false; + if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name, + attr.subroutine) == 0) + { + gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer " + "assignment", rvalue->symtree->name, &rvalue->where); + return false; + } + } + /* Check for F08:C730. */ + if (attr.elemental && !attr.intrinsic) + { + gfc_error ("Nonintrinsic elemental procedure %qs is invalid " + "in procedure pointer assignment at %L", + rvalue->symtree->name, &rvalue->where); + return false; + } + + /* Ensure that the calling convention is the same. As other attributes + such as DLLEXPORT may differ, one explicitly only tests for the + calling conventions. */ + if (rvalue->expr_type == EXPR_VARIABLE + && lvalue->symtree->n.sym->attr.ext_attr + != rvalue->symtree->n.sym->attr.ext_attr) + { + symbol_attribute calls; + + calls.ext_attr = 0; + gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL); + gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL); + gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL); + + if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr) + != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr)) + { + gfc_error ("Mismatch in the procedure pointer assignment " + "at %L: mismatch in the calling convention", + &rvalue->where); + return false; + } + } + + comp1 = gfc_get_proc_ptr_comp (lvalue); + if (comp1) + s1 = comp1->ts.interface; + else + { + s1 = lvalue->symtree->n.sym; + if (s1->ts.interface) + s1 = s1->ts.interface; + } + + comp2 = gfc_get_proc_ptr_comp (rvalue); + if (comp2) + { + if (rvalue->expr_type == EXPR_FUNCTION) + { + s2 = comp2->ts.interface->result; + name = s2->name; + } + else + { + s2 = comp2->ts.interface; + name = comp2->name; + } + } + else if (rvalue->expr_type == EXPR_FUNCTION) + { + if (rvalue->value.function.esym) + s2 = rvalue->value.function.esym->result; + else + s2 = rvalue->symtree->n.sym->result; + + name = s2->name; + } + else + { + s2 = rvalue->symtree->n.sym; + name = s2->name; + } + + if (s2 && s2->attr.proc_pointer && s2->ts.interface) + s2 = s2->ts.interface; + + /* Special check for the case of absent interface on the lvalue. + * All other interface checks are done below. */ + if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function) + { + gfc_error ("Interface mismatch in procedure pointer assignment " + "at %L: %qs is not a subroutine", &rvalue->where, name); + return false; + } + + /* F08:7.2.2.4 (4) */ + if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err))) + { + if (comp1 && !s1) + { + gfc_error ("Explicit interface required for component %qs at %L: %s", + comp1->name, &lvalue->where, err); + return false; + } + else if (s1->attr.if_source == IFSRC_UNKNOWN) + { + gfc_error ("Explicit interface required for %qs at %L: %s", + s1->name, &lvalue->where, err); + return false; + } + } + if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err))) + { + if (comp2 && !s2) + { + gfc_error ("Explicit interface required for component %qs at %L: %s", + comp2->name, &rvalue->where, err); + return false; + } + else if (s2->attr.if_source == IFSRC_UNKNOWN) + { + gfc_error ("Explicit interface required for %qs at %L: %s", + s2->name, &rvalue->where, err); + return false; + } + } + + if (s1 == s2 || !s1 || !s2) + return true; + + if (!gfc_compare_interfaces (s1, s2, name, 0, 1, + err, sizeof(err), NULL, NULL)) + { + gfc_error ("Interface mismatch in procedure pointer assignment " + "at %L: %s", &rvalue->where, err); + return false; + } + + /* Check F2008Cor2, C729. */ + if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN + && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function) + { + gfc_error ("Procedure pointer target %qs at %L must be either an " + "intrinsic, host or use associated, referenced or have " + "the EXTERNAL attribute", s2->name, &rvalue->where); + return false; + } + + return true; + } + + if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) + { + /* Check for F03:C717. */ + if (UNLIMITED_POLY (rvalue) + && !(UNLIMITED_POLY (lvalue) + || (lvalue->ts.type == BT_DERIVED + && (lvalue->ts.u.derived->attr.is_bind_c + || lvalue->ts.u.derived->attr.sequence)))) + gfc_error ("Data-pointer-object at %L must be unlimited " + "polymorphic, or of a type with the BIND or SEQUENCE " + "attribute, to be compatible with an unlimited " + "polymorphic target", &lvalue->where); + else + gfc_error ("Different types in pointer assignment at %L; " + "attempted assignment of %s to %s", &lvalue->where, + gfc_typename (&rvalue->ts), + gfc_typename (&lvalue->ts)); + return false; + } + + if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind) + { + gfc_error ("Different kind type parameters in pointer " + "assignment at %L", &lvalue->where); + return false; + } + + if (lvalue->rank != rvalue->rank && !rank_remap) + { + gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); + return false; + } + + /* Make sure the vtab is present. */ + if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue)) + gfc_find_vtab (&rvalue->ts); + + /* Check rank remapping. */ + if (rank_remap) + { + mpz_t lsize, rsize; + + /* If this can be determined, check that the target must be at least as + large as the pointer assigned to it is. */ + if (gfc_array_size (lvalue, &lsize) + && gfc_array_size (rvalue, &rsize) + && mpz_cmp (rsize, lsize) < 0) + { + gfc_error ("Rank remapping target is smaller than size of the" + " pointer (%ld < %ld) at %L", + mpz_get_si (rsize), mpz_get_si (lsize), + &lvalue->where); + return false; + } + + /* The target must be either rank one or it must be simply contiguous + and F2008 must be allowed. */ + if (rvalue->rank != 1) + { + if (!gfc_is_simply_contiguous (rvalue, true, false)) + { + gfc_error ("Rank remapping target must be rank 1 or" + " simply contiguous at %L", &rvalue->where); + return false; + } + if (!gfc_notify_std (GFC_STD_F2008, "Rank remapping target is not " + "rank 1 at %L", &rvalue->where)) + return false; + } + } + + /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */ + if (rvalue->expr_type == EXPR_NULL) + return true; + + if (lvalue->ts.type == BT_CHARACTER) + { + bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment"); + if (!t) + return false; + } + + if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue)) + lvalue->symtree->n.sym->attr.subref_array_pointer = 1; + + attr = gfc_expr_attr (rvalue); + + if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer) + { + /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call + to caf_get. Map this to the same error message as below when it is + still a variable expression. */ + if (rvalue->value.function.isym + && rvalue->value.function.isym->id == GFC_ISYM_CAF_GET) + /* The test above might need to be extend when F08, Note 5.4 has to be + interpreted in the way that target and pointer with the same coindex + are allowed. */ + gfc_error ("Data target at %L shall not have a coindex", + &rvalue->where); + else + gfc_error ("Target expression in pointer assignment " + "at %L must deliver a pointer result", + &rvalue->where); + return false; + } + + if (!attr.target && !attr.pointer) + { + gfc_error ("Pointer assignment target is neither TARGET " + "nor POINTER at %L", &rvalue->where); + return false; + } + + if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym)) + { + gfc_error ("Bad target in pointer assignment in PURE " + "procedure at %L", &rvalue->where); + } + + if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym)) + gfc_unset_implicit_pure (gfc_current_ns->proc_name); + + if (gfc_has_vector_index (rvalue)) + { + gfc_error ("Pointer assignment with vector subscript " + "on rhs at %L", &rvalue->where); + return false; + } + + if (attr.is_protected && attr.use_assoc + && !(attr.pointer || attr.proc_pointer)) + { + gfc_error ("Pointer assignment target has PROTECTED " + "attribute at %L", &rvalue->where); + return false; + } + + /* F2008, C725. For PURE also C1283. */ + if (rvalue->expr_type == EXPR_VARIABLE + && gfc_is_coindexed (rvalue)) + { + gfc_ref *ref; + for (ref = rvalue->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + { + gfc_error ("Data target at %L shall not have a coindex", + &rvalue->where); + return false; + } + } + + /* Error for assignments of contiguous pointers to targets which is not + contiguous. Be lenient in the definition of what counts as + congiguous. */ + + if (lhs_attr.contiguous && !gfc_is_simply_contiguous (rvalue, false, true)) + gfc_error ("Assignment to contiguous pointer from non-contiguous " + "target at %L", &rvalue->where); + + /* Warn if it is the LHS pointer may lives longer than the RHS target. */ + if (warn_target_lifetime + && rvalue->expr_type == EXPR_VARIABLE + && !rvalue->symtree->n.sym->attr.save + && !rvalue->symtree->n.sym->attr.pointer && !attr.pointer + && !rvalue->symtree->n.sym->attr.host_assoc + && !rvalue->symtree->n.sym->attr.in_common + && !rvalue->symtree->n.sym->attr.use_assoc + && !rvalue->symtree->n.sym->attr.dummy) + { + bool warn; + gfc_namespace *ns; + + warn = lvalue->symtree->n.sym->attr.dummy + || lvalue->symtree->n.sym->attr.result + || lvalue->symtree->n.sym->attr.function + || (lvalue->symtree->n.sym->attr.host_assoc + && lvalue->symtree->n.sym->ns + != rvalue->symtree->n.sym->ns) + || lvalue->symtree->n.sym->attr.use_assoc + || lvalue->symtree->n.sym->attr.in_common; + + if (rvalue->symtree->n.sym->ns->proc_name + && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE + && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM) + for (ns = rvalue->symtree->n.sym->ns; + ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE; + ns = ns->parent) + if (ns->parent == lvalue->symtree->n.sym->ns) + { + warn = true; + break; + } + + if (warn) + gfc_warning (OPT_Wtarget_lifetime, + "Pointer at %L in pointer assignment might outlive the " + "pointer target", &lvalue->where); + } + + return true; +} + + +/* Relative of gfc_check_assign() except that the lvalue is a single + symbol. Used for initialization assignments. */ + +bool +gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) +{ + gfc_expr lvalue; + bool r; + bool pointer, proc_pointer; + + memset (&lvalue, '\0', sizeof (gfc_expr)); + + lvalue.expr_type = EXPR_VARIABLE; + lvalue.ts = sym->ts; + if (sym->as) + lvalue.rank = sym->as->rank; + lvalue.symtree = XCNEW (gfc_symtree); + lvalue.symtree->n.sym = sym; + lvalue.where = sym->declared_at; + + if (comp) + { + lvalue.ref = gfc_get_ref (); + lvalue.ref->type = REF_COMPONENT; + lvalue.ref->u.c.component = comp; + lvalue.ref->u.c.sym = sym; + lvalue.ts = comp->ts; + lvalue.rank = comp->as ? comp->as->rank : 0; + lvalue.where = comp->loc; + pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp) + ? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer; + proc_pointer = comp->attr.proc_pointer; + } + else + { + pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym) + ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; + proc_pointer = sym->attr.proc_pointer; + } + + if (pointer || proc_pointer) + r = gfc_check_pointer_assign (&lvalue, rvalue); + else + { + /* If a conversion function, e.g., __convert_i8_i4, was inserted + into an array constructor, we should check if it can be reduced + as an initialization expression. */ + if (rvalue->expr_type == EXPR_FUNCTION + && rvalue->value.function.isym + && (rvalue->value.function.isym->conversion == 1)) + gfc_check_init_expr (rvalue); + + r = gfc_check_assign (&lvalue, rvalue, 1); + } + + free (lvalue.symtree); + free (lvalue.ref); + + if (!r) + return r; + + if (pointer && rvalue->expr_type != EXPR_NULL) + { + /* F08:C461. Additional checks for pointer initialization. */ + symbol_attribute attr; + attr = gfc_expr_attr (rvalue); + if (attr.allocatable) + { + gfc_error ("Pointer initialization target at %L " + "must not be ALLOCATABLE", &rvalue->where); + return false; + } + if (!attr.target || attr.pointer) + { + gfc_error ("Pointer initialization target at %L " + "must have the TARGET attribute", &rvalue->where); + return false; + } + + if (!attr.save && rvalue->expr_type == EXPR_VARIABLE + && rvalue->symtree->n.sym->ns->proc_name + && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program) + { + rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT; + attr.save = SAVE_IMPLICIT; + } + + if (!attr.save) + { + gfc_error ("Pointer initialization target at %L " + "must have the SAVE attribute", &rvalue->where); + return false; + } + } + + if (proc_pointer && rvalue->expr_type != EXPR_NULL) + { + /* F08:C1220. Additional checks for procedure pointer initialization. */ + symbol_attribute attr = gfc_expr_attr (rvalue); + if (attr.proc_pointer) + { + gfc_error ("Procedure pointer initialization target at %L " + "may not be a procedure pointer", &rvalue->where); + return false; + } + } + + return true; +} + + +/* Build an initializer for a local integer, real, complex, logical, or + character variable, based on the command line flags finit-local-zero, + finit-integer=, finit-real=, finit-logical=, and finit-character=. */ + +gfc_expr * +gfc_build_default_init_expr (gfc_typespec *ts, locus *where) +{ + int char_len; + gfc_expr *init_expr; + int i; + + /* Try to build an initializer expression. */ + init_expr = gfc_get_constant_expr (ts->type, ts->kind, where); + + /* We will only initialize integers, reals, complex, logicals, and + characters, and only if the corresponding command-line flags + were set. Otherwise, we free init_expr and return null. */ + switch (ts->type) + { + case BT_INTEGER: + if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF) + mpz_set_si (init_expr->value.integer, + gfc_option.flag_init_integer_value); + else + { + gfc_free_expr (init_expr); + init_expr = NULL; + } + break; + + case BT_REAL: + switch (flag_init_real) + { + case GFC_INIT_REAL_SNAN: + init_expr->is_snan = 1; + /* Fall through. */ + case GFC_INIT_REAL_NAN: + mpfr_set_nan (init_expr->value.real); + break; + + case GFC_INIT_REAL_INF: + mpfr_set_inf (init_expr->value.real, 1); + break; + + case GFC_INIT_REAL_NEG_INF: + mpfr_set_inf (init_expr->value.real, -1); + break; + + case GFC_INIT_REAL_ZERO: + mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE); + break; + + default: + gfc_free_expr (init_expr); + init_expr = NULL; + break; + } + break; + + case BT_COMPLEX: + switch (flag_init_real) + { + case GFC_INIT_REAL_SNAN: + init_expr->is_snan = 1; + /* Fall through. */ + case GFC_INIT_REAL_NAN: + mpfr_set_nan (mpc_realref (init_expr->value.complex)); + mpfr_set_nan (mpc_imagref (init_expr->value.complex)); + break; + + case GFC_INIT_REAL_INF: + mpfr_set_inf (mpc_realref (init_expr->value.complex), 1); + mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1); + break; + + case GFC_INIT_REAL_NEG_INF: + mpfr_set_inf (mpc_realref (init_expr->value.complex), -1); + mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1); + break; + + case GFC_INIT_REAL_ZERO: + mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE); + break; + + default: + gfc_free_expr (init_expr); + init_expr = NULL; + break; + } + break; + + case BT_LOGICAL: + if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE) + init_expr->value.logical = 0; + else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE) + init_expr->value.logical = 1; + else + { + gfc_free_expr (init_expr); + init_expr = NULL; + } + break; + + case BT_CHARACTER: + /* For characters, the length must be constant in order to + create a default initializer. */ + if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON + && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT) + { + char_len = mpz_get_si (ts->u.cl->length->value.integer); + init_expr->value.character.length = char_len; + init_expr->value.character.string = gfc_get_wide_string (char_len+1); + for (i = 0; i < char_len; i++) + init_expr->value.character.string[i] + = (unsigned char) gfc_option.flag_init_character_value; + } + else + { + gfc_free_expr (init_expr); + init_expr = NULL; + } + if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON + && ts->u.cl->length && flag_max_stack_var_size != 0) + { + gfc_actual_arglist *arg; + init_expr = gfc_get_expr (); + init_expr->where = *where; + init_expr->ts = *ts; + init_expr->expr_type = EXPR_FUNCTION; + init_expr->value.function.isym = + gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT); + init_expr->value.function.name = "repeat"; + arg = gfc_get_actual_arglist (); + arg->expr = gfc_get_character_expr (ts->kind, where, NULL, 1); + arg->expr->value.character.string[0] = + gfc_option.flag_init_character_value; + arg->next = gfc_get_actual_arglist (); + arg->next->expr = gfc_copy_expr (ts->u.cl->length); + init_expr->value.function.actual = arg; + } + break; + + default: + gfc_free_expr (init_expr); + init_expr = NULL; + } + + return init_expr; +} + +/* Apply an initialization expression to a typespec. Can be used for symbols or + components. Similar to add_init_expr_to_sym in decl.c; could probably be + combined with some effort. */ + +void +gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init) +{ + if (ts->type == BT_CHARACTER && !attr->pointer && init + && ts->u.cl + && ts->u.cl->length && ts->u.cl->length->expr_type == EXPR_CONSTANT) + { + int len; + + gcc_assert (ts->u.cl && ts->u.cl->length); + gcc_assert (ts->u.cl->length->expr_type == EXPR_CONSTANT); + gcc_assert (ts->u.cl->length->ts.type == BT_INTEGER); + + len = mpz_get_si (ts->u.cl->length->value.integer); + + if (init->expr_type == EXPR_CONSTANT) + gfc_set_constant_character_len (len, init, -1); + else if (init + && init->ts.u.cl + && mpz_cmp (ts->u.cl->length->value.integer, + init->ts.u.cl->length->value.integer)) + { + gfc_constructor *ctor; + ctor = gfc_constructor_first (init->value.constructor); + + if (ctor) + { + int first_len; + bool has_ts = (init->ts.u.cl + && init->ts.u.cl->length_from_typespec); + + /* Remember the length of the first element for checking + that all elements *in the constructor* have the same + length. This need not be the length of the LHS! */ + gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT); + gcc_assert (ctor->expr->ts.type == BT_CHARACTER); + first_len = ctor->expr->value.character.length; + + for ( ; ctor; ctor = gfc_constructor_next (ctor)) + if (ctor->expr->expr_type == EXPR_CONSTANT) + { + gfc_set_constant_character_len (len, ctor->expr, + has_ts ? -1 : first_len); + if (!ctor->expr->ts.u.cl) + ctor->expr->ts.u.cl + = gfc_new_charlen (gfc_current_ns, ts->u.cl); + else + ctor->expr->ts.u.cl->length + = gfc_copy_expr (ts->u.cl->length); + } + } + } + } +} + + +/* Check whether an expression is a structure constructor and whether it has + other values than NULL. */ + +bool +is_non_empty_structure_constructor (gfc_expr * e) +{ + if (e->expr_type != EXPR_STRUCTURE) + return false; + + gfc_constructor *cons = gfc_constructor_first (e->value.constructor); + while (cons) + { + if (!cons->expr || cons->expr->expr_type != EXPR_NULL) + return true; + cons = gfc_constructor_next (cons); + } + return false; +} + + +/* Check for default initializer; sym->value is not enough + as it is also set for EXPR_NULL of allocatables. */ + +bool +gfc_has_default_initializer (gfc_symbol *der) +{ + gfc_component *c; + + gcc_assert (gfc_fl_struct (der->attr.flavor)); + for (c = der->components; c; c = c->next) + if (gfc_bt_struct (c->ts.type)) + { + if (!c->attr.pointer && !c->attr.proc_pointer + && !(c->attr.allocatable && der == c->ts.u.derived) + && ((c->initializer + && is_non_empty_structure_constructor (c->initializer)) + || gfc_has_default_initializer (c->ts.u.derived))) + return true; + if (c->attr.pointer && c->initializer) + return true; + } + else + { + if (c->initializer) + return true; + } + + return false; +} + + +/* + Generate an initializer expression which initializes the entirety of a union. + A normal structure constructor is insufficient without undue effort, because + components of maps may be oddly aligned/overlapped. (For example if a + character is initialized from one map overtop a real from the other, only one + byte of the real is actually initialized.) Unfortunately we don't know the + size of the union right now, so we can't generate a proper initializer, but + we use a NULL expr as a placeholder and do the right thing later in + gfc_trans_subcomponent_assign. + */ +static gfc_expr * +generate_union_initializer (gfc_component *un) +{ + if (un == NULL || un->ts.type != BT_UNION) + return NULL; + + gfc_expr *placeholder = gfc_get_null_expr (&un->loc); + placeholder->ts = un->ts; + return placeholder; +} + + +/* Get the user-specified initializer for a union, if any. This means the user + has said to initialize component(s) of a map. For simplicity's sake we + only allow the user to initialize the first map. We don't have to worry + about overlapping initializers as they are released early in resolution (see + resolve_fl_struct). */ + +static gfc_expr * +get_union_initializer (gfc_symbol *union_type, gfc_component **map_p) +{ + gfc_component *map; + gfc_expr *init=NULL; + + if (!union_type || union_type->attr.flavor != FL_UNION) + return NULL; + + for (map = union_type->components; map; map = map->next) + { + if (gfc_has_default_initializer (map->ts.u.derived)) + { + init = gfc_default_initializer (&map->ts); + if (map_p) + *map_p = map; + break; + } + } + + if (map_p && !init) + *map_p = NULL; + + return init; +} + +/* Fetch or generate an initializer for the given component. + Only generate an initializer if generate is true. */ + +static gfc_expr * +component_initializer (gfc_typespec *ts, gfc_component *c, bool generate) +{ + gfc_expr *init = NULL; + + /* See if we can find the initializer immediately. + Some components should never get initializers. */ + if (c->initializer || !generate + || (ts->type == BT_CLASS && !c->attr.allocatable) + || c->attr.pointer + || c->attr.class_pointer + || c->attr.proc_pointer) + return c->initializer; + + /* Recursively handle derived type components. */ + if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + init = gfc_generate_initializer (&c->ts, true); + + else if (c->ts.type == BT_UNION && c->ts.u.derived->components) + { + gfc_component *map = NULL; + gfc_constructor *ctor; + gfc_expr *user_init; + + /* If we don't have a user initializer and we aren't generating one, this + union has no initializer. */ + user_init = get_union_initializer (c->ts.u.derived, &map); + if (!user_init && !generate) + return NULL; + + /* Otherwise use a structure constructor. */ + init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind, + &c->loc); + init->ts = c->ts; + + /* If we are to generate an initializer for the union, add a constructor + which initializes the whole union first. */ + if (generate) + { + ctor = gfc_constructor_get (); + ctor->expr = generate_union_initializer (c); + gfc_constructor_append (&init->value.constructor, ctor); + } + + /* If we found an initializer in one of our maps, apply it. Note this + is applied _after_ the entire-union initializer above if any. */ + if (user_init) + { + ctor = gfc_constructor_get (); + ctor->expr = user_init; + ctor->n.component = map; + gfc_constructor_append (&init->value.constructor, ctor); + } + } + + /* Treat simple components like locals. */ + else + { + init = gfc_build_default_init_expr (&c->ts, &c->loc); + gfc_apply_init (&c->ts, &c->attr, init); + } + + return init; +} + + +/* Get an expression for a default initializer of a derived type. */ + +gfc_expr * +gfc_default_initializer (gfc_typespec *ts) +{ + return gfc_generate_initializer (ts, false); +} + + +/* Get or generate an expression for a default initializer of a derived type. + If -finit-derived is specified, generate default initialization expressions + for components that lack them when generate is set. */ + +gfc_expr * +gfc_generate_initializer (gfc_typespec *ts, bool generate) +{ + gfc_expr *init, *tmp; + gfc_component *comp; + generate = flag_init_derived && generate; + + /* See if we have a default initializer in this, but not in nested + types (otherwise we could use gfc_has_default_initializer()). + We don't need to check if we are going to generate them. */ + comp = ts->u.derived->components; + if (!generate) + { + for (; comp; comp = comp->next) + if (comp->initializer || comp->attr.allocatable + || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) + && CLASS_DATA (comp)->attr.allocatable)) + break; + } + + if (!comp) + return NULL; + + init = gfc_get_structure_constructor_expr (ts->type, ts->kind, + &ts->u.derived->declared_at); + init->ts = *ts; + + for (comp = ts->u.derived->components; comp; comp = comp->next) + { + gfc_constructor *ctor = gfc_constructor_get(); + + /* Fetch or generate an initializer for the component. */ + tmp = component_initializer (ts, comp, generate); + if (tmp) + { + /* Save the component ref for STRUCTUREs and UNIONs. */ + if (ts->u.derived->attr.flavor == FL_STRUCT + || ts->u.derived->attr.flavor == FL_UNION) + ctor->n.component = comp; + + /* If the initializer was not generated, we need a copy. */ + ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp; + if ((comp->ts.type != tmp->ts.type + || comp->ts.kind != tmp->ts.kind) + && !comp->attr.pointer && !comp->attr.proc_pointer) + { + bool val; + val = gfc_convert_type_warn (ctor->expr, &comp->ts, 1, false); + if (val == false) + return NULL; + } + } + + if (comp->attr.allocatable + || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable)) + { + ctor->expr = gfc_get_expr (); + ctor->expr->expr_type = EXPR_NULL; + ctor->expr->where = init->where; + ctor->expr->ts = comp->ts; + } + + gfc_constructor_append (&init->value.constructor, ctor); + } + + return init; +} + + +/* Given a symbol, create an expression node with that symbol as a + variable. If the symbol is array valued, setup a reference of the + whole array. */ + +gfc_expr * +gfc_get_variable_expr (gfc_symtree *var) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_VARIABLE; + e->symtree = var; + e->ts = var->n.sym->ts; + + if (var->n.sym->attr.flavor != FL_PROCEDURE + && ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS) + || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym) + && CLASS_DATA (var->n.sym)->as))) + { + e->rank = var->n.sym->ts.type == BT_CLASS + ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank; + e->ref = gfc_get_ref (); + e->ref->type = REF_ARRAY; + e->ref->u.ar.type = AR_FULL; + e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS + ? CLASS_DATA (var->n.sym)->as + : var->n.sym->as); + } + + return e; +} + + +/* Adds a full array reference to an expression, as needed. */ + +void +gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as) +{ + gfc_ref *ref; + for (ref = e->ref; ref; ref = ref->next) + if (!ref->next) + break; + if (ref) + { + ref->next = gfc_get_ref (); + ref = ref->next; + } + else + { + e->ref = gfc_get_ref (); + ref = e->ref; + } + ref->type = REF_ARRAY; + ref->u.ar.type = AR_FULL; + ref->u.ar.dimen = e->rank; + ref->u.ar.where = e->where; + ref->u.ar.as = as; +} + + +gfc_expr * +gfc_lval_expr_from_sym (gfc_symbol *sym) +{ + gfc_expr *lval; + gfc_array_spec *as; + lval = gfc_get_expr (); + lval->expr_type = EXPR_VARIABLE; + lval->where = sym->declared_at; + lval->ts = sym->ts; + lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); + + /* It will always be a full array. */ + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; + lval->rank = as ? as->rank : 0; + if (lval->rank) + gfc_add_full_array_ref (lval, as); + return lval; +} + + +/* Returns the array_spec of a full array expression. A NULL is + returned otherwise. */ +gfc_array_spec * +gfc_get_full_arrayspec_from_expr (gfc_expr *expr) +{ + gfc_array_spec *as; + gfc_ref *ref; + + if (expr->rank == 0) + return NULL; + + /* Follow any component references. */ + if (expr->expr_type == EXPR_VARIABLE + || expr->expr_type == EXPR_CONSTANT) + { + if (expr->symtree) + as = expr->symtree->n.sym->as; + else + as = NULL; + + for (ref = expr->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_COMPONENT: + as = ref->u.c.component->as; + continue; + + case REF_SUBSTRING: + continue; + + case REF_ARRAY: + { + switch (ref->u.ar.type) + { + case AR_ELEMENT: + case AR_SECTION: + case AR_UNKNOWN: + as = NULL; + continue; + + case AR_FULL: + break; + } + break; + } + } + } + } + else + as = NULL; + + return as; +} + + +/* General expression traversal function. */ + +bool +gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, + bool (*func)(gfc_expr *, gfc_symbol *, int*), + int f) +{ + gfc_array_ref ar; + gfc_ref *ref; + gfc_actual_arglist *args; + gfc_constructor *c; + int i; + + if (!expr) + return false; + + if ((*func) (expr, sym, &f)) + return true; + + if (expr->ts.type == BT_CHARACTER + && expr->ts.u.cl + && expr->ts.u.cl->length + && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT + && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f)) + return true; + + switch (expr->expr_type) + { + case EXPR_PPC: + case EXPR_COMPCALL: + case EXPR_FUNCTION: + for (args = expr->value.function.actual; args; args = args->next) + { + if (gfc_traverse_expr (args->expr, sym, func, f)) + return true; + } + break; + + case EXPR_VARIABLE: + case EXPR_CONSTANT: + case EXPR_NULL: + case EXPR_SUBSTRING: + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) + { + if (gfc_traverse_expr (c->expr, sym, func, f)) + return true; + if (c->iterator) + { + if (gfc_traverse_expr (c->iterator->var, sym, func, f)) + return true; + if (gfc_traverse_expr (c->iterator->start, sym, func, f)) + return true; + if (gfc_traverse_expr (c->iterator->end, sym, func, f)) + return true; + if (gfc_traverse_expr (c->iterator->step, sym, func, f)) + return true; + } + } + break; + + case EXPR_OP: + if (gfc_traverse_expr (expr->value.op.op1, sym, func, f)) + return true; + if (gfc_traverse_expr (expr->value.op.op2, sym, func, f)) + return true; + break; + + default: + gcc_unreachable (); + break; + } + + ref = expr->ref; + while (ref != NULL) + { + switch (ref->type) + { + case REF_ARRAY: + ar = ref->u.ar; + for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + { + if (gfc_traverse_expr (ar.start[i], sym, func, f)) + return true; + if (gfc_traverse_expr (ar.end[i], sym, func, f)) + return true; + if (gfc_traverse_expr (ar.stride[i], sym, func, f)) + return true; + } + break; + + case REF_SUBSTRING: + if (gfc_traverse_expr (ref->u.ss.start, sym, func, f)) + return true; + if (gfc_traverse_expr (ref->u.ss.end, sym, func, f)) + return true; + break; + + case REF_COMPONENT: + if (ref->u.c.component->ts.type == BT_CHARACTER + && ref->u.c.component->ts.u.cl + && ref->u.c.component->ts.u.cl->length + && ref->u.c.component->ts.u.cl->length->expr_type + != EXPR_CONSTANT + && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length, + sym, func, f)) + return true; + + if (ref->u.c.component->as) + for (i = 0; i < ref->u.c.component->as->rank + + ref->u.c.component->as->corank; i++) + { + if (gfc_traverse_expr (ref->u.c.component->as->lower[i], + sym, func, f)) + return true; + if (gfc_traverse_expr (ref->u.c.component->as->upper[i], + sym, func, f)) + return true; + } + break; + + default: + gcc_unreachable (); + } + ref = ref->next; + } + return false; +} + +/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */ + +static bool +expr_set_symbols_referenced (gfc_expr *expr, + gfc_symbol *sym ATTRIBUTE_UNUSED, + int *f ATTRIBUTE_UNUSED) +{ + if (expr->expr_type != EXPR_VARIABLE) + return false; + gfc_set_sym_referenced (expr->symtree->n.sym); + return false; +} + +void +gfc_expr_set_symbols_referenced (gfc_expr *expr) +{ + gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0); +} + + +/* Determine if an expression is a procedure pointer component and return + the component in that case. Otherwise return NULL. */ + +gfc_component * +gfc_get_proc_ptr_comp (gfc_expr *expr) +{ + gfc_ref *ref; + + if (!expr || !expr->ref) + return NULL; + + ref = expr->ref; + while (ref->next) + ref = ref->next; + + if (ref->type == REF_COMPONENT + && ref->u.c.component->attr.proc_pointer) + return ref->u.c.component; + + return NULL; +} + + +/* Determine if an expression is a procedure pointer component. */ + +bool +gfc_is_proc_ptr_comp (gfc_expr *expr) +{ + return (gfc_get_proc_ptr_comp (expr) != NULL); +} + + +/* Determine if an expression is a function with an allocatable class scalar + result. */ +bool +gfc_is_alloc_class_scalar_function (gfc_expr *expr) +{ + if (expr->expr_type == EXPR_FUNCTION + && expr->value.function.esym + && expr->value.function.esym->result + && expr->value.function.esym->result->ts.type == BT_CLASS + && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension + && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable) + return true; + + return false; +} + + +/* Determine if an expression is a function with an allocatable class array + result. */ +bool +gfc_is_alloc_class_array_function (gfc_expr *expr) +{ + if (expr->expr_type == EXPR_FUNCTION + && expr->value.function.esym + && expr->value.function.esym->result + && expr->value.function.esym->result->ts.type == BT_CLASS + && CLASS_DATA (expr->value.function.esym->result)->attr.dimension + && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable) + return true; + + return false; +} + + +/* Walk an expression tree and check each variable encountered for being typed. + If strict is not set, a top-level variable is tolerated untyped in -std=gnu + mode as is a basic arithmetic expression using those; this is for things in + legacy-code like: + + INTEGER :: arr(n), n + INTEGER :: arr(n + 1), n + + The namespace is needed for IMPLICIT typing. */ + +static gfc_namespace* check_typed_ns; + +static bool +expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, + int* f ATTRIBUTE_UNUSED) +{ + bool t; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + gcc_assert (e->symtree); + t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns, + true, e->where); + + return (!t); +} + +bool +gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict) +{ + bool error_found; + + /* If this is a top-level variable or EXPR_OP, do the check with strict given + to us. */ + if (!strict) + { + if (e->expr_type == EXPR_VARIABLE && !e->ref) + return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where); + + if (e->expr_type == EXPR_OP) + { + bool t = true; + + gcc_assert (e->value.op.op1); + t = gfc_expr_check_typed (e->value.op.op1, ns, strict); + + if (t && e->value.op.op2) + t = gfc_expr_check_typed (e->value.op.op2, ns, strict); + + return t; + } + } + + /* Otherwise, walk the expression and do it strictly. */ + check_typed_ns = ns; + error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0); + + return error_found ? false : true; +} + + +/* This function returns true if it contains any references to PDT KIND + or LEN parameters. */ + +static bool +derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, + int* f ATTRIBUTE_UNUSED) +{ + if (e->expr_type != EXPR_VARIABLE) + return false; + + gcc_assert (e->symtree); + if (e->symtree->n.sym->attr.pdt_kind + || e->symtree->n.sym->attr.pdt_len) + return true; + + return false; +} + + +bool +gfc_derived_parameter_expr (gfc_expr *e) +{ + return gfc_traverse_expr (e, NULL, &derived_parameter_expr, 0); +} + + +/* This function returns the overall type of a type parameter spec list. + If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the + parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned + unless derived is not NULL. In this latter case, all the LEN parameters + must be either assumed or deferred for the return argument to be set to + anything other than SPEC_EXPLICIT. */ + +gfc_param_spec_type +gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived) +{ + gfc_param_spec_type res = SPEC_EXPLICIT; + gfc_component *c; + bool seen_assumed = false; + bool seen_deferred = false; + + if (derived == NULL) + { + for (; param_list; param_list = param_list->next) + if (param_list->spec_type == SPEC_ASSUMED + || param_list->spec_type == SPEC_DEFERRED) + return param_list->spec_type; + } + else + { + for (; param_list; param_list = param_list->next) + { + c = gfc_find_component (derived, param_list->name, + true, true, NULL); + gcc_assert (c != NULL); + if (c->attr.pdt_kind) + continue; + else if (param_list->spec_type == SPEC_EXPLICIT) + return SPEC_EXPLICIT; + seen_assumed = param_list->spec_type == SPEC_ASSUMED; + seen_deferred = param_list->spec_type == SPEC_DEFERRED; + if (seen_assumed && seen_deferred) + return SPEC_EXPLICIT; + } + res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED; + } + return res; +} + + +bool +gfc_ref_this_image (gfc_ref *ref) +{ + int n; + + gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0); + + for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) + if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) + return false; + + return true; +} + +gfc_expr * +gfc_find_stat_co(gfc_expr *e) +{ + gfc_ref *ref; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return ref->u.ar.stat; + + if (e->value.function.actual->expr) + for (ref = e->value.function.actual->expr->ref; ref; + ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return ref->u.ar.stat; + + return NULL; +} + +bool +gfc_is_coindexed (gfc_expr *e) +{ + gfc_ref *ref; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return !gfc_ref_this_image (ref); + + return false; +} + + +/* Coarrays are variables with a corank but not being coindexed. However, also + the following is a coarray: A subobject of a coarray is a coarray if it does + not have any cosubscripts, vector subscripts, allocatable component + selection, or pointer component selection. (F2008, 2.4.7) */ + +bool +gfc_is_coarray (gfc_expr *e) +{ + gfc_ref *ref; + gfc_symbol *sym; + gfc_component *comp; + bool coindexed; + bool coarray; + int i; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + coindexed = false; + sym = e->symtree->n.sym; + + if (sym->ts.type == BT_CLASS && sym->attr.class_ok) + coarray = CLASS_DATA (sym)->attr.codimension; + else + coarray = sym->attr.codimension; + + for (ref = e->ref; ref; ref = ref->next) + switch (ref->type) + { + case REF_COMPONENT: + comp = ref->u.c.component; + if (comp->ts.type == BT_CLASS && comp->attr.class_ok + && (CLASS_DATA (comp)->attr.class_pointer + || CLASS_DATA (comp)->attr.allocatable)) + { + coindexed = false; + coarray = CLASS_DATA (comp)->attr.codimension; + } + else if (comp->attr.pointer || comp->attr.allocatable) + { + coindexed = false; + coarray = comp->attr.codimension; + } + break; + + case REF_ARRAY: + if (!coarray) + break; + + if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref)) + { + coindexed = true; + break; + } + + for (i = 0; i < ref->u.ar.dimen; i++) + if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) + { + coarray = false; + break; + } + break; + + case REF_SUBSTRING: + break; + } + + return coarray && !coindexed; +} + + +int +gfc_get_corank (gfc_expr *e) +{ + int corank; + gfc_ref *ref; + + if (!gfc_is_coarray (e)) + return 0; + + if (e->ts.type == BT_CLASS && e->ts.u.derived->components) + corank = e->ts.u.derived->components->as + ? e->ts.u.derived->components->as->corank : 0; + else + corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY) + corank = ref->u.ar.as->corank; + gcc_assert (ref->type != REF_SUBSTRING); + } + + return corank; +} + + +/* Check whether the expression has an ultimate allocatable component. + Being itself allocatable does not count. */ +bool +gfc_has_ultimate_allocatable (gfc_expr *e) +{ + gfc_ref *ref, *last = NULL; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + last = ref; + + if (last && last->u.c.component->ts.type == BT_CLASS) + return CLASS_DATA (last->u.c.component)->attr.alloc_comp; + else if (last && last->u.c.component->ts.type == BT_DERIVED) + return last->u.c.component->ts.u.derived->attr.alloc_comp; + else if (last) + return false; + + if (e->ts.type == BT_CLASS) + return CLASS_DATA (e)->attr.alloc_comp; + else if (e->ts.type == BT_DERIVED) + return e->ts.u.derived->attr.alloc_comp; + else + return false; +} + + +/* Check whether the expression has an pointer component. + Being itself a pointer does not count. */ +bool +gfc_has_ultimate_pointer (gfc_expr *e) +{ + gfc_ref *ref, *last = NULL; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + last = ref; + + if (last && last->u.c.component->ts.type == BT_CLASS) + return CLASS_DATA (last->u.c.component)->attr.pointer_comp; + else if (last && last->u.c.component->ts.type == BT_DERIVED) + return last->u.c.component->ts.u.derived->attr.pointer_comp; + else if (last) + return false; + + if (e->ts.type == BT_CLASS) + return CLASS_DATA (e)->attr.pointer_comp; + else if (e->ts.type == BT_DERIVED) + return e->ts.u.derived->attr.pointer_comp; + else + return false; +} + + +/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4. + Note: A scalar is not regarded as "simply contiguous" by the standard. + if bool is not strict, some further checks are done - for instance, + a "(::1)" is accepted. */ + +bool +gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element) +{ + bool colon; + int i; + gfc_array_ref *ar = NULL; + gfc_ref *ref, *part_ref = NULL; + gfc_symbol *sym; + + if (expr->expr_type == EXPR_FUNCTION) + return expr->value.function.esym + ? expr->value.function.esym->result->attr.contiguous : false; + else if (expr->expr_type != EXPR_VARIABLE) + return false; + + if (!permit_element && expr->rank == 0) + return false; + + for (ref = expr->ref; ref; ref = ref->next) + { + if (ar) + return false; /* Array shall be last part-ref. */ + + if (ref->type == REF_COMPONENT) + part_ref = ref; + else if (ref->type == REF_SUBSTRING) + return false; + else if (ref->u.ar.type != AR_ELEMENT) + ar = &ref->u.ar; + } + + sym = expr->symtree->n.sym; + if (expr->ts.type != BT_CLASS + && ((part_ref + && !part_ref->u.c.component->attr.contiguous + && part_ref->u.c.component->attr.pointer) + || (!part_ref + && !sym->attr.contiguous + && (sym->attr.pointer + || sym->as->type == AS_ASSUMED_RANK + || sym->as->type == AS_ASSUMED_SHAPE)))) + return false; + + if (!ar || ar->type == AR_FULL) + return true; + + gcc_assert (ar->type == AR_SECTION); + + /* Check for simply contiguous array */ + colon = true; + for (i = 0; i < ar->dimen; i++) + { + if (ar->dimen_type[i] == DIMEN_VECTOR) + return false; + + if (ar->dimen_type[i] == DIMEN_ELEMENT) + { + colon = false; + continue; + } + + gcc_assert (ar->dimen_type[i] == DIMEN_RANGE); + + + /* If the previous section was not contiguous, that's an error, + unless we have effective only one element and checking is not + strict. */ + if (!colon && (strict || !ar->start[i] || !ar->end[i] + || ar->start[i]->expr_type != EXPR_CONSTANT + || ar->end[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->start[i]->value.integer, + ar->end[i]->value.integer) != 0)) + return false; + + /* Following the standard, "(::1)" or - if known at compile time - + "(lbound:ubound)" are not simply contiguous; if strict + is false, they are regarded as simply contiguous. */ + if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT + || ar->stride[i]->ts.type != BT_INTEGER + || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)) + return false; + + if (ar->start[i] + && (strict || ar->start[i]->expr_type != EXPR_CONSTANT + || !ar->as->lower[i] + || ar->as->lower[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->start[i]->value.integer, + ar->as->lower[i]->value.integer) != 0)) + colon = false; + + if (ar->end[i] + && (strict || ar->end[i]->expr_type != EXPR_CONSTANT + || !ar->as->upper[i] + || ar->as->upper[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->end[i]->value.integer, + ar->as->upper[i]->value.integer) != 0)) + colon = false; + } + + return true; +} + + +/* Build call to an intrinsic procedure. The number of arguments has to be + passed (rather than ending the list with a NULL value) because we may + want to add arguments but with a NULL-expression. */ + +gfc_expr* +gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name, + locus where, unsigned numarg, ...) +{ + gfc_expr* result; + gfc_actual_arglist* atail; + gfc_intrinsic_sym* isym; + va_list ap; + unsigned i; + const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name); + + isym = gfc_intrinsic_function_by_id (id); + gcc_assert (isym); + + result = gfc_get_expr (); + result->expr_type = EXPR_FUNCTION; + result->ts = isym->ts; + result->where = where; + result->value.function.name = mangled_name; + result->value.function.isym = isym; + + gfc_get_sym_tree (mangled_name, ns, &result->symtree, false); + gfc_commit_symbol (result->symtree->n.sym); + gcc_assert (result->symtree + && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE + || result->symtree->n.sym->attr.flavor == FL_UNKNOWN)); + result->symtree->n.sym->intmod_sym_id = id; + result->symtree->n.sym->attr.flavor = FL_PROCEDURE; + result->symtree->n.sym->attr.intrinsic = 1; + result->symtree->n.sym->attr.artificial = 1; + + va_start (ap, numarg); + atail = NULL; + for (i = 0; i < numarg; ++i) + { + if (atail) + { + atail->next = gfc_get_actual_arglist (); + atail = atail->next; + } + else + atail = result->value.function.actual = gfc_get_actual_arglist (); + + atail->expr = va_arg (ap, gfc_expr*); + } + va_end (ap); + + return result; +} + + +/* Check if an expression may appear in a variable definition context + (F2008, 16.6.7) or pointer association context (F2008, 16.6.8). + This is called from the various places when resolving + the pieces that make up such a context. + If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do + variables), some checks are not performed. + + Optionally, a possible error message can be suppressed if context is NULL + and just the return status (true / false) be requested. */ + +bool +gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, + bool own_scope, const char* context) +{ + gfc_symbol* sym = NULL; + bool is_pointer; + bool check_intentin; + bool ptr_component; + symbol_attribute attr; + gfc_ref* ref; + int i; + + if (e->expr_type == EXPR_VARIABLE) + { + gcc_assert (e->symtree); + sym = e->symtree->n.sym; + } + else if (e->expr_type == EXPR_FUNCTION) + { + gcc_assert (e->symtree); + sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym; + } + + attr = gfc_expr_attr (e); + if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer) + { + if (!(gfc_option.allow_std & GFC_STD_F2008)) + { + if (context) + gfc_error ("Fortran 2008: Pointer functions in variable definition" + " context (%s) at %L", context, &e->where); + return false; + } + } + else if (e->expr_type != EXPR_VARIABLE) + { + if (context) + gfc_error ("Non-variable expression in variable definition context (%s)" + " at %L", context, &e->where); + return false; + } + + if (!pointer && sym->attr.flavor == FL_PARAMETER) + { + if (context) + gfc_error ("Named constant %qs in variable definition context (%s)" + " at %L", sym->name, context, &e->where); + return false; + } + if (!pointer && sym->attr.flavor != FL_VARIABLE + && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result) + && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)) + { + if (context) + gfc_error ("%qs in variable definition context (%s) at %L is not" + " a variable", sym->name, context, &e->where); + return false; + } + + /* Find out whether the expr is a pointer; this also means following + component references to the last one. */ + is_pointer = (attr.pointer || attr.proc_pointer); + if (pointer && !is_pointer) + { + if (context) + gfc_error ("Non-POINTER in pointer association context (%s)" + " at %L", context, &e->where); + return false; + } + + if (e->ts.type == BT_DERIVED + && e->ts.u.derived == NULL) + { + if (context) + gfc_error ("Type inaccessible in variable definition context (%s) " + "at %L", context, &e->where); + return false; + } + + /* F2008, C1303. */ + if (!alloc_obj + && (attr.lock_comp + || (e->ts.type == BT_DERIVED + && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))) + { + if (context) + gfc_error ("LOCK_TYPE in variable definition context (%s) at %L", + context, &e->where); + return false; + } + + /* TS18508, C702/C203. */ + if (!alloc_obj + && (attr.lock_comp + || (e->ts.type == BT_DERIVED + && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE))) + { + if (context) + gfc_error ("LOCK_EVENT in variable definition context (%s) at %L", + context, &e->where); + return false; + } + + /* INTENT(IN) dummy argument. Check this, unless the object itself is the + component of sub-component of a pointer; we need to distinguish + assignment to a pointer component from pointer-assignment to a pointer + component. Note that (normal) assignment to procedure pointers is not + possible. */ + check_intentin = !own_scope; + ptr_component = (sym->ts.type == BT_CLASS && sym->ts.u.derived + && CLASS_DATA (sym)) + ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; + for (ref = e->ref; ref && check_intentin; ref = ref->next) + { + if (ptr_component && ref->type == REF_COMPONENT) + check_intentin = false; + if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) + { + ptr_component = true; + if (!pointer) + check_intentin = false; + } + } + if (check_intentin && sym->attr.intent == INTENT_IN) + { + if (pointer && is_pointer) + { + if (context) + gfc_error ("Dummy argument %qs with INTENT(IN) in pointer" + " association context (%s) at %L", + sym->name, context, &e->where); + return false; + } + if (!pointer && !is_pointer && !sym->attr.pointer) + { + if (context) + gfc_error ("Dummy argument %qs with INTENT(IN) in variable" + " definition context (%s) at %L", + sym->name, context, &e->where); + return false; + } + } + + /* PROTECTED and use-associated. */ + if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin) + { + if (pointer && is_pointer) + { + if (context) + gfc_error ("Variable %qs is PROTECTED and can not appear in a" + " pointer association context (%s) at %L", + sym->name, context, &e->where); + return false; + } + if (!pointer && !is_pointer) + { + if (context) + gfc_error ("Variable %qs is PROTECTED and can not appear in a" + " variable definition context (%s) at %L", + sym->name, context, &e->where); + return false; + } + } + + /* Variable not assignable from a PURE procedure but appears in + variable definition context. */ + if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym)) + { + if (context) + gfc_error ("Variable %qs can not appear in a variable definition" + " context (%s) at %L in PURE procedure", + sym->name, context, &e->where); + return false; + } + + if (!pointer && context && gfc_implicit_pure (NULL) + && gfc_impure_variable (sym)) + { + gfc_namespace *ns; + gfc_symbol *sym; + + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + sym = ns->proc_name; + if (sym == NULL) + break; + if (sym->attr.flavor == FL_PROCEDURE) + { + sym->attr.implicit_pure = 0; + break; + } + } + } + /* Check variable definition context for associate-names. */ + if (!pointer && sym->assoc) + { + const char* name; + gfc_association_list* assoc; + + gcc_assert (sym->assoc->target); + + /* If this is a SELECT TYPE temporary (the association is used internally + for SELECT TYPE), silently go over to the target. */ + if (sym->attr.select_type_temporary) + { + gfc_expr* t = sym->assoc->target; + + gcc_assert (t->expr_type == EXPR_VARIABLE); + name = t->symtree->name; + + if (t->symtree->n.sym->assoc) + assoc = t->symtree->n.sym->assoc; + else + assoc = sym->assoc; + } + else + { + name = sym->name; + assoc = sym->assoc; + } + gcc_assert (name && assoc); + + /* Is association to a valid variable? */ + if (!assoc->variable) + { + if (context) + { + if (assoc->target->expr_type == EXPR_VARIABLE) + gfc_error ("%qs at %L associated to vector-indexed target can" + " not be used in a variable definition context (%s)", + name, &e->where, context); + else + gfc_error ("%qs at %L associated to expression can" + " not be used in a variable definition context (%s)", + name, &e->where, context); + } + return false; + } + + /* Target must be allowed to appear in a variable definition context. */ + if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) + { + if (context) + gfc_error ("Associate-name %qs can not appear in a variable" + " definition context (%s) at %L because its target" + " at %L can not, either", + name, context, &e->where, + &assoc->target->where); + return false; + } + } + + /* Check for same value in vector expression subscript. */ + + if (e->rank > 0) + for (ref = e->ref; ref != NULL; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) + for (i = 0; i < GFC_MAX_DIMENSIONS + && ref->u.ar.dimen_type[i] != 0; i++) + if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) + { + gfc_expr *arr = ref->u.ar.start[i]; + if (arr->expr_type == EXPR_ARRAY) + { + gfc_constructor *c, *n; + gfc_expr *ec, *en; + + for (c = gfc_constructor_first (arr->value.constructor); + c != NULL; c = gfc_constructor_next (c)) + { + if (c == NULL || c->iterator != NULL) + continue; + + ec = c->expr; + + for (n = gfc_constructor_next (c); n != NULL; + n = gfc_constructor_next (n)) + { + if (n->iterator != NULL) + continue; + + en = n->expr; + if (gfc_dep_compare_expr (ec, en) == 0) + { + if (context) + gfc_error_now ("Elements with the same value " + "at %L and %L in vector " + "subscript in a variable " + "definition context (%s)", + &(ec->where), &(en->where), + context); + return false; + } + } + } + } + } + + return true; +}