diff options
Diffstat (limited to 'gcc-4.8.1/gcc/fortran/expr.c')
| -rw-r--r-- | gcc-4.8.1/gcc/fortran/expr.c | 4901 |
1 files changed, 0 insertions, 4901 deletions
diff --git a/gcc-4.8.1/gcc/fortran/expr.c b/gcc-4.8.1/gcc/fortran/expr.c deleted file mode 100644 index d16bdb090..000000000 --- a/gcc-4.8.1/gcc/fortran/expr.c +++ /dev/null @@ -1,4901 +0,0 @@ -/* Routines for manipulation of expression nodes. - Copyright (C) 2000-2013 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 "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_DERIVED: - 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); - - 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); - - 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; - 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. - Returns an error message or NULL if the result is set. It is - tempting to generate an error and return SUCCESS or FAILURE, but - failure is OK for some callers. */ - -const char * -gfc_extract_int (gfc_expr *expr, int *result) -{ - if (expr->expr_type != EXPR_CONSTANT) - return _("Constant expression required at %C"); - - if (expr->ts.type != BT_INTEGER) - return _("Integer expression required at %C"); - - if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0) - || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0)) - { - return _("Integer value too large in expression at %C"); - } - - *result = (int) mpz_get_si (expr->value.integer); - - return NULL; -} - - -/* 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 = 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; -} - - -/* Function to determine if an expression is constant or not. This - function expects that the expression has already been simplified. */ - -int -gfc_is_constant_expr (gfc_expr *e) -{ - gfc_constructor *c; - gfc_actual_arglist *arg; - gfc_symbol *sym; - - if (e == NULL) - return 1; - - 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: - return 0; - - 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 0; - } - - /* Specification functions are constant. */ - /* F95, 7.1.6.2; F2003, 7.1.7 */ - sym = NULL; - if (e->symtree) - sym = e->symtree->n.sym; - if (e->value.function.esym) - sym = e->value.function.esym; - - if (sym - && sym->attr.function - && sym->attr.pure - && !sym->attr.intrinsic - && !sym->attr.recursive - && sym->attr.proc != PROC_INTERNAL - && sym->attr.proc != PROC_ST_FUNCTION - && sym->attr.proc != PROC_UNKNOWN - && gfc_sym_get_dummy_args (sym) == NULL) - return 1; - - 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 1; - - return 0; - - case EXPR_CONSTANT: - case EXPR_NULL: - return 1; - - 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 0; - - return 1; - - - default: - gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type"); - return 0; - } -} - - -/* 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; - - 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 gfc_try -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 SUCCESS; - - op1 = p->value.op.op1; - op2 = p->value.op.op2; - op = p->value.op.op; - - if (gfc_simplify_expr (op1, type) == FAILURE) - return FAILURE; - if (gfc_simplify_expr (op2, type) == FAILURE) - return FAILURE; - - if (!gfc_is_constant_expr (op1) - || (op2 != NULL && !gfc_is_constant_expr (op2))) - return SUCCESS; - - /* 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 FAILURE; - } - - result->rank = p->rank; - result->where = p->where; - gfc_replace_expr (p, result); - - return SUCCESS; -} - - -/* Subroutine to simplify constructor expressions. Mutually recursive - with gfc_simplify_expr(). */ - -static gfc_try -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) == FAILURE - || gfc_simplify_expr (c->iterator->end, type) == FAILURE - || gfc_simplify_expr (c->iterator->step, type) == FAILURE)) - return FAILURE; - - 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) == FAILURE) - { - gfc_free_expr (p); - continue; - } - - gfc_replace_expr (c->expr, p); - } - } - - return SUCCESS; -} - - -/* Pull a single array element out of an array constructor. */ - -static gfc_try -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; - gfc_try t; - - t = SUCCESS; - 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]) == FAILURE - || gfc_reduce_init_expr (ar->as->upper[i]) == FAILURE) - { - t = FAILURE; - cons = NULL; - goto depart; - } - - e = gfc_copy_expr (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 = FAILURE; - 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); - if (e) - gfc_free_expr (e); - *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 *comp; - gfc_component *pick; - gfc_constructor *c = gfc_constructor_first (base); - - comp = ref->u.c.sym->components; - pick = ref->u.c.component; - 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 gfc_try -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; - gfc_try t; - - t = SUCCESS; - - 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 = FAILURE; - 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 = FAILURE; - goto cleanup; - } - } - } - else - { - if ((begin && begin->expr_type != EXPR_CONSTANT) - || (finish && finish->expr_type != EXPR_CONSTANT) - || (step && step->expr_type != EXPR_CONSTANT)) - { - t = FAILURE; - 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 = FAILURE; - 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 >= gfc_option.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, - gfc_option.flag_max_array_constructor); - return FAILURE; - } - - 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 gfc_try -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 FAILURE; - - *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 SUCCESS; -} - - - -/* Simplify a subobject reference of a constructor. This occurs when - parameter variable values are substituted. */ - -static gfc_try -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) == FAILURE) - return FAILURE; - - if (!cons) - return SUCCESS; - - remove_subobject_ref (p, cons); - break; - - case AR_SECTION: - if (find_array_section (p, p->ref) == FAILURE) - return FAILURE; - p->ref->u.ar.type = AR_FULL; - - /* Fall through. */ - - case AR_FULL: - if (p->ref->next != NULL - && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED)) - { - 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) == FAILURE) - return FAILURE; - } - - if (p->ts.type == BT_DERIVED - && 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 SUCCESS; - } - - 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) == FAILURE) - return FAILURE; - - gfc_replace_expr (p, newp); - gfc_free_ref_list (p->ref); - p->ref = NULL; - break; - } - } - - return SUCCESS; -} - - -/* Simplify a chain of references. */ - -static gfc_try -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) == FAILURE) - return FAILURE; - if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE) - return FAILURE; - if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE) - return FAILURE; - } - break; - - case REF_SUBSTRING: - if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE) - return FAILURE; - if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE) - return FAILURE; - break; - - default: - break; - } - } - return SUCCESS; -} - - -/* Try to substitute the value of a parameter variable. */ - -static gfc_try -simplify_parameter_variable (gfc_expr *p, int type) -{ - gfc_expr *e; - gfc_try t; - - e = gfc_copy_expr (p->symtree->n.sym->value); - if (e == NULL) - return FAILURE; - - 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 == SUCCESS && !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 FAILURE on error, SUCCESS otherwise. - NOTE: Will return SUCCESS even if the expression can not be simplified. */ - -gfc_try -gfc_simplify_expr (gfc_expr *p, int type) -{ - gfc_actual_arglist *ap; - - if (p == NULL) - return SUCCESS; - - 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) == FAILURE) - return FAILURE; - - if (p->value.function.isym != NULL - && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR) - return FAILURE; - - break; - - case EXPR_SUBSTRING: - if (simplify_ref_chain (p->ref, type) == FAILURE) - return FAILURE; - - 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) == FAILURE) - return FAILURE; - 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) == FAILURE) - return FAILURE; - break; - } - - if (type == 1) - { - gfc_simplify_iterator_var (p); - } - - /* Simplify subcomponent references. */ - if (simplify_ref_chain (p->ref, type) == FAILURE) - return FAILURE; - - break; - - case EXPR_STRUCTURE: - case EXPR_ARRAY: - if (simplify_ref_chain (p->ref, type) == FAILURE) - return FAILURE; - - if (simplify_constructor (p->value.constructor, type) == FAILURE) - return FAILURE; - - 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) == FAILURE) - return FAILURE; - - break; - - case EXPR_COMPCALL: - case EXPR_PPC: - gcc_unreachable (); - break; - } - - return SUCCESS; -} - - -/* 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) == SUCCESS) - return BT_INTEGER; - - return e->ts.type; -} - - -/* Scalarize an expression for an elemental intrinsic call. */ - -static gfc_try -scalarize_intrinsic_call (gfc_expr *e) -{ - gfc_actual_arglist *a, *b; - gfc_constructor_base ctor; - gfc_constructor *args[5]; - 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->expr_type != EXPR_ARRAY) - continue; - array_arg = n; - expr = gfc_copy_expr (a->expr); - break; - } - - if (!array_arg) - return FAILURE; - - 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) == FAILURE) - 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 SUCCESS; - -compliance: - gfc_error_now ("elemental function arguments at %C are not compliant"); - -cleanup: - gfc_free_expr (expr); - gfc_free_expr (old); - return FAILURE; -} - - -static gfc_try -check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *)) -{ - gfc_expr *op1 = e->value.op.op1; - gfc_expr *op2 = e->value.op.op2; - - if ((*check_function) (op1) == FAILURE) - return FAILURE; - - 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) == FAILURE) - return FAILURE; - - 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 FAILURE; - } - break; - - case INTRINSIC_PLUS: - case INTRINSIC_MINUS: - case INTRINSIC_TIMES: - case INTRINSIC_DIVIDE: - case INTRINSIC_POWER: - if ((*check_function) (op2) == FAILURE) - return FAILURE; - - if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2))) - goto not_numeric; - - break; - - case INTRINSIC_CONCAT: - if ((*check_function) (op2) == FAILURE) - return FAILURE; - - 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 FAILURE; - } - - if (op1->ts.kind != op2->ts.kind) - { - gfc_error ("Concat operator at %L must concatenate strings of the " - "same kind", &e->where); - return FAILURE; - } - - 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 FAILURE; - } - - break; - - case INTRINSIC_AND: - case INTRINSIC_OR: - case INTRINSIC_EQV: - case INTRINSIC_NEQV: - if ((*check_function) (op2) == FAILURE) - return FAILURE; - - if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL) - { - gfc_error ("LOGICAL operands are required in expression at %L", - &e->where); - return FAILURE; - } - - break; - - case INTRINSIC_PARENTHESES: - break; - - default: - gfc_error ("Only intrinsic operators can be used in expression at %L", - &e->where); - return FAILURE; - } - - return SUCCESS; - -not_numeric: - gfc_error ("Numeric operands are required in expression at %L", &e->where); - - return FAILURE; -} - -/* F2003, 7.1.7 (3): In init expression, allocatable components - must not be data-initialized. */ -static gfc_try -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); - - 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->expr_type != EXPR_NULL) - { - gfc_error("Invalid initialization expression for ALLOCATABLE " - "component '%s' in structure constructor at %L", - comp->name, &ctor->expr->where); - return FAILURE; - } - } - - return SUCCESS; -} - -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) == FAILURE) - return MATCH_ERROR; - - return MATCH_YES; -} - -static gfc_try 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; - 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; - - 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) - == FAILURE) - 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 '%s' " - " 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) == FAILURE) - return MATCH_ERROR; - - if (not_restricted == 0 - && ap->expr->expr_type != EXPR_VARIABLE - && check_restricted (ap->expr) == FAILURE) - 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 '%s' 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) == FAILURE) - 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 - FAILURE is returned an error message has been generated. */ - -gfc_try -gfc_check_init_expr (gfc_expr *e) -{ - match m; - gfc_try t; - - if (e == NULL) - return SUCCESS; - - switch (e->expr_type) - { - case EXPR_OP: - t = check_intrinsic_op (e, gfc_check_init_expr); - if (t == SUCCESS) - t = gfc_simplify_expr (e, 0); - - break; - - case EXPR_FUNCTION: - t = FAILURE; - - { - gfc_intrinsic_sym* isym; - gfc_symbol* sym; - - sym = e->symtree->n.sym; - if (!gfc_is_intrinsic (sym, 0, e->where) - || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES) - { - gfc_error ("Function '%s' 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 '%s' at %L is not permitted " - "in an initialization expression", - e->symtree->n.sym->name, &e->where); - m = MATCH_ERROR; - } - - if (m == MATCH_ERROR) - return FAILURE; - - /* 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)) == SUCCESS) - break; - } - - if (m == MATCH_YES) - t = gfc_simplify_expr (e, 0); - - break; - - case EXPR_VARIABLE: - t = SUCCESS; - - if (gfc_check_iter_variable (e) == SUCCESS) - 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 '%s' is used at %L before its definition " - "is complete", e->symtree->n.sym->name, &e->where); - t = FAILURE; - } - else - t = simplify_parameter_variable (e, 0); - - break; - } - - if (gfc_in_match_data ()) - break; - - t = FAILURE; - - if (e->symtree->n.sym->as) - { - switch (e->symtree->n.sym->as->type) - { - case AS_ASSUMED_SIZE: - gfc_error ("Assumed size array '%s' 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 '%s' at %L is not permitted " - "in an initialization expression", - e->symtree->n.sym->name, &e->where); - break; - - case AS_DEFERRED: - gfc_error ("Deferred array '%s' at %L is not permitted " - "in an initialization expression", - e->symtree->n.sym->name, &e->where); - break; - - case AS_EXPLICIT: - gfc_error ("Array '%s' 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 '%s' at %L has not been declared or is " - "a variable, which does not reduce to a constant " - "expression", e->symtree->n.sym->name, &e->where); - - break; - - case EXPR_CONSTANT: - case EXPR_NULL: - t = SUCCESS; - break; - - case EXPR_SUBSTRING: - t = gfc_check_init_expr (e->ref->u.ss.start); - if (t == FAILURE) - break; - - t = gfc_check_init_expr (e->ref->u.ss.end); - if (t == SUCCESS) - t = gfc_simplify_expr (e, 0); - - break; - - case EXPR_STRUCTURE: - t = e->ts.is_iso_c ? SUCCESS : FAILURE; - if (t == SUCCESS) - break; - - t = check_alloc_comp_init (e); - if (t == FAILURE) - break; - - t = gfc_check_constructor (e, gfc_check_init_expr); - if (t == FAILURE) - break; - - break; - - case EXPR_ARRAY: - t = gfc_check_constructor (e, gfc_check_init_expr); - if (t == FAILURE) - break; - - t = gfc_expand_constructor (e, true); - if (t == FAILURE) - 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 FAILURE. */ - -gfc_try -gfc_reduce_init_expr (gfc_expr *expr) -{ - gfc_try t; - - gfc_init_expr_flag = true; - t = gfc_resolve_expr (expr); - if (t == SUCCESS) - t = gfc_check_init_expr (expr); - gfc_init_expr_flag = false; - - if (t == FAILURE) - return FAILURE; - - if (expr->expr_type == EXPR_ARRAY) - { - if (gfc_check_constructor_type (expr) == FAILURE) - return FAILURE; - if (gfc_expand_constructor (expr, true) == FAILURE) - return FAILURE; - } - - return SUCCESS; -} - - -/* 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; - gfc_try t; - - expr = NULL; - - gfc_init_expr_flag = true; - - m = gfc_match_expr (&expr); - if (m != MATCH_YES) - { - gfc_init_expr_flag = false; - return m; - } - - t = gfc_reduce_init_expr (expr); - if (t != SUCCESS) - { - 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 gfc_try -restricted_args (gfc_actual_arglist *a) -{ - for (; a; a = a->next) - { - if (check_restricted (a->expr) == FAILURE) - return FAILURE; - } - - return SUCCESS; -} - - -/************* Restricted/specification expressions *************/ - - -/* Make sure a non-intrinsic function is a specification function. */ - -static gfc_try -external_spec_function (gfc_expr *e) -{ - gfc_symbol *f; - - f = e->value.function.esym; - - if (f->attr.proc == PROC_ST_FUNCTION) - { - gfc_error ("Specification function '%s' at %L cannot be a statement " - "function", f->name, &e->where); - return FAILURE; - } - - if (f->attr.proc == PROC_INTERNAL) - { - gfc_error ("Specification function '%s' at %L cannot be an internal " - "function", f->name, &e->where); - return FAILURE; - } - - if (!f->attr.pure && !f->attr.elemental) - { - gfc_error ("Specification function '%s' at %L must be PURE", f->name, - &e->where); - return FAILURE; - } - - if (f->attr.recursive) - { - gfc_error ("Specification function '%s' at %L cannot be RECURSIVE", - f->name, &e->where); - return FAILURE; - } - - return restricted_args (e->value.function.actual); -} - - -/* Check to see that a function reference to an intrinsic is a - restricted expression. */ - -static gfc_try -restricted_intrinsic (gfc_expr *e) -{ - /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */ - if (check_inquiry (e, 0) == MATCH_YES) - return SUCCESS; - - return restricted_args (e->value.function.actual); -} - - -/* Check the expressions of an actual arglist. Used by check_restricted. */ - -static gfc_try -check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*)) -{ - for (; arg; arg = arg->next) - if (checker (arg->expr) == FAILURE) - return FAILURE; - - return SUCCESS; -} - - -/* Check the subscription expressions of a reference chain with a checking - function; used by check_restricted. */ - -static gfc_try -check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*)) -{ - int dim; - - if (!ref) - return SUCCESS; - - switch (ref->type) - { - case REF_ARRAY: - for (dim = 0; dim != ref->u.ar.dimen; ++dim) - { - if (checker (ref->u.ar.start[dim]) == FAILURE) - return FAILURE; - if (checker (ref->u.ar.end[dim]) == FAILURE) - return FAILURE; - if (checker (ref->u.ar.stride[dim]) == FAILURE) - return FAILURE; - } - break; - - case REF_COMPONENT: - /* Nothing needed, just proceed to next reference. */ - break; - - case REF_SUBSTRING: - if (checker (ref->u.ss.start) == FAILURE) - return FAILURE; - if (checker (ref->u.ss.end) == FAILURE) - return FAILURE; - break; - - default: - gcc_unreachable (); - break; - } - - return check_references (ref->next, checker); -} - - -/* Verify that an expression is a restricted expression. Like its - cousin check_init_expr(), an error message is generated if we - return FAILURE. */ - -static gfc_try -check_restricted (gfc_expr *e) -{ - gfc_symbol* sym; - gfc_try t; - - if (e == NULL) - return SUCCESS; - - switch (e->expr_type) - { - case EXPR_OP: - t = check_intrinsic_op (e, check_restricted); - if (t == SUCCESS) - 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 == SUCCESS) - t = external_spec_function (e); - } - else - { - if (e->value.function.isym && e->value.function.isym->inquiry) - t = SUCCESS; - else - t = check_arglist (e->value.function.actual, &check_restricted); - - if (t == SUCCESS) - t = restricted_intrinsic (e); - } - break; - - case EXPR_VARIABLE: - sym = e->symtree->n.sym; - t = FAILURE; - - /* 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 '%s' not allowed in expression at %L", - sym->name, &e->where); - break; - } - - if (sym->attr.optional) - { - gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL", - sym->name, &e->where); - break; - } - - if (sym->attr.intent == INTENT_OUT) - { - gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)", - sym->name, &e->where); - break; - } - - /* Check reference chain if any. */ - if (check_references (e->ref, &check_restricted) == FAILURE) - 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 - || (sym->ns && sym->ns == gfc_current_ns->parent) - || (sym->ns && gfc_current_ns->parent - && sym->ns == gfc_current_ns->parent->parent) - || (sym->ns->proc_name != NULL - && sym->ns->proc_name->attr.flavor == FL_MODULE) - || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns))) - { - t = SUCCESS; - break; - } - - gfc_error ("Variable '%s' 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 = SUCCESS; - break; - - case EXPR_SUBSTRING: - t = gfc_specification_expr (e->ref->u.ss.start); - if (t == FAILURE) - break; - - t = gfc_specification_expr (e->ref->u.ss.end); - if (t == SUCCESS) - 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 FAILURE, an error has been generated. */ - -gfc_try -gfc_specification_expr (gfc_expr *e) -{ - gfc_component *comp; - - if (e == NULL) - return SUCCESS; - - 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 FAILURE; - } - - 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 '%s' at %L must be PURE", - e->symtree->n.sym->name, &e->where); - /* Prevent repeat error messages. */ - e->symtree->n.sym->attr.pure = 1; - return FAILURE; - } - - if (e->rank != 0) - { - gfc_error ("Expression at %L must be scalar", &e->where); - return FAILURE; - } - - if (gfc_simplify_expr (e, 0) == FAILURE) - return FAILURE; - - return check_restricted (e); -} - - -/************** Expression conformance checks. *************/ - -/* Given two expressions, make sure that the arrays are conformable. */ - -gfc_try -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; - gfc_try t; - - va_list argp; - char buffer[240]; - - if (op1->rank == 0 || op2->rank == 0) - return SUCCESS; - - 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 FAILURE; - } - - t = SUCCESS; - - for (d = 0; d < op1->rank; d++) - { - op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS; - op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS; - - 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 = FAILURE; - } - - if (op1_flag) - mpz_clear (op1_size); - if (op2_flag) - mpz_clear (op2_size); - - if (t == FAILURE) - return FAILURE; - } - - return SUCCESS; -} - - -/* Given an assignable expression and an arbitrary expression, make - sure that the assignment can take place. */ - -gfc_try -gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) -{ - 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->attr.is_main_program) - bad_proc = true; - - /* (iii) A module or internal procedure... */ - if ((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->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 ("'%s' at %L is not a VALUE", sym->name, &lvalue->where); - return FAILURE; - } - } - - 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 FAILURE; - } - - if (lvalue->ts.type == BT_UNKNOWN) - { - gfc_error ("Variable type is UNKNOWN in assignment at %L", - &lvalue->where); - return FAILURE; - } - - if (rvalue->expr_type == EXPR_NULL) - { - if (has_pointer && (ref == NULL || ref->next == NULL) - && lvalue->symtree->n.sym->attr.data) - return SUCCESS; - else - { - gfc_error ("NULL appears on right-hand side in assignment at %L", - &rvalue->where); - return FAILURE; - } - } - - /* This is possibly a typo: x = f() instead of x => f(). */ - if (gfc_option.warn_surprising - && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer) - gfc_warning ("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") != SUCCESS) - return FAILURE; - - 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 '%s'", - &rvalue->where, lvalue->symtree->n.sym->name) - == FAILURE) - return FAILURE; - 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) == FAILURE) - return FAILURE; - - /* Handle the case of a BOZ literal on the RHS. */ - if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER) - { - int rc; - if (gfc_option.warn_surprising) - gfc_warning ("BOZ literal at %L is bitwise transferred " - "non-integer symbol '%s'", &rvalue->where, - lvalue->symtree->n.sym->name); - if (!gfc_convert_boz (rvalue, &lvalue->ts)) - return FAILURE; - 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 FAILURE; - } - } - - /* Warn about type-changing conversions for REAL or COMPLEX constants. - If lvalue and rvalue are mixed REAL and complex, gfc_compare_types - will warn anyway, so there is no need to to so here. */ - - if (rvalue->expr_type == EXPR_CONSTANT && lvalue->ts.type == rvalue->ts.type - && (lvalue->ts.type == BT_REAL || lvalue->ts.type == BT_COMPLEX)) - { - if (lvalue->ts.kind < rvalue->ts.kind && gfc_option.gfc_warn_conversion) - { - /* As a special bonus, don't warn about REAL rvalues which are not - changed by the conversion if -Wconversion is specified. */ - if (rvalue->ts.type == BT_REAL && mpfr_number_p (rvalue->value.real)) - { - /* Calculate the difference between the constant and the rounded - value and check it against zero. */ - mpfr_t rv, diff; - gfc_set_model_kind (lvalue->ts.kind); - mpfr_init (rv); - gfc_set_model_kind (rvalue->ts.kind); - mpfr_init (diff); - - mpfr_set (rv, rvalue->value.real, GFC_RND_MODE); - mpfr_sub (diff, rv, rvalue->value.real, GFC_RND_MODE); - - if (!mpfr_zero_p (diff)) - gfc_warning ("Change of value in conversion from " - " %s to %s at %L", gfc_typename (&rvalue->ts), - gfc_typename (&lvalue->ts), &rvalue->where); - - mpfr_clear (rv); - mpfr_clear (diff); - } - else - gfc_warning ("Possible change of value in conversion from %s " - "to %s at %L",gfc_typename (&rvalue->ts), - gfc_typename (&lvalue->ts), &rvalue->where); - - } - else if (gfc_option.warn_conversion_extra - && lvalue->ts.kind > rvalue->ts.kind) - { - gfc_warning ("Conversion from %s to %s at %L", - gfc_typename (&rvalue->ts), - gfc_typename (&lvalue->ts), &rvalue->where); - } - } - - if (gfc_compare_types (&lvalue->ts, &rvalue->ts)) - return SUCCESS; - - /* 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 SUCCESS; - - if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) - return SUCCESS; - - 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 FAILURE; - } - - /* 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) - gfc_convert_chartype (rvalue, &lvalue->ts); - - return SUCCESS; - } - - 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. */ - -gfc_try -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 FAILURE; - } - - if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc - && !lhs_attr.proc_pointer) - { - gfc_error ("'%s' in the pointer assignment at %L cannot be an " - "l-value since it is a procedure", - lvalue->symtree->n.sym->name, &lvalue->where); - return FAILURE; - } - - 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 '%s' at %L", - lvalue->symtree->n.sym->name, &lvalue->where); - return FAILURE; - } - - if (gfc_notify_std (GFC_STD_F2003,"Bounds " - "specification for '%s' in pointer assignment " - "at %L", lvalue->symtree->n.sym->name, - &lvalue->where) == FAILURE) - return FAILURE; - - /* 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 FAILURE; - } - if (ref->u.ar.stride[dim]) - { - gfc_error ("Stride must not be present at %L", - &lvalue->where); - return FAILURE; - } - - 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 FAILURE; - } - } - } - } - } - - 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 SUCCESS; - - /* 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 FAILURE; - } - } - - /* Checks on rvalue for procedure pointer assignments. */ - if (proc_pointer) - { - char err[200]; - gfc_symbol *s1,*s2; - gfc_component *comp; - 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 FAILURE; - } - 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 == gfc_current_ns->proc_name - && sym->attr.function && sym->result == sym) - { - gfc_error ("Function result '%s' is invalid as proc-target " - "in procedure pointer assignment at %L", - sym->name, &rvalue->where); - return FAILURE; - } - } - if (attr.abstract) - { - gfc_error ("Abstract interface '%s' is invalid " - "in procedure pointer assignment at %L", - rvalue->symtree->name, &rvalue->where); - return FAILURE; - } - /* Check for F08:C729. */ - if (attr.flavor == FL_PROCEDURE) - { - if (attr.proc == PROC_ST_FUNCTION) - { - gfc_error ("Statement function '%s' is invalid " - "in procedure pointer assignment at %L", - rvalue->symtree->name, &rvalue->where); - return FAILURE; - } - if (attr.proc == PROC_INTERNAL && - gfc_notify_std (GFC_STD_F2008, "Internal procedure " - "'%s' is invalid in procedure pointer assignment " - "at %L", rvalue->symtree->name, &rvalue->where) - == FAILURE) - return FAILURE; - if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name, - attr.subroutine) == 0) - { - gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer " - "assignment", rvalue->symtree->name, &rvalue->where); - return FAILURE; - } - } - /* Check for F08:C730. */ - if (attr.elemental && !attr.intrinsic) - { - gfc_error ("Nonintrinsic elemental procedure '%s' is invalid " - "in procedure pointer assignment at %L", - rvalue->symtree->name, &rvalue->where); - return FAILURE; - } - - /* 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 FAILURE; - } - } - - comp = gfc_get_proc_ptr_comp (lvalue); - if (comp) - s1 = comp->ts.interface; - else - { - s1 = lvalue->symtree->n.sym; - if (s1->ts.interface) - s1 = s1->ts.interface; - } - - comp = gfc_get_proc_ptr_comp (rvalue); - if (comp) - { - if (rvalue->expr_type == EXPR_FUNCTION) - { - s2 = comp->ts.interface->result; - name = s2->name; - } - else - { - s2 = comp->ts.interface; - name = comp->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; - - if (s1 == s2 || !s1 || !s2) - return SUCCESS; - - 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 FAILURE; - } - - if (!gfc_compare_interfaces (s2, s1, name, 0, 1, - err, sizeof(err), NULL, NULL)) - { - gfc_error ("Interface mismatch in procedure pointer assignment " - "at %L: %s", &rvalue->where, err); - return FAILURE; - } - - return SUCCESS; - } - - 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 &L must be unlimited " - "polymorphic, a sequence derived type or of a " - "type with the BIND attribute assignment at %L " - "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 FAILURE; - } - - 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 FAILURE; - } - - if (lvalue->rank != rvalue->rank && !rank_remap) - { - gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); - return FAILURE; - } - - /* Make sure the vtab is present. */ - if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED) - gfc_find_derived_vtab (rvalue->ts.u.derived); - else if (UNLIMITED_POLY (lvalue) && !UNLIMITED_POLY (rvalue)) - gfc_find_intrinsic_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) == SUCCESS - && gfc_array_size (rvalue, &rsize) == SUCCESS - && 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 FAILURE; - } - - /* 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)) - { - gfc_error ("Rank remapping target must be rank 1 or" - " simply contiguous at %L", &rvalue->where); - return FAILURE; - } - if (gfc_notify_std (GFC_STD_F2008, "Rank remapping" - " target is not rank 1 at %L", &rvalue->where) - == FAILURE) - return FAILURE; - } - } - - /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */ - if (rvalue->expr_type == EXPR_NULL) - return SUCCESS; - - if (lvalue->ts.type == BT_CHARACTER) - { - gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment"); - if (t == FAILURE) - return FAILURE; - } - - 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) - { - gfc_error ("Target expression in pointer assignment " - "at %L must deliver a pointer result", - &rvalue->where); - return FAILURE; - } - - if (!attr.target && !attr.pointer) - { - gfc_error ("Pointer assignment target is neither TARGET " - "nor POINTER at %L", &rvalue->where); - return FAILURE; - } - - 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_current_ns->proc_name->attr.implicit_pure = 0; - - - if (gfc_has_vector_index (rvalue)) - { - gfc_error ("Pointer assignment with vector subscript " - "on rhs at %L", &rvalue->where); - return FAILURE; - } - - 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 FAILURE; - } - - /* 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 FAILURE; - } - } - - /* Warn if it is the LHS pointer may lives longer than the RHS target. */ - if (gfc_option.warn_target_lifetime - && rvalue->expr_type == EXPR_VARIABLE - && !rvalue->symtree->n.sym->attr.save - && !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; - - if (warn) - gfc_warning ("Pointer at %L in pointer assignment might outlive the " - "pointer target", &lvalue->where); - } - - return SUCCESS; -} - - -/* Relative of gfc_check_assign() except that the lvalue is a single - symbol. Used for initialization assignments. */ - -gfc_try -gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) -{ - gfc_expr lvalue; - gfc_try 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 - r = gfc_check_assign (&lvalue, rvalue, 1); - - free (lvalue.symtree); - - if (r == FAILURE) - 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 FAILURE; - } - if (!attr.target || attr.pointer) - { - gfc_error ("Pointer initialization target at %L " - "must have the TARGET attribute", &rvalue->where); - return FAILURE; - } - - 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 FAILURE; - } - } - - 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 FAILURE; - } - } - - return SUCCESS; -} - - -/* 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 (der->attr.flavor == FL_DERIVED); - for (c = der->components; c; c = c->next) - if (c->ts.type == BT_DERIVED) - { - if (!c->attr.pointer - && 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; -} - - -/* Get an expression for a default initializer. */ - -gfc_expr * -gfc_default_initializer (gfc_typespec *ts) -{ - gfc_expr *init; - gfc_component *comp; - - /* See if we have a default initializer in this, but not in nested - types (otherwise we could use gfc_has_default_initializer()). */ - for (comp = ts->u.derived->components; 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(); - - if (comp->initializer) - { - ctor->expr = gfc_copy_expr (comp->initializer); - if ((comp->ts.type != comp->initializer->ts.type - || comp->ts.kind != comp->initializer->ts.kind) - && !comp->attr.pointer && !comp->attr.proc_pointer) - gfc_convert_type_warn (ctor->expr, &comp->ts, 2, false); - } - - 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->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->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; - 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. */ - lval->rank = sym->as ? sym->as->rank : 0; - if (lval->rank) - gfc_add_full_array_ref (lval, sym->ts.type == BT_CLASS ? - CLASS_DATA (sym)->as : sym->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) - { - as = expr->symtree->n.sym->as; - 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); -} - - -/* 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) -{ - gfc_try 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 == FAILURE); -} - -gfc_try -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) - { - gfc_try t = SUCCESS; - - gcc_assert (e->value.op.op1); - t = gfc_expr_check_typed (e->value.op.op1, ns, strict); - - if (t == SUCCESS && 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 ? FAILURE : SUCCESS; -} - - -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; -} - - -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 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 (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; - - 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 (SUCCESS / FAILURE) be requested. */ - -gfc_try -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; - bool unlimited; - symbol_attribute attr; - gfc_ref* ref; - - 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; - } - - unlimited = e->ts.type == BT_CLASS && UNLIMITED_POLY (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 FAILURE; - } - } - 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 FAILURE; - } - - if (!pointer && sym->attr.flavor == FL_PARAMETER) - { - if (context) - gfc_error ("Named constant '%s' in variable definition context (%s)" - " at %L", sym->name, context, &e->where); - return FAILURE; - } - 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 ("'%s' in variable definition context (%s) at %L is not" - " a variable", sym->name, context, &e->where); - return FAILURE; - } - - /* 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 && !unlimited) - { - if (context) - gfc_error ("Non-POINTER in pointer association context (%s)" - " at %L", context, &e->where); - return FAILURE; - } - - /* 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 FAILURE; - } - - /* 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 && 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 '%s' with INTENT(IN) in pointer" - " association context (%s) at %L", - sym->name, context, &e->where); - return FAILURE; - } - if (!pointer && !is_pointer && !sym->attr.pointer) - { - if (context) - gfc_error ("Dummy argument '%s' with INTENT(IN) in variable" - " definition context (%s) at %L", - sym->name, context, &e->where); - return FAILURE; - } - } - - /* PROTECTED and use-associated. */ - if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin) - { - if (pointer && is_pointer) - { - if (context) - gfc_error ("Variable '%s' is PROTECTED and can not appear in a" - " pointer association context (%s) at %L", - sym->name, context, &e->where); - return FAILURE; - } - if (!pointer && !is_pointer) - { - if (context) - gfc_error ("Variable '%s' is PROTECTED and can not appear in a" - " variable definition context (%s) at %L", - sym->name, context, &e->where); - return FAILURE; - } - } - - /* 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 '%s' can not appear in a variable definition" - " context (%s) at %L in PURE procedure", - sym->name, context, &e->where); - return FAILURE; - } - - 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 ("'%s' at %L associated to vector-indexed target can" - " not be used in a variable definition context (%s)", - name, &e->where, context); - else - gfc_error ("'%s' at %L associated to expression can" - " not be used in a variable definition context (%s)", - name, &e->where, context); - } - return FAILURE; - } - - /* Target must be allowed to appear in a variable definition context. */ - if (gfc_check_vardef_context (assoc->target, pointer, false, false, NULL) - == FAILURE) - { - if (context) - gfc_error ("Associate-name '%s' 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 FAILURE; - } - } - - return SUCCESS; -} |