/* Routines for manipulation of expression nodes.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+ 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "arith.h"
#include "match.h"
#include "target-memory.h" /* for gfc_convert_boz */
+#include "constructor.h"
-/* Get a new expr node. */
+
+/* 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)
e->shape = NULL;
e->ref = NULL;
e->symtree = NULL;
- e->con_by_offset = NULL;
return e;
}
-/* Free an argument list and everything below it. */
+/* Get a new expression node that is an array constructor
+ of given type and kind. */
-void
-gfc_free_actual_arglist (gfc_actual_arglist *a1)
+gfc_expr *
+gfc_get_array_expr (bt type, int kind, locus *where)
{
- gfc_actual_arglist *a2;
-
- while (a1)
- {
- a2 = a1->next;
- gfc_free_expr (a1->expr);
- gfc_free (a1);
- a1 = a2;
- }
-}
+ gfc_expr *e;
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_ARRAY;
+ e->value.constructor = NULL;
+ e->rank = 1;
+ e->shape = NULL;
-/* Copy an arglist structure and all of the arguments. */
+ e->ts.type = type;
+ e->ts.kind = kind;
+ if (where)
+ e->where = *where;
-gfc_actual_arglist *
-gfc_copy_actual_arglist (gfc_actual_arglist *p)
-{
- gfc_actual_arglist *head, *tail, *new_arg;
+ return e;
+}
- head = tail = NULL;
- for (; p; p = p->next)
- {
- new_arg = gfc_get_actual_arglist ();
- *new_arg = *p;
+/* Get a new expression node that is the NULL expression. */
- new_arg->expr = gfc_copy_expr (p->expr);
- new_arg->next = NULL;
+gfc_expr *
+gfc_get_null_expr (locus *where)
+{
+ gfc_expr *e;
- if (head == NULL)
- head = new_arg;
- else
- tail->next = new_arg;
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_NULL;
+ e->ts.type = BT_UNKNOWN;
- tail = new_arg;
- }
+ if (where)
+ e->where = *where;
- return head;
+ return e;
}
-/* Free a list of reference structures. */
+/* Get a new expression node that is an operator expression node. */
-void
-gfc_free_ref_list (gfc_ref *p)
+gfc_expr *
+gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
+ gfc_expr *op1, gfc_expr *op2)
{
- 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;
+ gfc_expr *e;
- case REF_SUBSTRING:
- gfc_free_expr (p->u.ss.start);
- gfc_free_expr (p->u.ss.end);
- break;
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_OP;
+ e->value.op.op = op;
+ e->value.op.op1 = op1;
+ e->value.op.op2 = op2;
- case REF_COMPONENT:
- break;
- }
+ if (where)
+ e->where = *where;
- gfc_free (p);
- }
+ return e;
}
-/* 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. */
+/* Get a new expression node that is an structure constructor
+ of given type and kind. */
-static void
-free_expr0 (gfc_expr *e)
+gfc_expr *
+gfc_get_structure_constructor_expr (bt type, int kind, locus *where)
{
- int n;
+ 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;
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_STRUCTURE;
+ e->value.constructor = NULL;
- case BT_REAL:
- mpfr_clear (e->value.real);
- break;
+ e->ts.type = type;
+ e->ts.kind = kind;
+ if (where)
+ e->where = *where;
- case BT_CHARACTER:
- gfc_free (e->value.character.string);
- break;
+ return e;
+}
- case BT_COMPLEX:
- mpfr_clear (e->value.complex.r);
- mpfr_clear (e->value.complex.i);
- break;
- default:
- break;
- }
+/* Get a new expression node that is an constant of given type and kind. */
- /* Free the representation. */
- if (e->representation.string)
- gfc_free (e->representation.string);
+gfc_expr *
+gfc_get_constant_expr (bt type, int kind, locus *where)
+{
+ gfc_expr *e;
- break;
+ if (!where)
+ gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL");
- 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;
+ e = gfc_get_expr ();
- case EXPR_FUNCTION:
- gfc_free_actual_arglist (e->value.function.actual);
- break;
+ e->expr_type = EXPR_CONSTANT;
+ e->ts.type = type;
+ e->ts.kind = kind;
+ e->where = *where;
- case EXPR_COMPCALL:
- gfc_free_actual_arglist (e->value.compcall.actual);
+ switch (type)
+ {
+ case BT_INTEGER:
+ mpz_init (e->value.integer);
break;
- case EXPR_VARIABLE:
+ case BT_REAL:
+ gfc_set_model_kind (kind);
+ mpfr_init (e->value.real);
break;
- case EXPR_ARRAY:
- case EXPR_STRUCTURE:
- gfc_free_constructor (e->value.constructor);
+ case BT_COMPLEX:
+ gfc_set_model_kind (kind);
+ mpc_init2 (e->value.complex, mpfr_get_default_prec());
break;
- case EXPR_SUBSTRING:
- gfc_free (e->value.character.string);
+ default:
break;
+ }
- case EXPR_NULL:
- break;
+ return e;
+}
- default:
- gfc_internal_error ("free_expr0(): Bad expr type");
- }
- /* Free a shape array. */
- if (e->shape != NULL)
- {
- for (n = 0; n < e->rank; n++)
- mpz_clear (e->shape[n]);
+/* 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;
- gfc_free (e->shape);
+ if (!src)
+ {
+ dest = gfc_get_wide_string (len + 1);
+ gfc_wide_memset (dest, ' ', len);
+ dest[len] = '\0';
}
+ else
+ dest = gfc_char_to_widechar (src);
- gfc_free_ref_list (e->ref);
+ e = gfc_get_constant_expr (BT_CHARACTER, kind,
+ where ? where : &gfc_current_locus);
+ e->value.character.string = dest;
+ e->value.character.length = len;
- memset (e, '\0', sizeof (gfc_expr));
+ return e;
}
-/* Free an expression node and everything beneath it. */
+/* Get a new expression node that is an integer constant. */
-void
-gfc_free_expr (gfc_expr *e)
+gfc_expr *
+gfc_get_int_expr (int kind, locus *where, int value)
{
- if (e == NULL)
- return;
- if (e->con_by_offset)
- splay_tree_delete (e->con_by_offset);
- free_expr0 (e);
- gfc_free (e);
+ 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;
}
-/* Graft the *src expression onto the *dest subexpression. */
+/* Get a new expression node that is a logical constant. */
-void
-gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
+gfc_expr *
+gfc_get_logical_expr (int kind, locus *where, bool value)
{
- free_expr0 (dest);
- *dest = *src;
- gfc_free (src);
-}
+ gfc_expr *p;
+ p = gfc_get_constant_expr (BT_LOGICAL, kind,
+ where ? where : &gfc_current_locus);
+ p->value.logical = value;
-/* 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. */
+ return p;
+}
-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");
+gfc_expr *
+gfc_get_iokind_expr (locus *where, io_kind k)
+{
+ gfc_expr *e;
- 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");
- }
+ /* 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. */
- *result = (int) mpz_get_si (expr->value.integer);
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_CONSTANT;
+ e->ts.type = BT_LOGICAL;
+ e->value.iokind = k;
+ e->where = *where;
- return NULL;
+ return e;
}
-/* Recursively copy a list of reference structures. */
+/* Given an expression pointer, return a copy of the expression. This
+ subroutine is recursive. */
-gfc_ref *
-gfc_copy_ref (gfc_ref *src)
+gfc_expr *
+gfc_copy_expr (gfc_expr *p)
{
- gfc_array_ref *ar;
- gfc_ref *dest;
+ gfc_expr *q;
+ gfc_char_t *s;
+ char *c;
- if (src == NULL)
+ if (p == NULL)
return NULL;
- dest = gfc_get_ref ();
- dest->type = src->type;
+ q = gfc_get_expr ();
+ *q = *p;
- switch (src->type)
+ switch (q->expr_type)
{
- case REF_ARRAY:
- ar = gfc_copy_array_ref (&src->u.ar);
- dest->u.ar = *ar;
- gfc_free (ar);
+ 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 REF_COMPONENT:
- dest->u.c = src->u.c;
- 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));
+ }
- 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;
- }
+ /* 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;
- 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;
-}
-
-
-/* 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_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);
- mpfr_init (q->value.complex.r);
- mpfr_init (q->value.complex.i);
- mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
- mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
+ 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:
case BT_HOLLERITH:
case BT_LOGICAL:
case BT_DERIVED:
+ case BT_CLASS:
break; /* Already done. */
case BT_PROCEDURE:
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;
case EXPR_STRUCTURE:
case EXPR_ARRAY:
- q->value.constructor = gfc_copy_constructor (p->value.constructor);
+ q->value.constructor = gfc_constructor_copy (p->value.constructor);
break;
case EXPR_VARIABLE:
}
-/* Return the maximum kind of two expressions. In general, higher
- kind numbers mean more precision for numeric types. */
+/* 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. */
-int
-gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
+static void
+free_expr0 (gfc_expr *e)
{
- return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
-}
-
+ int n;
-/* Returns nonzero if the type is numeric, zero otherwise. */
+ 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;
-static int
-numeric_type (bt type)
-{
- return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
-}
+ case BT_REAL:
+ mpfr_clear (e->value.real);
+ break;
+ case BT_CHARACTER:
+ free (e->value.character.string);
+ break;
-/* Returns nonzero if the typespec is a numeric type, zero otherwise. */
+ case BT_COMPLEX:
+ mpc_clear (e->value.complex);
+ break;
-int
-gfc_numeric_ts (gfc_typespec *ts)
-{
- return numeric_type (ts->type);
-}
+ default:
+ break;
+ }
+ /* Free the representation. */
+ free (e->representation.string);
-/* Returns an expression node that is an integer constant. */
+ break;
-gfc_expr *
-gfc_int_expr (int i)
-{
- gfc_expr *p;
+ 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;
- p = gfc_get_expr ();
+ case EXPR_FUNCTION:
+ gfc_free_actual_arglist (e->value.function.actual);
+ break;
- p->expr_type = EXPR_CONSTANT;
- p->ts.type = BT_INTEGER;
- p->ts.kind = gfc_default_integer_kind;
+ case EXPR_COMPCALL:
+ case EXPR_PPC:
+ gfc_free_actual_arglist (e->value.compcall.actual);
+ break;
- p->where = gfc_current_locus;
- mpz_init_set_si (p->value.integer, i);
+ case EXPR_VARIABLE:
+ break;
- return p;
-}
+ case EXPR_ARRAY:
+ case EXPR_STRUCTURE:
+ gfc_constructor_free (e->value.constructor);
+ break;
+ case EXPR_SUBSTRING:
+ free (e->value.character.string);
+ break;
-/* Returns an expression node that is a logical constant. */
+ case EXPR_NULL:
+ break;
-gfc_expr *
-gfc_logical_expr (int i, locus *where)
-{
- gfc_expr *p;
+ default:
+ gfc_internal_error ("free_expr0(): Bad expr type");
+ }
- p = gfc_get_expr ();
+ /* Free a shape array. */
+ if (e->shape != NULL)
+ {
+ for (n = 0; n < e->rank; n++)
+ mpz_clear (e->shape[n]);
- p->expr_type = EXPR_CONSTANT;
- p->ts.type = BT_LOGICAL;
- p->ts.kind = gfc_default_logical_kind;
+ free (e->shape);
+ }
- if (where == NULL)
- where = &gfc_current_locus;
- p->where = *where;
- p->value.logical = i;
+ gfc_free_ref_list (e->ref);
- return p;
+ memset (e, '\0', sizeof (gfc_expr));
}
-/* 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. */
+/* Free an expression node and everything beneath it. */
-gfc_expr *
-gfc_build_conversion (gfc_expr *e)
+void
+gfc_free_expr (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;
+ if (e == NULL)
+ return;
+ free_expr0 (e);
+ free (e);
}
-/* Given an expression node with some sort of numeric binary
- expression, insert type conversions required to make the operands
- have the same type.
-
- 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. */
+/* Free an argument list and everything below it. */
void
-gfc_type_convert_binary (gfc_expr *e)
+gfc_free_actual_arglist (gfc_actual_arglist *a1)
{
- gfc_expr *op1, *op2;
-
- op1 = e->value.op.op1;
- op2 = e->value.op.op2;
+ gfc_actual_arglist *a2;
- if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
+ while (a1)
{
- gfc_clear_ts (&e->ts);
- return;
+ a2 = a1->next;
+ gfc_free_expr (a1->expr);
+ free (a1);
+ a1 = a2;
}
+}
- /* 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 (op2, &op1->ts, 2);
- else
- gfc_convert_type (op1, &op2->ts, 2);
+/* Copy an arglist structure and all of the arguments. */
- e->ts = op1->ts;
- goto done;
- }
+gfc_actual_arglist *
+gfc_copy_actual_arglist (gfc_actual_arglist *p)
+{
+ gfc_actual_arglist *head, *tail, *new_arg;
- /* Integer combined with real or complex. */
- if (op2->ts.type == BT_INTEGER)
+ head = tail = NULL;
+
+ for (; p; p = p->next)
{
- e->ts = op1->ts;
+ new_arg = gfc_get_actual_arglist ();
+ *new_arg = *p;
- /* Special case for ** operator. */
- if (e->value.op.op == INTRINSIC_POWER)
- goto done;
+ new_arg->expr = gfc_copy_expr (p->expr);
+ new_arg->next = NULL;
- gfc_convert_type (e->value.op.op2, &e->ts, 2);
- goto done;
- }
+ if (head == NULL)
+ head = new_arg;
+ else
+ tail->next = new_arg;
- if (op1->ts.type == BT_INTEGER)
- {
- e->ts = op2->ts;
- gfc_convert_type (e->value.op.op1, &e->ts, 2);
- goto done;
+ tail = new_arg;
}
- /* 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 (e->value.op.op1, &e->ts, 2);
- if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
- gfc_convert_type (e->value.op.op2, &e->ts, 2);
-
-done:
- return;
+ return head;
}
-static match
-check_specification_function (gfc_expr *e)
-{
- gfc_symbol *sym;
-
- if (!e->symtree)
- return MATCH_NO;
-
- sym = e->symtree->n.sym;
-
- /* F95, 7.1.6.2; F2003, 7.1.7 */
- 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
- && sym->formal == NULL)
- return MATCH_YES;
-
- return MATCH_NO;
-}
-
-/* Function to determine if an expression is constant or not. This
- function expects that the expression has already been simplified. */
+/* Free a list of reference structures. */
-int
-gfc_is_constant_expr (gfc_expr *e)
+void
+gfc_free_ref_list (gfc_ref *p)
{
- gfc_constructor *c;
- gfc_actual_arglist *arg;
- int rv;
-
- if (e == NULL)
- return 1;
+ gfc_ref *q;
+ int i;
- switch (e->expr_type)
+ for (; p; p = q)
{
- case EXPR_OP:
- rv = (gfc_is_constant_expr (e->value.op.op1)
- && (e->value.op.op2 == NULL
- || gfc_is_constant_expr (e->value.op.op2)));
- break;
-
- case EXPR_VARIABLE:
- rv = 0;
- break;
-
- case EXPR_FUNCTION:
- /* Specification functions are constant. */
- if (check_specification_function (e) == MATCH_YES)
- {
- rv = 1;
- break;
- }
+ q = p->next;
- /* Call to intrinsic with at least one argument. */
- rv = 0;
- if (e->value.function.isym && e->value.function.actual)
+ switch (p->type)
{
- for (arg = e->value.function.actual; arg; arg = arg->next)
+ case REF_ARRAY:
+ for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
{
- if (!gfc_is_constant_expr (arg->expr))
- break;
+ gfc_free_expr (p->u.ar.start[i]);
+ gfc_free_expr (p->u.ar.end[i]);
+ gfc_free_expr (p->u.ar.stride[i]);
}
- if (arg == NULL)
- rv = 1;
- }
- break;
- case EXPR_CONSTANT:
- case EXPR_NULL:
- rv = 1;
- break;
+ break;
- case EXPR_SUBSTRING:
- rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
- && gfc_is_constant_expr (e->ref->u.ss.end));
- break;
+ case REF_SUBSTRING:
+ gfc_free_expr (p->u.ss.start);
+ gfc_free_expr (p->u.ss.end);
+ break;
- case EXPR_STRUCTURE:
- rv = 0;
- for (c = e->value.constructor; c; c = c->next)
- if (!gfc_is_constant_expr (c->expr))
+ case REF_COMPONENT:
break;
+ }
- if (c == NULL)
- rv = 1;
- break;
+ free (p);
+ }
+}
- case EXPR_ARRAY:
- rv = gfc_constant_ac (e);
- break;
- default:
- gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
- }
+/* Graft the *src expression onto the *dest subexpression. */
- return rv;
+void
+gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
+{
+ free_expr0 (dest);
+ *dest = *src;
+ free (src);
}
-/* 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;
+/* 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. */
- if (e->expr_type != EXPR_VARIABLE)
- return false;
+const char *
+gfc_extract_int (gfc_expr *expr, int *result)
+{
+ if (expr->expr_type != EXPR_CONSTANT)
+ return _("Constant expression required at %C");
- if (e->symtree->n.sym->attr.subref_array_pointer)
- return true;
+ if (expr->ts.type != BT_INTEGER)
+ return _("Integer expression required at %C");
- seen_array = false;
- for (ref = e->ref; ref; ref = ref->next)
+ if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
+ || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
{
- 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 _("Integer value too large in expression at %C");
}
- return false;
-}
+ *result = (int) mpz_get_si (expr->value.integer);
-/* 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;
+ return NULL;
+}
- if (p->value.op.op == INTRINSIC_USER)
- return SUCCESS;
- op1 = p->value.op.op1;
- op2 = p->value.op.op2;
- op = p->value.op.op;
+/* Recursively copy a list of reference structures. */
- if (gfc_simplify_expr (op1, type) == FAILURE)
- return FAILURE;
- if (gfc_simplify_expr (op2, type) == FAILURE)
- return FAILURE;
+gfc_ref *
+gfc_copy_ref (gfc_ref *src)
+{
+ gfc_array_ref *ar;
+ gfc_ref *dest;
- if (!gfc_is_constant_expr (op1)
- || (op2 != NULL && !gfc_is_constant_expr (op2)))
- return SUCCESS;
+ if (src == NULL)
+ return NULL;
- /* Rip p apart. */
- p->value.op.op1 = NULL;
- p->value.op.op2 = NULL;
+ dest = gfc_get_ref ();
+ dest->type = src->type;
- switch (op)
+ switch (src->type)
{
- case INTRINSIC_PARENTHESES:
- result = gfc_parentheses (op1);
- break;
-
- case INTRINSIC_UPLUS:
- result = gfc_uplus (op1);
- break;
-
- case INTRINSIC_UMINUS:
- result = gfc_uminus (op1);
+ case REF_ARRAY:
+ ar = gfc_copy_array_ref (&src->u.ar);
+ dest->u.ar = *ar;
+ free (ar);
break;
- case INTRINSIC_PLUS:
- result = gfc_add (op1, op2);
+ case REF_COMPONENT:
+ dest->u.c = src->u.c;
break;
- case INTRINSIC_MINUS:
- result = gfc_subtract (op1, op2);
+ 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;
+ }
- case INTRINSIC_TIMES:
- result = gfc_multiply (op1, op2);
- break;
+ dest->next = gfc_copy_ref (src->next);
- case INTRINSIC_DIVIDE:
- result = gfc_divide (op1, op2);
- break;
+ return dest;
+}
- case INTRINSIC_POWER:
- result = gfc_power (op1, op2);
- break;
- case INTRINSIC_CONCAT:
- result = gfc_concat (op1, op2);
- break;
+/* Detect whether an expression has any vector index array references. */
- case INTRINSIC_EQ:
- case INTRINSIC_EQ_OS:
- result = gfc_eq (op1, op2, op);
- break;
+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;
+}
- 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;
+/* Copy a shape array. */
- case INTRINSIC_GE:
- case INTRINSIC_GE_OS:
- result = gfc_ge (op1, op2, op);
- break;
+mpz_t *
+gfc_copy_shape (mpz_t *shape, int rank)
+{
+ mpz_t *new_shape;
+ int n;
- case INTRINSIC_LT:
- case INTRINSIC_LT_OS:
- result = gfc_lt (op1, op2, op);
- break;
+ if (shape == NULL)
+ return NULL;
- case INTRINSIC_LE:
- case INTRINSIC_LE_OS:
- result = gfc_le (op1, op2, op);
- break;
+ new_shape = gfc_get_shape (rank);
- case INTRINSIC_NOT:
- result = gfc_not (op1);
- break;
+ for (n = 0; n < rank; n++)
+ mpz_init_set (new_shape[n], shape[n]);
- case INTRINSIC_AND:
- result = gfc_and (op1, op2);
- break;
+ return new_shape;
+}
- case INTRINSIC_OR:
- result = gfc_or (op1, op2);
- break;
- case INTRINSIC_EQV:
- result = gfc_eqv (op1, op2);
- break;
+/* Copy a shape array excluding dimension N, where N is an integer
+ constant expression. Dimensions are numbered in fortran style --
+ starting with ONE.
- case INTRINSIC_NEQV:
- result = gfc_neqv (op1, op2);
- break;
+ 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}
- default:
- gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
- }
+ If anything goes wrong -- N is not a constant, its value is out
+ of range -- or anything else, just returns NULL. */
- if (result == 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++)
{
- gfc_free_expr (op1);
- gfc_free_expr (op2);
- return FAILURE;
+ if (i == n)
+ continue;
+ mpz_init_set (*s, shape[i]);
+ s++;
}
- result->rank = p->rank;
- result->where = p->where;
- gfc_replace_expr (p, result);
+ return new_shape;
+}
- return SUCCESS;
+
+/* 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;
}
-/* Subroutine to simplify constructor expressions. Mutually recursive
- with gfc_simplify_expr(). */
+/* Returns nonzero if the type is numeric, zero otherwise. */
-static gfc_try
-simplify_constructor (gfc_constructor *c, int type)
+static int
+numeric_type (bt type)
{
- gfc_expr *p;
+ return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
+}
- for (; c; c = c->next)
- {
- 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);
+/* Returns nonzero if the typespec is a numeric type, zero otherwise. */
- if (gfc_simplify_expr (p, type) == FAILURE)
- {
- gfc_free_expr (p);
- continue;
- }
+int
+gfc_numeric_ts (gfc_typespec *ts)
+{
+ return numeric_type (ts->type);
+}
- gfc_replace_expr (c->expr, p);
- }
- }
- return SUCCESS;
+/* 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;
}
-/* Pull a single array element out of an array constructor. */
+/* 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.
-static gfc_try
-find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
- gfc_constructor **rval)
+ 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)
{
- unsigned long nelemen;
- int i;
- mpz_t delta;
- mpz_t offset;
- mpz_t span;
- mpz_t tmp;
- gfc_expr *e;
- gfc_try t;
+ gfc_expr *op1, *op2;
- t = SUCCESS;
- e = NULL;
+ op1 = e->value.op.op1;
+ op2 = e->value.op.op2;
- 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 (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
{
- e = gfc_copy_expr (ar->start[i]);
- if (e->expr_type != EXPR_CONSTANT)
- {
- cons = NULL;
- goto depart;
- }
+ gfc_clear_ts (&e->ts);
+ return;
+ }
- /* Check the bounds. */
- if ((ar->as->upper[i]
- && ar->as->upper[i]->expr_type == EXPR_CONSTANT
- && mpz_cmp (e->value.integer,
- ar->as->upper[i]->value.integer) > 0)
- || (ar->as->lower[i]->expr_type == EXPR_CONSTANT
- && mpz_cmp (e->value.integer,
- ar->as->lower[i]->value.integer) < 0))
+ /* Kind conversions of same type. */
+ if (op1->ts.type == op2->ts.type)
+ {
+ if (op1->ts.kind == op2->ts.kind)
{
- gfc_error ("Index in dimension %d is out of bounds "
- "at %L", i + 1, &ar->c_where[i]);
- cons = NULL;
- t = FAILURE;
- goto depart;
+ /* No type conversions. */
+ e->ts = op1->ts;
+ goto done;
}
- mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
- mpz_mul (delta, delta, span);
- mpz_add (offset, offset, delta);
+ 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);
- 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);
+ e->ts = op1->ts;
+ goto done;
}
- for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
+ /* Integer combined with real or complex. */
+ if (op2->ts.type == BT_INTEGER)
{
- if (cons)
- {
- if (cons->iterator)
- {
- cons = NULL;
- goto depart;
- }
- cons = cons->next;
- }
+ 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;
}
-depart:
- mpz_clear (delta);
- mpz_clear (offset);
- mpz_clear (span);
- mpz_clear (tmp);
- if (e)
- gfc_free_expr (e);
- *rval = cons;
- return t;
+ 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;
}
-/* Find a component of a structure constructor. */
+/* Function to determine if an expression is constant or not. This
+ function expects that the expression has already been simplified. */
-static gfc_constructor *
-find_component_ref (gfc_constructor *cons, gfc_ref *ref)
+int
+gfc_is_constant_expr (gfc_expr *e)
{
- gfc_component *comp;
- gfc_component *pick;
+ gfc_constructor *c;
+ gfc_actual_arglist *arg;
+ gfc_symbol *sym;
- comp = ref->u.c.sym->components;
- pick = ref->u.c.component;
- while (comp != pick)
+ if (e == NULL)
+ return 1;
+
+ switch (e->expr_type)
{
- comp = comp->next;
- cons = cons->next;
- }
+ 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)));
- return cons;
-}
+ 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);
-/* Replace an expression with the contents of a constructor, removing
- the subobject reference in the process. */
+ /* 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;
+ }
-static void
-remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
-{
- gfc_expr *e;
+ /* 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
+ && sym->formal == 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;
- e = cons->expr;
- cons->expr = NULL;
- e->ref = p->ref->next;
- p->ref->next = NULL;
- gfc_replace_expr (p, e);
-}
+ 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));
-/* Pull an array section out of an array constructor. */
+ 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);
-static gfc_try
-find_array_section (gfc_expr *expr, gfc_ref *ref)
-{
- int idx;
- int rank;
- int d;
- int shape_i;
- 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;
- mpz_t index;
- gfc_constructor *cons;
- gfc_constructor *base;
- gfc_expr *begin;
- gfc_expr *finish;
- gfc_expr *step;
- gfc_expr *upper;
- gfc_expr *lower;
- gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
- gfc_try t;
+ for (; c; c = gfc_constructor_next (c))
+ if (!gfc_is_constant_expr (c->expr))
+ return 0;
- t = SUCCESS;
+ return 1;
- base = expr->value.constructor;
- expr->value.constructor = NULL;
- rank = ref->u.ar.as->rank;
+ default:
+ gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
+ return 0;
+ }
+}
- 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);
+/* 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;
- /* 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;
- }
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
- /* Build the counters to clock through the array reference. */
- shape_i = 0;
- for (d = 0; d < rank; d++)
+ if (e->symtree->n.sym->attr.subref_array_pointer)
+ return true;
+
+ seen_array = false;
+ for (ref = e->ref; ref; ref = ref->next)
{
- /* 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->type == REF_ARRAY
+ && ref->u.ar.type != AR_ELEMENT)
+ seen_array = true;
- if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
- {
- gcc_assert (begin);
+ if (seen_array
+ && ref->type != REF_ARRAY)
+ return seen_array;
+ }
+ return false;
+}
- if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
- {
- t = FAILURE;
- goto cleanup;
- }
- gcc_assert (begin->rank == 1);
- gcc_assert (begin->shape);
+/* Try to collapse intrinsic expressions. */
- vecsub[d] = 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]);
+static gfc_try
+simplify_intrinsic_op (gfc_expr *p, int type)
+{
+ gfc_intrinsic_op op;
+ gfc_expr *op1, *op2, *result;
- /* Check bounds. */
- for (c = vecsub[d]; c; c = c->next)
- {
- if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
- || mpz_cmp (c->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;
- }
+ if (p->value.op.op == INTRINSIC_USER)
+ return SUCCESS;
- /* Obtain the stride. */
- if (step)
- mpz_set (stride[d], step->value.integer);
- else
- mpz_set_ui (stride[d], one);
+ op1 = p->value.op.op1;
+ op2 = p->value.op.op2;
+ op = p->value.op.op;
- if (mpz_cmp_ui (stride[d], 0) == 0)
- mpz_set_ui (stride[d], one);
+ if (gfc_simplify_expr (op1, type) == FAILURE)
+ return FAILURE;
+ if (gfc_simplify_expr (op2, type) == FAILURE)
+ return FAILURE;
- /* Obtain the start value for the index. */
- if (begin)
- mpz_set (start[d], begin->value.integer);
- else
- mpz_set (start[d], lower->value.integer);
+ if (!gfc_is_constant_expr (op1)
+ || (op2 != NULL && !gfc_is_constant_expr (op2)))
+ return SUCCESS;
- mpz_set (ctr[d], start[d]);
+ /* Rip p apart. */
+ p->value.op.op1 = NULL;
+ p->value.op.op2 = NULL;
- /* Obtain the end value for the index. */
- if (finish)
- mpz_set (end[d], finish->value.integer);
- else
- mpz_set (end[d], upper->value.integer);
+ switch (op)
+ {
+ case INTRINSIC_PARENTHESES:
+ result = gfc_parentheses (op1);
+ break;
- /* 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);
+ case INTRINSIC_UPLUS:
+ result = gfc_uplus (op1);
+ break;
- /* 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;
- }
+ case INTRINSIC_UMINUS:
+ result = gfc_uminus (op1);
+ break;
- /* 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);
+ case INTRINSIC_PLUS:
+ result = gfc_add (op1, op2);
+ break;
- /* 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);
- }
+ case INTRINSIC_MINUS:
+ result = gfc_subtract (op1, op2);
+ break;
- mpz_init (index);
- mpz_init (ptr);
- cons = base;
+ case INTRINSIC_TIMES:
+ result = gfc_multiply (op1, op2);
+ break;
- /* 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++)
- {
- if (ref->u.ar.offset)
- mpz_set (ptr, ref->u.ar.offset->value.integer);
- else
- mpz_init_set_ui (ptr, 0);
+ case INTRINSIC_DIVIDE:
+ result = gfc_divide (op1, op2);
+ break;
- 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);
+ case INTRINSIC_POWER:
+ result = gfc_power (op1, op2);
+ break;
- if (!incr_ctr) continue;
+ case INTRINSIC_CONCAT:
+ result = gfc_concat (op1, op2);
+ break;
- if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
- {
- gcc_assert(vecsub[d]);
+ case INTRINSIC_EQ:
+ case INTRINSIC_EQ_OS:
+ result = gfc_eq (op1, op2, op);
+ break;
- if (!vecsub[d]->next)
- vecsub[d] = ref->u.ar.start[d]->value.constructor;
- else
- {
- vecsub[d] = vecsub[d]->next;
- incr_ctr = false;
- }
- mpz_set (ctr[d], vecsub[d]->expr->value.integer);
- }
- else
- {
- mpz_add (ctr[d], ctr[d], stride[d]);
+ case INTRINSIC_NE:
+ case INTRINSIC_NE_OS:
+ result = gfc_ne (op1, op2, op);
+ break;
- 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;
- }
- }
+ case INTRINSIC_GT:
+ case INTRINSIC_GT_OS:
+ result = gfc_gt (op1, op2, op);
+ break;
- /* There must be a better way of dealing with negative strides
- than resetting the index and the constructor pointer! */
- if (mpz_cmp (ptr, index) < 0)
- {
- mpz_set_ui (index, 0);
- cons = base;
- }
+ case INTRINSIC_GE:
+ case INTRINSIC_GE_OS:
+ result = gfc_ge (op1, op2, op);
+ break;
- while (cons && cons->next && mpz_cmp (ptr, index) > 0)
- {
- mpz_add_ui (index, index, one);
- cons = cons->next;
- }
+ case INTRINSIC_LT:
+ case INTRINSIC_LT_OS:
+ result = gfc_lt (op1, op2, op);
+ break;
- gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
- }
+ case INTRINSIC_LE:
+ case INTRINSIC_LE_OS:
+ result = gfc_le (op1, op2, op);
+ break;
- mpz_clear (ptr);
- mpz_clear (index);
+ case INTRINSIC_NOT:
+ result = gfc_not (op1);
+ break;
-cleanup:
+ case INTRINSIC_AND:
+ result = gfc_and (op1, op2);
+ break;
- 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_free_constructor (base);
- return t;
-}
+ case INTRINSIC_OR:
+ result = gfc_or (op1, op2);
+ break;
-/* Pull a substring out of an expression. */
+ case INTRINSIC_EQV:
+ result = gfc_eqv (op1, op2);
+ break;
-static gfc_try
-find_substring_ref (gfc_expr *p, gfc_expr **newp)
-{
- int end;
- int start;
- int length;
- gfc_char_t *chr;
+ case INTRINSIC_NEQV:
+ result = gfc_neqv (op1, op2);
+ break;
- if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
- || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
- return FAILURE;
+ default:
+ gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
+ }
- *newp = gfc_copy_expr (p);
- gfc_free ((*newp)->value.character.string);
+ if (result == NULL)
+ {
+ gfc_free_expr (op1);
+ gfc_free_expr (op2);
+ return FAILURE;
+ }
- 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;
+ result->rank = p->rank;
+ result->where = p->where;
+ gfc_replace_expr (p, result);
- 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. */
+/* Subroutine to simplify constructor expressions. Mutually recursive
+ with gfc_simplify_expr(). */
static gfc_try
-simplify_const_ref (gfc_expr *p)
+simplify_constructor (gfc_constructor_base base, int type)
{
- gfc_constructor *cons;
- gfc_expr *newp;
+ gfc_constructor *c;
+ gfc_expr *p;
- while (p->ref)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
- switch (p->ref->type)
- {
- case REF_ARRAY:
- switch (p->ref->u.ar.type)
- {
- case AR_ELEMENT:
- 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))
- {
- cons = p->value.constructor;
- for (; cons; cons = cons->next)
- {
- cons->expr->ref = gfc_copy_ref (p->ref->next);
- if (simplify_const_ref (cons->expr) == FAILURE)
- return FAILURE;
- }
-
- /* 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). */
- if (p->ts.type == BT_CHARACTER)
- {
- int string_len;
-
- gcc_assert (p->ref->next);
- gcc_assert (!p->ref->next->next);
- gcc_assert (p->ref->next->type == REF_SUBSTRING);
-
- if (p->value.constructor)
- {
- const gfc_expr* first = p->value.constructor->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 (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 (!p->ts.cl)
- {
- p->ts.cl = gfc_get_charlen ();
- p->ts.cl->next = NULL;
- p->ts.cl->length = NULL;
- }
- gfc_free_expr (p->ts.cl->length);
- p->ts.cl->length = gfc_int_expr (string_len);
- }
- }
- gfc_free_ref_list (p->ref);
- p->ref = NULL;
- break;
+ 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);
- default:
- return SUCCESS;
+ if (gfc_simplify_expr (p, type) == FAILURE)
+ {
+ gfc_free_expr (p);
+ continue;
}
- 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;
+ gfc_replace_expr (c->expr, p);
}
}
}
-/* Simplify a chain of references. */
+/* Pull a single array element out of an array constructor. */
static gfc_try
-simplify_ref_chain (gfc_ref *ref, int type)
+find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
+ gfc_constructor **rval)
{
- int n;
-
+ 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++)
+ {
+ if (ref->u.ar.offset)
+ mpz_set (ptr, ref->u.ar.offset->value.integer);
+ else
+ 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)
+ 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 < 0)
+ end = 0;
+
+ 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;
+}
+
+
+/* Check an intrinsic arithmetic operation to see if it is consistent
+ with some type of expression. */
+
+static gfc_try check_init_expr (gfc_expr *);
+
+
+/* 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 && 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++)
{
- case REF_ARRAY:
- for (n = 0; n < ref->u.ar.dimen; n++)
+ if (a == NULL)
+ new_ctor->expr->value.function.actual
+ = a = gfc_get_actual_arglist ();
+ else
{
- 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;
+ a->next = gfc_get_actual_arglist ();
+ a = a->next;
}
- 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;
+ 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;
+ 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 (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;
- default:
- break;
+ 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 && 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 SUCCESS;
+
+ return MATCH_YES;
}
-/* Try to substitute the value of a parameter variable. */
+/* F95, 7.1.6.1, Initialization expressions, (5)
+ F2003, 7.1.7 Initialization expression, (5) */
-static gfc_try
-simplify_parameter_variable (gfc_expr *p, int type)
+static match
+check_transformational (gfc_expr *e)
{
- gfc_expr *e;
- gfc_try t;
+ static const char * const trans_func_f95[] = {
+ "repeat", "reshape", "selected_int_kind",
+ "selected_real_kind", "transfer", "trim", NULL
+ };
- e = gfc_copy_expr (p->symtree->n.sym->value);
- if (e == NULL)
- return FAILURE;
+ 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
+ };
- e->rank = p->rank;
+ int i;
+ const char *name;
+ const char *const *functions;
- /* 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);
+ if (!e->value.function.isym
+ || !e->value.function.isym->transformational)
+ return MATCH_NO;
- /* 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);
+ name = e->symtree->n.sym->name;
- return t;
+ 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);
}
-/* 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.
+/* F95, 7.1.6.1, Initialization expressions, (6)
+ F2003, 7.1.7 Initialization expression, (6) */
- 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. */
+static match
+check_null (gfc_expr *e)
+{
+ if (strcmp ("null", e->symtree->n.sym->name) != 0)
+ return MATCH_NO;
-gfc_try
-gfc_simplify_expr (gfc_expr *p, int type)
+ return check_init_expr_arguments (e);
+}
+
+
+static match
+check_elemental (gfc_expr *e)
{
- gfc_actual_arglist *ap;
+ if (!e->value.function.isym
+ || !e->value.function.isym->elemental)
+ return MATCH_NO;
- if (p == NULL)
+ if (e->ts.type != BT_INTEGER
+ && e->ts.type != BT_CHARACTER
+ && gfc_notify_std (GFC_STD_F2003, "Extension: 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. */
+
+static gfc_try
+check_init_expr (gfc_expr *e)
+{
+ match m;
+ gfc_try t;
+
+ if (e == NULL)
return SUCCESS;
- switch (p->expr_type)
+ switch (e->expr_type)
{
- case EXPR_CONSTANT:
- case EXPR_NULL:
+ case EXPR_OP:
+ t = check_intrinsic_op (e, check_init_expr);
+ if (t == SUCCESS)
+ t = gfc_simplify_expr (e, 0);
+
break;
case EXPR_FUNCTION:
- for (ap = p->value.function.actual; ap; ap = ap->next)
- if (gfc_simplify_expr (ap->expr, type) == FAILURE)
- return FAILURE;
+ t = FAILURE;
- if (p->value.function.isym != NULL
- && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
- return 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;
+ }
+
+ /* 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_SUBSTRING:
- if (simplify_ref_chain (p->ref, type) == FAILURE)
- return FAILURE;
+ case EXPR_VARIABLE:
+ t = SUCCESS;
- if (gfc_is_constant_expr (p))
- {
- gfc_char_t *s;
- int start, end;
+ if (gfc_check_iter_variable (e) == SUCCESS)
+ break;
- if (p->ref && p->ref->u.ss.start)
+ 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_extract_int (p->ref->u.ss.start, &start);
- start--; /* Convert from one-based to zero-based. */
+ gfc_error("PARAMETER '%s' is used at %L before its definition "
+ "is complete", e->symtree->n.sym->name, &e->where);
+ t = FAILURE;
}
else
- start = 0;
+ t = simplify_parameter_variable (e, 0);
- if (p->ref && p->ref->u.ss.end)
- gfc_extract_int (p->ref->u.ss.end, &end);
- else
- end = p->value.character.length;
+ break;
+ }
- 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. */
- gfc_free (p->value.character.string);
- p->value.character.string = s;
- p->value.character.length = end - start;
- p->ts.cl = gfc_get_charlen ();
- p->ts.cl->next = gfc_current_ns->cl_list;
- gfc_current_ns->cl_list = p->ts.cl;
- p->ts.cl->length = gfc_int_expr (p->value.character.length);
- gfc_free_ref_list (p->ref);
- p->ref = NULL;
- p->expr_type = EXPR_CONSTANT;
+ 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();
+ }
}
- break;
+ 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);
- 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 || p->ref
- || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
- {
- if (simplify_parameter_variable (p, type) == FAILURE)
- return FAILURE;
- break;
- }
+ case EXPR_CONSTANT:
+ case EXPR_NULL:
+ t = SUCCESS;
+ break;
- if (type == 1)
- {
- gfc_simplify_iterator_var (p);
- }
+ case EXPR_SUBSTRING:
+ t = check_init_expr (e->ref->u.ss.start);
+ if (t == FAILURE)
+ break;
- /* Simplify subcomponent references. */
- if (simplify_ref_chain (p->ref, type) == FAILURE)
- return FAILURE;
+ t = check_init_expr (e->ref->u.ss.end);
+ if (t == SUCCESS)
+ t = gfc_simplify_expr (e, 0);
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;
+ t = e->ts.is_iso_c ? SUCCESS : FAILURE;
+ if (t == SUCCESS)
+ break;
- if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
- && p->ref->u.ar.type == AR_FULL)
- gfc_expand_constructor (p);
+ t = check_alloc_comp_init (e);
+ if (t == FAILURE)
+ break;
- if (simplify_const_ref (p) == FAILURE)
- return FAILURE;
+ t = gfc_check_constructor (e, check_init_expr);
+ if (t == FAILURE)
+ break;
break;
- case EXPR_COMPCALL:
- gcc_unreachable ();
+ case EXPR_ARRAY:
+ t = gfc_check_constructor (e, 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 = 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;
}
-/* Returns the type of an expression with the exception that iterator
- variables are automatically integers no matter what else they may
- be declared as. */
+/* Match an initialization expression. We work by first matching an
+ expression, then reducing it to a constant. */
-static bt
-et0 (gfc_expr *e)
+match
+gfc_match_init_expr (gfc_expr **result)
{
- if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
- return BT_INTEGER;
+ gfc_expr *expr;
+ match m;
+ gfc_try t;
- return e->ts.type;
-}
+ expr = NULL;
+ gfc_init_expr_flag = true;
-/* Check an intrinsic arithmetic operation to see if it is consistent
- with some type of expression. */
+ m = gfc_match_expr (&expr);
+ if (m != MATCH_YES)
+ {
+ gfc_init_expr_flag = false;
+ return m;
+ }
-static gfc_try check_init_expr (gfc_expr *);
+ 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;
+}
-/* Scalarize an expression for an elemental intrinsic call. */
+
+/* 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
-scalarize_intrinsic_call (gfc_expr *e)
+restricted_args (gfc_actual_arglist *a)
{
- gfc_actual_arglist *a, *b;
- gfc_constructor *args[5], *ctor, *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 (check_restricted (a->expr) == FAILURE)
+ return FAILURE;
}
- if (!array_arg)
- return FAILURE;
+ return SUCCESS;
+}
- old = gfc_copy_expr (e);
- gfc_free_constructor (expr->value.constructor);
- expr->value.constructor = NULL;
+/************* Restricted/specification expressions *************/
- 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)
+/* 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)
{
- /* Check that this is OK for an initialization expression. */
- if (a->expr && check_init_expr (a->expr) == FAILURE)
- goto cleanup;
+ gfc_error ("Specification function '%s' at %L cannot be a statement "
+ "function", f->name, &e->where);
+ return FAILURE;
+ }
- 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_copy_constructor (ctor);
- }
- else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
- {
- if (a->expr->rank)
- rank[n] = a->expr->rank;
- else
- rank[n] = 1;
- args[n] = gfc_copy_constructor (a->expr->value.constructor);
- }
- else
- args[n] = NULL;
- n++;
+ 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;
+ }
- /* Using the array argument as the master, step through the array
- calling the function for each element and advancing the array
- constructors together. */
- ctor = args[array_arg - 1];
- new_ctor = NULL;
- for (; ctor; ctor = ctor->next)
+ if (f->attr.recursive)
{
- if (expr->value.constructor == NULL)
- expr->value.constructor
- = new_ctor = gfc_get_constructor ();
- else
- {
- new_ctor->next = gfc_get_constructor ();
- new_ctor = new_ctor->next;
- }
- new_ctor->expr = gfc_copy_expr (old);
- 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);
+ gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
+ f->name, &e->where);
+ return FAILURE;
+ }
- b = b->next;
- }
+ 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;
- /* 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);
+ case REF_COMPONENT:
+ /* Nothing needed, just proceed to next reference. */
+ break;
- for (i = 0; i < n; i++)
- if (args[i])
- args[i] = args[i]->next;
+ case REF_SUBSTRING:
+ if (checker (ref->u.ss.start) == FAILURE)
+ return FAILURE;
+ if (checker (ref->u.ss.end) == FAILURE)
+ return FAILURE;
+ break;
- 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;
+ default:
+ gcc_unreachable ();
+ break;
}
- free_expr0 (e);
- *e = *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;
+ 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_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
+check_restricted (gfc_expr *e)
{
- gfc_expr *op1 = e->value.op.op1;
- gfc_expr *op2 = e->value.op.op2;
+ gfc_symbol* sym;
+ gfc_try t;
- if ((*check_function) (op1) == FAILURE)
- return FAILURE;
+ if (e == NULL)
+ return SUCCESS;
- switch (e->value.op.op)
+ switch (e->expr_type)
{
- case INTRINSIC_UPLUS:
- case INTRINSIC_UMINUS:
- if (!numeric_type (et0 (op1)))
- goto not_numeric;
+ case EXPR_OP:
+ t = check_intrinsic_op (e, check_restricted);
+ if (t == SUCCESS)
+ t = gfc_simplify_expr (e, 0);
+
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))))
+ case EXPR_FUNCTION:
+ if (e->value.function.esym)
{
- gfc_error ("Numeric or CHARACTER operands are required in "
- "expression at %L", &e->where);
- return FAILURE;
+ t = check_arglist (e->value.function.actual, &check_restricted);
+ if (t == SUCCESS)
+ t = external_spec_function (e);
}
- break;
+ else
+ {
+ if (e->value.function.isym && e->value.function.isym->inquiry)
+ t = SUCCESS;
+ else
+ t = check_arglist (e->value.function.actual, &check_restricted);
- case INTRINSIC_PLUS:
- case INTRINSIC_MINUS:
- case INTRINSIC_TIMES:
- case INTRINSIC_DIVIDE:
- case INTRINSIC_POWER:
- if ((*check_function) (op2) == FAILURE)
- return FAILURE;
+ if (t == SUCCESS)
+ t = restricted_intrinsic (e);
+ }
+ break;
- if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
- goto not_numeric;
+ case EXPR_VARIABLE:
+ sym = e->symtree->n.sym;
+ t = FAILURE;
- if (e->value.op.op == INTRINSIC_POWER
- && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
+ /* 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)
{
- if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
- "exponent in an initialization "
- "expression at %L", &op2->where)
- == FAILURE)
- return FAILURE;
+ gfc_error ("Dummy argument '%s' not allowed in expression at %L",
+ sym->name, &e->where);
+ break;
}
- break;
-
- case INTRINSIC_CONCAT:
- if ((*check_function) (op2) == FAILURE)
- return FAILURE;
-
- if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
+ if (sym->attr.optional)
{
- gfc_error ("Concatenation operator in expression at %L "
- "must have two CHARACTER operands", &op1->where);
- return FAILURE;
+ gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
+ sym->name, &e->where);
+ break;
}
- if (op1->ts.kind != op2->ts.kind)
+ if (sym->attr.intent == INTENT_OUT)
{
- gfc_error ("Concat operator at %L must concatenate strings of the "
- "same kind", &e->where);
- return FAILURE;
+ gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
+ sym->name, &e->where);
+ break;
}
- break;
+ /* Check reference chain if any. */
+ if (check_references (e->ref, &check_restricted) == FAILURE)
+ break;
- case INTRINSIC_NOT:
- if (et0 (op1) != BT_LOGICAL)
+ /* 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)))
{
- gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
- "operand", &op1->where);
- return FAILURE;
+ 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 INTRINSIC_AND:
- case INTRINSIC_OR:
- case INTRINSIC_EQV:
- case INTRINSIC_NEQV:
- if ((*check_function) (op2) == FAILURE)
- return FAILURE;
+ case EXPR_NULL:
+ case EXPR_CONSTANT:
+ t = SUCCESS;
+ break;
- if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
- {
- gfc_error ("LOGICAL operands are required in expression at %L",
- &e->where);
- return FAILURE;
- }
+ 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 INTRINSIC_PARENTHESES:
+ case EXPR_STRUCTURE:
+ t = gfc_check_constructor (e, check_restricted);
+ break;
+
+ case EXPR_ARRAY:
+ t = gfc_check_constructor (e, check_restricted);
break;
default:
- gfc_error ("Only intrinsic operators can be used in expression at %L",
- &e->where);
- return FAILURE;
+ gfc_internal_error ("check_restricted(): Unknown expression type");
}
- return SUCCESS;
-
-not_numeric:
- gfc_error ("Numeric operands are required in expression at %L", &e->where);
-
- return FAILURE;
+ return t;
}
-static match
-check_init_expr_arguments (gfc_expr *e)
+/* 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_actual_arglist *ap;
+ gfc_component *comp;
- for (ap = e->value.function.actual; ap; ap = ap->next)
- if (check_init_expr (ap->expr) == FAILURE)
- return MATCH_ERROR;
+ if (e == NULL)
+ return SUCCESS;
- return MATCH_YES;
-}
+ 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;
+ }
-/* F95, 7.1.6.1, Initialization expressions, (7)
- F2003, 7.1.7 Initialization expression, (8) */
+ if (e->expr_type == EXPR_FUNCTION
+ && !e->value.function.isym
+ && !e->value.function.esym
+ && !gfc_pure (e->symtree->n.sym)
+ && (!gfc_is_proc_ptr_comp (e, &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;
+ }
-static match
-check_inquiry (gfc_expr *e, int not_restricted)
-{
- const char *name;
- const char *const *functions;
+ if (e->rank != 0)
+ {
+ gfc_error ("Expression at %L must be scalar", &e->where);
+ return FAILURE;
+ }
- 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
- };
+ if (gfc_simplify_expr (e, 0) == FAILURE)
+ return FAILURE;
- 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
- };
+ return check_restricted (e);
+}
- int i;
- gfc_actual_arglist *ap;
- if (!e->value.function.isym
- || !e->value.function.isym->inquiry)
- return MATCH_NO;
+/************** Expression conformance checks. *************/
- /* An undeclared parameter will get us here (PR25018). */
- if (e->symtree == NULL)
- return MATCH_NO;
+/* Given two expressions, make sure that the arrays are conformable. */
- name = e->symtree->n.sym->name;
+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];
- functions = (gfc_option.warn_std & GFC_STD_F2003)
- ? inquiry_func_f2003 : inquiry_func_f95;
+ if (op1->rank == 0 || op2->rank == 0)
+ return SUCCESS;
- for (i = 0; functions[i]; i++)
- if (strcmp (functions[i], name) == 0)
- break;
+ va_start (argp, optype_msgid);
+ vsnprintf (buffer, 240, optype_msgid, argp);
+ va_end (argp);
- if (functions[i] == NULL)
- return MATCH_ERROR;
+ 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;
+ }
- /* 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. */
+ t = SUCCESS;
- for (ap = e->value.function.actual; ap; ap = ap->next)
+ for (d = 0; d < op1->rank; d++)
{
- if (!ap->expr)
- continue;
+ op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
+ op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
- if (ap->expr->ts.type == BT_UNKNOWN)
+ if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
{
- 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;
+ 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));
- ap->expr->ts = ap->expr->symtree->n.sym->ts;
+ t = FAILURE;
}
- /* 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.cl->length == NULL)
- {
- gfc_error ("Assumed character length variable '%s' in constant "
- "expression at %L", e->symtree->n.sym->name, &e->where);
- return MATCH_ERROR;
- }
- else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
- return MATCH_ERROR;
+ if (op1_flag)
+ mpz_clear (op1_size);
+ if (op2_flag)
+ mpz_clear (op2_size);
+
+ if (t == FAILURE)
+ return FAILURE;
}
- return MATCH_YES;
+ return SUCCESS;
}
-/* F95, 7.1.6.1, Initialization expressions, (5)
- F2003, 7.1.7 Initialization expression, (5) */
+/* Given an assignable expression and an arbitrary expression, make
+ sure that the assignment can take place. */
-static match
-check_transformational (gfc_expr *e)
+gfc_try
+gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
{
- static const char * const trans_func_f95[] = {
- "repeat", "reshape", "selected_int_kind",
- "selected_real_kind", "transfer", "trim", NULL
- };
+ gfc_symbol *sym;
+ gfc_ref *ref;
+ int has_pointer;
- int i;
- const char *name;
+ sym = lvalue->symtree->n.sym;
- if (!e->value.function.isym
- || !e->value.function.isym->transformational)
- return MATCH_NO;
+ /* 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;
+ }
- name = e->symtree->n.sym->name;
+ /* 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;
- /* NULL() is dealt with below. */
- if (strcmp ("null", name) == 0)
- return MATCH_NO;
+ /* (i) Use associated; */
+ if (sym->attr.use_assoc)
+ bad_proc = true;
- for (i = 0; trans_func_f95[i]; i++)
- if (strcmp (trans_func_f95[i], name) == 0)
- break;
+ /* (ii) The assignment is in the main program; or */
+ if (gfc_current_ns->proc_name->attr.is_main_program)
+ bad_proc = true;
- /* FIXME, F2003: implement translation of initialization
- expressions before enabling this check. For F95, error
- out if the transformational function is not in the list. */
-#if 0
- if (trans_func_f95[i] == NULL
- && gfc_notify_std (GFC_STD_F2003,
- "transformational intrinsic '%s' at %L is not permitted "
- "in an initialization expression", name, &e->where) == FAILURE)
- return MATCH_ERROR;
-#else
- if (trans_func_f95[i] == NULL)
+ /* (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("transformational intrinsic '%s' at %L is not permitted "
- "in an initialization expression", name, &e->where);
- return MATCH_ERROR;
+ gfc_error ("Incompatible ranks %d and %d in assignment at %L",
+ lvalue->rank, rvalue->rank, &lvalue->where);
+ return FAILURE;
}
-#endif
- return check_init_expr_arguments (e);
-}
+ 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;
+ }
+ }
-/* F95, 7.1.6.1, Initialization expressions, (6)
- F2003, 7.1.7 Initialization expression, (6) */
+ /* This is possibly a typo: x = f() instead of x => f(). */
+ if (gfc_option.warn_surprising
+ && rvalue->expr_type == EXPR_FUNCTION
+ && rvalue->symtree->n.sym->attr.pointer)
+ gfc_warning ("POINTER valued function appears on right-hand side of "
+ "assignment at %L", &rvalue->where);
-static match
-check_null (gfc_expr *e)
-{
- if (strcmp ("null", e->symtree->n.sym->name) != 0)
- return MATCH_NO;
+ /* Check size of array assignments. */
+ if (lvalue->rank != 0 && rvalue->rank != 0
+ && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
+ return FAILURE;
- return check_init_expr_arguments (e);
-}
+ if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
+ && lvalue->symtree->n.sym->attr.data
+ && gfc_notify_std (GFC_STD_GNU, "Extension: 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, "Extension: 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;
+ }
+ }
-static match
-check_elemental (gfc_expr *e)
-{
- if (!e->value.function.isym
- || !e->value.function.isym->elemental)
- return MATCH_NO;
+ if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
+ return SUCCESS;
- if (e->ts.type != BT_INTEGER
- && e->ts.type != BT_CHARACTER
- && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
- "nonstandard initialization expression at %L",
- &e->where) == FAILURE)
- return MATCH_ERROR;
+ /* 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;
- return check_init_expr_arguments (e);
-}
+ 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);
-static match
-check_conversion (gfc_expr *e)
-{
- if (!e->value.function.isym
- || !e->value.function.isym->conversion)
- return MATCH_NO;
+ return SUCCESS;
+ }
- return check_init_expr_arguments (e);
+ return gfc_convert_type (rvalue, &lvalue->ts, 1);
}
-/* 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. */
+/* 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. */
-static gfc_try
-check_init_expr (gfc_expr *e)
+gfc_try
+gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
{
- match m;
- gfc_try t;
+ symbol_attribute attr;
+ gfc_ref *ref;
+ bool is_pure, is_implicit_pure, rank_remap;
+ int proc_pointer;
- if (e == NULL)
- return SUCCESS;
+ if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
+ && !lvalue->symtree->n.sym->attr.proc_pointer)
+ {
+ gfc_error ("Pointer assignment target is not a POINTER at %L",
+ &lvalue->where);
+ return FAILURE;
+ }
- switch (e->expr_type)
+ if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
+ && lvalue->symtree->n.sym->attr.use_assoc
+ && !lvalue->symtree->n.sym->attr.proc_pointer)
{
- case EXPR_OP:
- t = check_intrinsic_op (e, check_init_expr);
- if (t == SUCCESS)
- t = gfc_simplify_expr (e, 0);
+ 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;
+ }
- break;
+ proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
- case EXPR_FUNCTION:
- t = FAILURE;
+ 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 ((m = check_specification_function (e)) != MATCH_YES)
+ if (ref->type == REF_ARRAY && ref->next == NULL)
{
- gfc_intrinsic_sym* isym;
- gfc_symbol* sym;
+ int dim;
+
+ if (ref->u.ar.type == AR_FULL)
+ break;
- sym = e->symtree->n.sym;
- if (!gfc_is_intrinsic (sym, 0, e->where)
- || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
+ if (ref->u.ar.type != AR_SECTION)
{
- gfc_error ("Function '%s' in initialization expression at %L "
- "must be an intrinsic or a specification function",
- e->symtree->n.sym->name, &e->where);
- break;
+ gfc_error ("Expected bounds specification for '%s' at %L",
+ lvalue->symtree->n.sym->name, &lvalue->where);
+ return FAILURE;
}
- 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)
+ if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: 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)
{
- 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 (!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;
+ }
- /* 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 (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;
+ }
+ }
+ }
}
+ }
- if (m == MATCH_YES)
- t = gfc_simplify_expr (e, 0);
-
- break;
+ is_pure = gfc_pure (NULL);
+ is_implicit_pure = gfc_implicit_pure (NULL);
- case EXPR_VARIABLE:
- t = SUCCESS;
+ /* 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;
- if (gfc_check_iter_variable (e) == SUCCESS)
- break;
+ /* 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;
+ }
+ }
- if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
+ /* 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)))
{
- /* 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 ("Invalid procedure pointer assignment at %L",
+ &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 C727. */
+ if (attr.flavor == FL_PROCEDURE)
+ {
+ if (attr.proc == PROC_ST_FUNCTION)
{
- gfc_error("PARAMETER '%s' is used at %L before its definition "
- "is complete", e->symtree->n.sym->name, &e->where);
- t = FAILURE;
+ gfc_error ("Statement function '%s' is invalid "
+ "in procedure pointer assignment at %L",
+ rvalue->symtree->name, &rvalue->where);
+ return FAILURE;
}
- else
- t = simplify_parameter_variable (e, 0);
-
- break;
+ 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 (gfc_in_match_data ())
- break;
-
- t = FAILURE;
-
- if (e->symtree->n.sym->as)
+ /* 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)
{
- 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;
+ symbol_attribute calls;
- 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;
+ 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);
- default:
- gcc_unreachable();
- }
+ 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;
+ }
}
- 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 = check_init_expr (e->ref->u.ss.start);
- if (t == FAILURE)
- break;
-
- t = check_init_expr (e->ref->u.ss.end);
- if (t == SUCCESS)
- t = gfc_simplify_expr (e, 0);
-
- break;
-
- case EXPR_STRUCTURE:
- if (e->ts.is_iso_c)
- t = SUCCESS;
+ if (gfc_is_proc_ptr_comp (lvalue, &comp))
+ s1 = comp->ts.interface;
else
- t = gfc_check_constructor (e, check_init_expr);
- break;
-
- case EXPR_ARRAY:
- t = gfc_check_constructor (e, check_init_expr);
- if (t == FAILURE)
- break;
+ s1 = lvalue->symtree->n.sym;
- t = gfc_expand_constructor (e);
- if (t == FAILURE)
- break;
+ if (gfc_is_proc_ptr_comp (rvalue, &comp))
+ {
+ s2 = comp->ts.interface;
+ name = comp->name;
+ }
+ else if (rvalue->expr_type == EXPR_FUNCTION)
+ {
+ s2 = rvalue->symtree->n.sym->result;
+ name = rvalue->symtree->n.sym->result->name;
+ }
+ else
+ {
+ s2 = rvalue->symtree->n.sym;
+ name = rvalue->symtree->n.sym->name;
+ }
- t = gfc_check_constructor_type (e);
- break;
+ if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
+ err, sizeof(err)))
+ {
+ gfc_error ("Interface mismatch in procedure pointer assignment "
+ "at %L: %s", &rvalue->where, err);
+ return FAILURE;
+ }
- default:
- gfc_internal_error ("check_init_expr(): Unknown expression type");
+ return SUCCESS;
}
- return t;
-}
-
-
-/* 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;
-
- m = gfc_match_expr (&expr);
- if (m != MATCH_YES)
- return m;
-
- gfc_init_expr = 1;
- t = gfc_resolve_expr (expr);
- if (t == SUCCESS)
- t = check_init_expr (expr);
- gfc_init_expr = 0;
-
- if (t == FAILURE)
+ if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
{
- gfc_free_expr (expr);
- return MATCH_ERROR;
+ 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 (expr->expr_type == EXPR_ARRAY
- && (gfc_check_constructor_type (expr) == FAILURE
- || gfc_expand_constructor (expr) == FAILURE))
+ if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
{
- gfc_free_expr (expr);
- return MATCH_ERROR;
+ gfc_error ("Different kind type parameters in pointer "
+ "assignment at %L", &lvalue->where);
+ return FAILURE;
}
- /* Not all inquiry functions are simplified to constant expressions
- so it is necessary to call check_inquiry again. */
- if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) != MATCH_YES
- && !gfc_in_match_data ())
+ if (lvalue->rank != rvalue->rank && !rank_remap)
{
- gfc_error ("Initialization expression didn't reduce %C");
- return MATCH_ERROR;
+ gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
+ return FAILURE;
}
- *result = expr;
-
- return MATCH_YES;
-}
+ if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
+ /* Make sure the vtab is present. */
+ gfc_find_derived_vtab (rvalue->ts.u.derived);
+ /* Check rank remapping. */
+ if (rank_remap)
+ {
+ mpz_t lsize, rsize;
-static gfc_try check_restricted (gfc_expr *);
+ /* 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;
+ }
-/* 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. */
+ /* 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, "Fortran 2008: Rank remapping"
+ " target is not rank 1 at %L", &rvalue->where)
+ == FAILURE)
+ return FAILURE;
+ }
+ }
-static gfc_try
-restricted_args (gfc_actual_arglist *a)
-{
- for (; a; a = a->next)
+ /* 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)
{
- if (check_restricted (a->expr) == FAILURE)
+ gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
+ if (t == 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;
+ if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
+ lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
- f = e->value.function.esym;
+ attr = gfc_expr_attr (rvalue);
- if (f->attr.proc == PROC_ST_FUNCTION)
+ if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer)
{
- gfc_error ("Specification function '%s' at %L cannot be a statement "
- "function", f->name, &e->where);
+ gfc_error ("Target expression in pointer assignment "
+ "at %L must deliver a pointer result",
+ &rvalue->where);
return FAILURE;
}
- if (f->attr.proc == PROC_INTERNAL)
+ if (!attr.target && !attr.pointer)
{
- gfc_error ("Specification function '%s' at %L cannot be an internal "
- "function", f->name, &e->where);
+ gfc_error ("Pointer assignment target is neither TARGET "
+ "nor POINTER at %L", &rvalue->where);
return FAILURE;
}
- if (!f->attr.pure && !f->attr.elemental)
+ if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
{
- gfc_error ("Specification function '%s' at %L must be PURE", f->name,
- &e->where);
- return FAILURE;
+ gfc_error ("Bad target in pointer assignment in PURE "
+ "procedure at %L", &rvalue->where);
}
- if (f->attr.recursive)
+ 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 ("Specification function '%s' at %L cannot be RECURSIVE",
- f->name, &e->where);
+ gfc_error ("Pointer assignment with vector subscript "
+ "on rhs at %L", &rvalue->where);
return FAILURE;
}
- return restricted_args (e->value.function.actual);
-}
-
-
-/* Check to see that a function reference to an intrinsic is a
- restricted expression. */
+ 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;
+ }
-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;
+ /* 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;
+ }
+ }
- return restricted_args (e->value.function.actual);
+ return SUCCESS;
}
-/* Verify that an expression is a restricted expression. Like its
- cousin check_init_expr(), an error message is generated if we
- return FAILURE. */
+/* Relative of gfc_check_assign() except that the lvalue is a single
+ symbol. Used for initialization assignments. */
-static gfc_try
-check_restricted (gfc_expr *e)
+gfc_try
+gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
{
- gfc_symbol *sym;
- gfc_try t;
-
- if (e == NULL)
- return SUCCESS;
+ gfc_expr lvalue;
+ gfc_try r;
- switch (e->expr_type)
- {
- case EXPR_OP:
- t = check_intrinsic_op (e, check_restricted);
- if (t == SUCCESS)
- t = gfc_simplify_expr (e, 0);
+ memset (&lvalue, '\0', sizeof (gfc_expr));
- break;
+ 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;
- case EXPR_FUNCTION:
- t = e->value.function.esym ? external_spec_function (e)
- : restricted_intrinsic (e);
- break;
+ if (sym->attr.pointer || sym->attr.proc_pointer
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer
+ && rvalue->expr_type == EXPR_NULL))
+ r = gfc_check_pointer_assign (&lvalue, rvalue);
+ else
+ r = gfc_check_assign (&lvalue, rvalue, 1);
- case EXPR_VARIABLE:
- sym = e->symtree->n.sym;
- t = FAILURE;
+ free (lvalue.symtree);
- /* 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)
+ if (r == FAILURE)
+ return r;
+
+ if (sym->attr.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 ("Dummy argument '%s' not allowed in expression at %L",
- sym->name, &e->where);
- break;
+ gfc_error ("Pointer initialization target at %C "
+ "must not be ALLOCATABLE ");
+ return FAILURE;
}
-
- if (sym->attr.optional)
+ if (!attr.target || attr.pointer)
{
- gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
- sym->name, &e->where);
- break;
+ gfc_error ("Pointer initialization target at %C "
+ "must have the TARGET attribute");
+ return FAILURE;
}
-
- if (sym->attr.intent == INTENT_OUT)
+ if (!attr.save)
{
- gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
- sym->name, &e->where);
- break;
+ gfc_error ("Pointer initialization target at %C "
+ "must have the SAVE attribute");
+ return FAILURE;
}
-
- /* 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 (sym->attr.in_common
- || sym->attr.use_assoc
- || sym->attr.dummy
- || sym->attr.implied_index
- || sym->ns != gfc_current_ns
- || (sym->ns->proc_name != NULL
- && sym->ns->proc_name->attr.flavor == FL_MODULE)
- || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
+ }
+
+ if (sym->attr.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)
{
- t = SUCCESS;
- break;
+ gfc_error ("Procedure pointer initialization target at %L "
+ "may not be a procedure pointer", &rvalue->where);
+ return FAILURE;
}
+ }
- gfc_error ("Variable '%s' cannot appear in the expression at %L",
- sym->name, &e->where);
+ return SUCCESS;
+}
- break;
- case EXPR_NULL:
- case EXPR_CONSTANT:
- t = SUCCESS;
- break;
+/* Check for default initializer; sym->value is not enough
+ as it is also set for EXPR_NULL of allocatables. */
- case EXPR_SUBSTRING:
- t = gfc_specification_expr (e->ref->u.ss.start);
- if (t == FAILURE)
- break;
+bool
+gfc_has_default_initializer (gfc_symbol *der)
+{
+ gfc_component *c;
- t = gfc_specification_expr (e->ref->u.ss.end);
- if (t == SUCCESS)
- t = gfc_simplify_expr (e, 0);
+ 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;
+ }
+ else
+ {
+ if (c->initializer)
+ return true;
+ }
- break;
+ return false;
+}
- case EXPR_STRUCTURE:
- t = gfc_check_constructor (e, check_restricted);
- break;
+/* Get an expression for a default initializer. */
- case EXPR_ARRAY:
- t = gfc_check_constructor (e, check_restricted);
+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)->attr.allocatable))
break;
- default:
- gfc_internal_error ("check_restricted(): Unknown expression type");
+ 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->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 t;
+ return init;
}
-/* Check to see that an expression is a specification expression. If
- we return FAILURE, an error has been generated. */
+/* 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_try
-gfc_specification_expr (gfc_expr *e)
+gfc_expr *
+gfc_get_variable_expr (gfc_symtree *var)
{
+ gfc_expr *e;
- 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;
- }
-
- if (e->expr_type == EXPR_FUNCTION
- && !e->value.function.isym
- && !e->value.function.esym
- && !gfc_pure (e->symtree->n.sym))
- {
- 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;
- }
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_VARIABLE;
+ e->symtree = var;
+ e->ts = var->n.sym->ts;
- if (e->rank != 0)
+ if (var->n.sym->as != NULL)
{
- gfc_error ("Expression at %L must be scalar", &e->where);
- return FAILURE;
+ e->rank = var->n.sym->as->rank;
+ e->ref = gfc_get_ref ();
+ e->ref->type = REF_ARRAY;
+ e->ref->u.ar.type = AR_FULL;
}
- if (gfc_simplify_expr (e, 0) == FAILURE)
- return FAILURE;
-
- return check_restricted (e);
+ return e;
}
-/************** Expression conformance checks. *************/
-
-/* Given two expressions, make sure that the arrays are conformable. */
-
-gfc_try
-gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
+gfc_expr *
+gfc_lval_expr_from_sym (gfc_symbol *sym)
{
- int op1_flag, op2_flag, d;
- mpz_t op1_size, op2_size;
- gfc_try t;
-
- if (op1->rank == 0 || op2->rank == 0)
- return SUCCESS;
-
- if (op1->rank != op2->rank)
+ 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_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid),
- op1->rank, op2->rank, &op1->where);
- return FAILURE;
+ lval->ref = gfc_get_ref ();
+ lval->ref->type = REF_ARRAY;
+ lval->ref->u.ar.type = AR_FULL;
+ lval->ref->u.ar.dimen = lval->rank;
+ lval->ref->u.ar.where = sym->declared_at;
+ lval->ref->u.ar.as = sym->as;
}
- t = SUCCESS;
+ return lval;
+}
- 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)", _(optype_msgid), &op1->where, d + 1,
- (int) mpz_get_si (op1_size),
- (int) mpz_get_si (op2_size));
+/* 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;
- t = FAILURE;
- }
+ if (expr->rank == 0)
+ return NULL;
- if (op1_flag)
- mpz_clear (op1_size);
- if (op2_flag)
- mpz_clear (op2_size);
+ /* 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;
- if (t == FAILURE)
- return FAILURE;
+ 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 SUCCESS;
+ return as;
}
-/* Given an assignable expression and an arbitrary expression, make
- sure that the assignment can take place. */
+/* General expression traversal function. */
-gfc_try
-gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
+bool
+gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
+ bool (*func)(gfc_expr *, gfc_symbol *, int*),
+ int f)
{
- gfc_symbol *sym;
+ gfc_array_ref ar;
gfc_ref *ref;
- int has_pointer;
-
- sym = lvalue->symtree->n.sym;
+ gfc_actual_arglist *args;
+ gfc_constructor *c;
+ int i;
- /* Check INTENT(IN), unless the object itself is the component or
- sub-component of a pointer. */
- has_pointer = sym->attr.pointer;
+ if (!expr)
+ return false;
- for (ref = lvalue->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
- {
- has_pointer = 1;
- break;
- }
+ if ((*func) (expr, sym, &f))
+ return true;
- if (!has_pointer && sym->attr.intent == INTENT_IN)
- {
- gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
- sym->name, &lvalue->where);
- return FAILURE;
- }
+ 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;
- /* 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)
+ switch (expr->expr_type)
{
- 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))
+ case EXPR_PPC:
+ case EXPR_COMPCALL:
+ case EXPR_FUNCTION:
+ for (args = expr->value.function.actual; args; args = args->next)
{
- /* ... 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;
+ if (gfc_traverse_expr (args->expr, sym, func, f))
+ return true;
}
+ break;
- /* (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;
+ case EXPR_VARIABLE:
+ case EXPR_CONSTANT:
+ case EXPR_NULL:
+ case EXPR_SUBSTRING:
+ break;
- if (bad_proc)
+ case EXPR_STRUCTURE:
+ case EXPR_ARRAY:
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c))
{
- gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
- return FAILURE;
+ 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;
- 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;
- }
+ 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;
- if (lvalue->ts.type == BT_UNKNOWN)
- {
- gfc_error ("Variable type is UNKNOWN in assignment at %L",
- &lvalue->where);
- return FAILURE;
+ default:
+ gcc_unreachable ();
+ break;
}
- if (rvalue->expr_type == EXPR_NULL)
- {
- if (lvalue->symtree->n.sym->attr.pointer
- && lvalue->symtree->n.sym->attr.data)
- return SUCCESS;
- else
+ ref = expr->ref;
+ while (ref != NULL)
+ {
+ switch (ref->type)
{
- gfc_error ("NULL appears on right-hand side in assignment at %L",
- &rvalue->where);
- return FAILURE;
- }
- }
-
- if (sym->attr.cray_pointee
- && lvalue->ref != NULL
- && lvalue->ref->u.ar.type == AR_FULL
- && lvalue->ref->u.ar.as->cp_was_assumed)
- {
- gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
- "is illegal", &lvalue->where);
- return FAILURE;
- }
+ 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;
- /* This is possibly a typo: x = f() instead of x => f(). */
- if (gfc_option.warn_surprising
- && rvalue->expr_type == EXPR_FUNCTION
- && rvalue->symtree->n.sym->attr.pointer)
- gfc_warning ("POINTER valued function appears on right-hand side of "
- "assignment at %L", &rvalue->where);
+ 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;
- /* Check size of array assignments. */
- if (lvalue->rank != 0 && rvalue->rank != 0
- && gfc_check_conformance ("array assignment", lvalue, rvalue) != SUCCESS)
- return FAILURE;
+ 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 (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
- && lvalue->symtree->n.sym->attr.data
- && gfc_notify_std (GFC_STD_GNU, "Extension: 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, "Extension: BOZ literal at %L outside "
- "a DATA statement and outside INT/REAL/DBLE/CMPLX",
- &rvalue->where) == FAILURE)
- return FAILURE;
+ 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;
- /* 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;
+ default:
+ gcc_unreachable ();
}
+ ref = ref->next;
}
+ return false;
+}
- if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
- return SUCCESS;
+/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
- /* 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;
+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;
+}
- if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
- return SUCCESS;
+void
+gfc_expr_set_symbols_referenced (gfc_expr *expr)
+{
+ gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
+}
- 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;
- }
+/* Determine if an expression is a procedure pointer component. If yes, the
+ argument 'comp' will point to the component (provided that 'comp' was
+ provided). */
- /* 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);
+bool
+gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
+{
+ gfc_ref *ref;
+ bool ppc = false;
- return SUCCESS;
+ if (!expr || !expr->ref)
+ return false;
+
+ ref = expr->ref;
+ while (ref->next)
+ ref = ref->next;
+
+ if (ref->type == REF_COMPONENT)
+ {
+ ppc = ref->u.c.component->attr.proc_pointer;
+ if (ppc && comp)
+ *comp = ref->u.c.component;
}
- return gfc_convert_type (rvalue, &lvalue->ts, 1);
+ return ppc;
}
-/* 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. */
+/* 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:
-gfc_try
-gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
+ 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)
{
- symbol_attribute attr;
- gfc_ref *ref;
- int is_pure;
- int pointer, check_intent_in;
+ gfc_try t;
- if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
- && !lvalue->symtree->n.sym->attr.proc_pointer)
- {
- gfc_error ("Pointer assignment target is not a POINTER at %L",
- &lvalue->where);
- return FAILURE;
- }
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
- if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
- && lvalue->symtree->n.sym->attr.use_assoc)
- {
- 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;
- }
+ gcc_assert (e->symtree);
+ t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
+ true, e->where);
+ return (t == FAILURE);
+}
- /* Check INTENT(IN), unless the object itself is the component or
- sub-component of a pointer. */
- check_intent_in = 1;
- pointer = lvalue->symtree->n.sym->attr.pointer
- | lvalue->symtree->n.sym->attr.proc_pointer;
+gfc_try
+gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
+{
+ bool error_found;
- for (ref = lvalue->ref; ref; ref = ref->next)
+ /* If this is a top-level variable or EXPR_OP, do the check with strict given
+ to us. */
+ if (!strict)
{
- if (pointer)
- check_intent_in = 0;
+ if (e->expr_type == EXPR_VARIABLE && !e->ref)
+ return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
- if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
- pointer = 1;
- }
+ if (e->expr_type == EXPR_OP)
+ {
+ gfc_try t = SUCCESS;
- if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
- {
- gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
- lvalue->symtree->n.sym->name, &lvalue->where);
- return FAILURE;
- }
+ gcc_assert (e->value.op.op1);
+ t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
- if (!pointer)
- {
- gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
- return FAILURE;
+ if (t == SUCCESS && e->value.op.op2)
+ t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
+
+ return t;
+ }
}
- is_pure = gfc_pure (NULL);
+ /* Otherwise, walk the expression and do it strictly. */
+ check_typed_ns = ns;
+ error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
- if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
- && lvalue->symtree->n.sym->value != rvalue)
+ return error_found ? FAILURE : SUCCESS;
+}
+
+/* Walk an expression tree and replace all symbols with a corresponding symbol
+ in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
+ statements. The boolean return value is required by gfc_traverse_expr. */
+
+static bool
+replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
+{
+ if ((expr->expr_type == EXPR_VARIABLE
+ || (expr->expr_type == EXPR_FUNCTION
+ && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
+ && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
{
- gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
- return FAILURE;
+ gfc_symtree *stree;
+ gfc_namespace *ns = sym->formal_ns;
+ /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
+ the symtree rather than create a new one (and probably fail later). */
+ stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
+ expr->symtree->n.sym->name);
+ gcc_assert (stree);
+ stree->n.sym->attr = expr->symtree->n.sym->attr;
+ expr->symtree = stree;
}
+ return false;
+}
- /* 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;
+void
+gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
+{
+ gfc_traverse_expr (expr, dest, &replace_symbol, 0);
+}
- /* TODO checks on rvalue for a procedure pointer assignment. */
- if (lvalue->symtree->n.sym->attr.proc_pointer)
- return SUCCESS;
+/* The following is analogous to 'replace_symbol', and needed for copying
+ interfaces for procedure pointer components. The argument 'sym' must formally
+ be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
+ However, it gets actually passed a gfc_component (i.e. the procedure pointer
+ component in whose formal_ns the arguments have to be). */
- if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
+static bool
+replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
+{
+ gfc_component *comp;
+ comp = (gfc_component *)sym;
+ if ((expr->expr_type == EXPR_VARIABLE
+ || (expr->expr_type == EXPR_FUNCTION
+ && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
+ && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
{
- 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;
+ gfc_symtree *stree;
+ gfc_namespace *ns = comp->formal_ns;
+ /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
+ the symtree rather than create a new one (and probably fail later). */
+ stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
+ expr->symtree->n.sym->name);
+ gcc_assert (stree);
+ stree->n.sym->attr = expr->symtree->n.sym->attr;
+ expr->symtree = stree;
}
+ return false;
+}
- if (lvalue->ts.kind != rvalue->ts.kind)
- {
- gfc_error ("Different kind type parameters in pointer "
- "assignment at %L", &lvalue->where);
- return FAILURE;
- }
+void
+gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
+{
+ gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
+}
- if (lvalue->rank != rvalue->rank)
- {
- gfc_error ("Different ranks in pointer assignment at %L",
- &lvalue->where);
- return FAILURE;
- }
- /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
- if (rvalue->expr_type == EXPR_NULL)
- return SUCCESS;
+bool
+gfc_ref_this_image (gfc_ref *ref)
+{
+ int n;
- if (lvalue->ts.type == BT_CHARACTER
- && lvalue->ts.cl && rvalue->ts.cl
- && lvalue->ts.cl->length && rvalue->ts.cl->length
- && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
- rvalue->ts.cl->length)) == 1)
- {
- gfc_error ("Different character lengths in pointer "
- "assignment at %L", &lvalue->where);
- return FAILURE;
- }
+ gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0);
- if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
- lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
+ 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;
- attr = gfc_expr_attr (rvalue);
- if (!attr.target && !attr.pointer)
- {
- gfc_error ("Pointer assignment target is neither TARGET "
- "nor POINTER at %L", &rvalue->where);
- return FAILURE;
- }
+ return true;
+}
- 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 (gfc_has_vector_index (rvalue))
- {
- gfc_error ("Pointer assignment with vector subscript "
- "on rhs at %L", &rvalue->where);
- return FAILURE;
- }
+bool
+gfc_is_coindexed (gfc_expr *e)
+{
+ gfc_ref *ref;
- if (attr.is_protected && attr.use_assoc)
- {
- gfc_error ("Pointer assignment target has PROTECTED "
- "attribute at %L", &rvalue->where);
- return FAILURE;
- }
+ 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 SUCCESS;
+ return false;
}
-/* Relative of gfc_check_assign() except that the lvalue is a single
- symbol. Used for initialization assignments. */
+/* 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) */
-gfc_try
-gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
+bool
+gfc_is_coarray (gfc_expr *e)
{
- gfc_expr lvalue;
- gfc_try r;
+ gfc_ref *ref;
+ gfc_symbol *sym;
+ gfc_component *comp;
+ bool coindexed;
+ bool coarray;
+ int i;
- memset (&lvalue, '\0', sizeof (gfc_expr));
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
- lvalue.expr_type = EXPR_VARIABLE;
- lvalue.ts = sym->ts;
- if (sym->as)
- lvalue.rank = sym->as->rank;
- lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
- lvalue.symtree->n.sym = sym;
- lvalue.where = sym->declared_at;
+ coindexed = false;
+ sym = e->symtree->n.sym;
- if (sym->attr.pointer || sym->attr.proc_pointer)
- r = gfc_check_pointer_assign (&lvalue, rvalue);
+ if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+ coarray = CLASS_DATA (sym)->attr.codimension;
else
- r = gfc_check_assign (&lvalue, rvalue, 1);
-
- gfc_free (lvalue.symtree);
+ coarray = sym->attr.codimension;
- return r;
-}
+ for (ref = e->ref; ref; ref = ref->next)
+ switch (ref->type)
+ {
+ case REF_COMPONENT:
+ comp = ref->u.c.component;
+ if (comp->attr.pointer || comp->attr.allocatable)
+ {
+ coindexed = false;
+ if (comp->ts.type == BT_CLASS && comp->attr.class_ok)
+ coarray = CLASS_DATA (comp)->attr.codimension;
+ else
+ coarray = comp->attr.codimension;
+ }
+ break;
+ case REF_ARRAY:
+ if (!coarray)
+ break;
-/* Get an expression for a default initializer. */
+ if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref))
+ {
+ coindexed = true;
+ break;
+ }
-gfc_expr *
-gfc_default_initializer (gfc_typespec *ts)
-{
- gfc_constructor *tail;
- gfc_expr *init;
- gfc_component *c;
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+ {
+ coarray = false;
+ break;
+ }
+ break;
- /* See if we have a default initializer. */
- for (c = ts->derived->components; c; c = c->next)
- if (c->initializer || c->attr.allocatable)
- break;
+ case REF_SUBSTRING:
+ break;
+ }
- if (!c)
- return NULL;
+ return coarray && !coindexed;
+}
- /* Build the constructor. */
- init = gfc_get_expr ();
- init->expr_type = EXPR_STRUCTURE;
- init->ts = *ts;
- init->where = ts->derived->declared_at;
- tail = NULL;
- for (c = ts->derived->components; c; c = c->next)
+int
+gfc_get_corank (gfc_expr *e)
+{
+ int corank;
+ gfc_ref *ref;
+ corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
+ for (ref = e->ref; ref; ref = ref->next)
{
- if (tail == NULL)
- init->value.constructor = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->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 (c->initializer)
- tail->expr = gfc_copy_expr (c->initializer);
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
- if (c->attr.allocatable)
- {
- tail->expr = gfc_get_expr ();
- tail->expr->expr_type = EXPR_NULL;
- tail->expr->ts = c->ts;
- }
- }
- return init;
-}
+ 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;
+}
-/* 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)
+/* Check whether the expression has an pointer component.
+ Being itself a pointer does not count. */
+bool
+gfc_has_ultimate_pointer (gfc_expr *e)
{
- gfc_expr *e;
+ gfc_ref *ref, *last = NULL;
- e = gfc_get_expr ();
- e->expr_type = EXPR_VARIABLE;
- e->symtree = var;
- e->ts = var->n.sym->ts;
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
- if (var->n.sym->as != NULL)
- {
- e->rank = var->n.sym->as->rank;
- e->ref = gfc_get_ref ();
- e->ref->type = REF_ARRAY;
- e->ref->u.ar.type = AR_FULL;
- }
+ 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;
- return e;
+ 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;
}
-/* General expression traversal function. */
+/* 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 futher checks are done - for instance,
+ a "(::1)" is accepted. */
bool
-gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
- bool (*func)(gfc_expr *, gfc_symbol *, int*),
- int f)
+gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
{
- gfc_array_ref ar;
- gfc_ref *ref;
- gfc_actual_arglist *args;
- gfc_constructor *c;
+ bool colon;
int i;
+ gfc_array_ref *ar = NULL;
+ gfc_ref *ref, *part_ref = NULL;
- if (!expr)
+ 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 ((*func) (expr, sym, &f))
- return true;
+ if (expr->rank == 0)
+ return false;
- if (expr->ts.type == BT_CHARACTER
- && expr->ts.cl
- && expr->ts.cl->length
- && expr->ts.cl->length->expr_type != EXPR_CONSTANT
- && gfc_traverse_expr (expr->ts.cl->length, sym, func, f))
+ 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;
+ }
+
+ if ((part_ref && !part_ref->u.c.component->attr.contiguous
+ && part_ref->u.c.component->attr.pointer)
+ || (!part_ref && !expr->symtree->n.sym->attr.contiguous
+ && (expr->symtree->n.sym->attr.pointer
+ || expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)))
+ return false;
+
+ if (!ar || ar->type == AR_FULL)
return true;
- switch (expr->expr_type)
+ gcc_assert (ar->type == AR_SECTION);
+
+ /* Check for simply contiguous array */
+ colon = true;
+ for (i = 0; i < ar->dimen; i++)
{
- case EXPR_FUNCTION:
- for (args = expr->value.function.actual; args; args = args->next)
+ if (ar->dimen_type[i] == DIMEN_VECTOR)
+ return false;
+
+ if (ar->dimen_type[i] == DIMEN_ELEMENT)
{
- if (gfc_traverse_expr (args->expr, sym, func, f))
- return true;
+ colon = false;
+ continue;
}
- break;
- case EXPR_VARIABLE:
- case EXPR_CONSTANT:
- case EXPR_NULL:
- case EXPR_SUBSTRING:
- break;
+ 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 contigous; 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;
+}
- case EXPR_STRUCTURE:
- case EXPR_ARRAY:
- for (c = expr->value.constructor; c; c = c->next)
+
+/* 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 (const char* name, locus where, unsigned numarg, ...)
+{
+ gfc_expr* result;
+ gfc_actual_arglist* atail;
+ gfc_intrinsic_sym* isym;
+ va_list ap;
+ unsigned i;
+
+ isym = gfc_find_function (name);
+ gcc_assert (isym);
+
+ result = gfc_get_expr ();
+ result->expr_type = EXPR_FUNCTION;
+ result->ts = isym->ts;
+ result->where = where;
+ result->value.function.name = name;
+ result->value.function.isym = isym;
+
+ va_start (ap, numarg);
+ atail = NULL;
+ for (i = 0; i < numarg; ++i)
+ {
+ if (atail)
{
- 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;
- }
+ atail->next = gfc_get_actual_arglist ();
+ atail = atail->next;
}
- 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;
+ else
+ atail = result->value.function.actual = gfc_get_actual_arglist ();
- default:
- gcc_unreachable ();
- break;
+ atail->expr = va_arg (ap, gfc_expr*);
}
+ va_end (ap);
- 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;
+ return result;
+}
- 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.cl
- && ref->u.c.component->ts.cl->length
- && ref->u.c.component->ts.cl->length->expr_type
- != EXPR_CONSTANT
- && gfc_traverse_expr (ref->u.c.component->ts.cl->length,
- sym, func, f))
- return true;
+/* 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 (ref->u.c.component->as)
- for (i = 0; i < ref->u.c.component->as->rank; 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;
+ Optionally, a possible error message can be suppressed if context is NULL
+ and just the return status (SUCCESS / FAILURE) be requested. */
- default:
- gcc_unreachable ();
- }
- ref = ref->next;
+gfc_try
+gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
+ const char* context)
+{
+ gfc_symbol* sym = NULL;
+ bool is_pointer;
+ bool check_intentin;
+ bool ptr_component;
+ 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;
}
- return false;
-}
-/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
+ 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;
+ }
-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;
-}
+ 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;
+ }
-void
-gfc_expr_set_symbols_referenced (gfc_expr *expr)
-{
- gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
-}
+ /* Find out whether the expr is a pointer; this also means following
+ component references to the last one. */
+ is_pointer = (attr.pointer || attr.proc_pointer);
+ if (pointer && !is_pointer)
+ {
+ if (context)
+ gfc_error ("Non-POINTER in pointer association context (%s)"
+ " at %L", context, &e->where);
+ return 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;
+ }
-/* 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; this is for things in legacy-code like:
+ /* INTENT(IN) dummy argument. Check this, unless the object itself is
+ the component of sub-component of a pointer. Obviously,
+ procedure pointers are of no interest here. */
+ check_intentin = true;
+ ptr_component = 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 (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)
+ {
+ if (context)
+ gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
+ " definition context (%s) at %L",
+ sym->name, context, &e->where);
+ return FAILURE;
+ }
+ }
- INTEGER :: arr(n), n
+ /* 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;
+ }
+ }
- The namespace is needed for IMPLICIT typing. */
+ /* Variable not assignable from a PURE procedure but appears in
+ variable definition context. */
+ if (!pointer && 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;
+ }
-static gfc_namespace* check_typed_ns;
+ if (!pointer && gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
-static bool
-expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
- int* f ATTRIBUTE_UNUSED)
-{
- gfc_try t;
+ /* Check variable definition context for associate-names. */
+ if (!pointer && sym->assoc)
+ {
+ const char* name;
+ gfc_association_list* assoc;
- if (e->expr_type != EXPR_VARIABLE)
- return false;
+ gcc_assert (sym->assoc->target);
- gcc_assert (e->symtree);
- t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
- true, e->where);
+ /* 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;
- return (t == FAILURE);
-}
+ gcc_assert (t->expr_type == EXPR_VARIABLE);
+ name = t->symtree->name;
-gfc_try
-gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
-{
- bool error_found;
+ 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);
- /* If this is a top-level variable, do the check with strict given to us. */
- if (!strict && e->expr_type == EXPR_VARIABLE && !e->ref)
- return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
+ /* 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;
+ }
- /* Otherwise, walk the expression and do it strictly. */
- check_typed_ns = ns;
- error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
+ /* Target must be allowed to appear in a variable definition context. */
+ if (gfc_check_vardef_context (assoc->target, pointer, 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 error_found ? FAILURE : SUCCESS;
+ return SUCCESS;
}
OSDN Git Service
