4c6b3ec750
2007-04-07 Paul Thomas <pault@gcc.gnu.org> PR fortran/30872 * expr.c (find_array_element): Correct arithmetic for rank > 1. 2007-04-07 Paul Thomas <pault@gcc.gnu.org> PR fortran/30872 * gfortran.dg/parameter_array_element_1.f90: New test. From-SVN: r123644
2635 lines
59 KiB
C
2635 lines
59 KiB
C
/* Routines for manipulation of expression nodes.
|
|
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
|
|
Free Software Foundation, Inc.
|
|
Contributed by Andy Vaught
|
|
|
|
This file is part of GCC.
|
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
|
the terms of the GNU General Public License as published by the Free
|
|
Software Foundation; either version 2, or (at your option) any later
|
|
version.
|
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
|
for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with GCC; see the file COPYING. If not, write to the Free
|
|
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
|
|
02110-1301, USA. */
|
|
|
|
#include "config.h"
|
|
#include "system.h"
|
|
#include "gfortran.h"
|
|
#include "arith.h"
|
|
#include "match.h"
|
|
|
|
/* Get a new expr node. */
|
|
|
|
gfc_expr *
|
|
gfc_get_expr (void)
|
|
{
|
|
gfc_expr *e;
|
|
|
|
e = gfc_getmem (sizeof (gfc_expr));
|
|
gfc_clear_ts (&e->ts);
|
|
e->shape = NULL;
|
|
e->ref = NULL;
|
|
e->symtree = NULL;
|
|
e->con_by_offset = NULL;
|
|
return e;
|
|
}
|
|
|
|
|
|
/* Free an argument list and everything below it. */
|
|
|
|
void
|
|
gfc_free_actual_arglist (gfc_actual_arglist *a1)
|
|
{
|
|
gfc_actual_arglist *a2;
|
|
|
|
while (a1)
|
|
{
|
|
a2 = a1->next;
|
|
gfc_free_expr (a1->expr);
|
|
gfc_free (a1);
|
|
a1 = a2;
|
|
}
|
|
}
|
|
|
|
|
|
/* Copy an arglist structure and all of the arguments. */
|
|
|
|
gfc_actual_arglist *
|
|
gfc_copy_actual_arglist (gfc_actual_arglist *p)
|
|
{
|
|
gfc_actual_arglist *head, *tail, *new;
|
|
|
|
head = tail = NULL;
|
|
|
|
for (; p; p = p->next)
|
|
{
|
|
new = gfc_get_actual_arglist ();
|
|
*new = *p;
|
|
|
|
new->expr = gfc_copy_expr (p->expr);
|
|
new->next = NULL;
|
|
|
|
if (head == NULL)
|
|
head = new;
|
|
else
|
|
tail->next = new;
|
|
|
|
tail = new;
|
|
}
|
|
|
|
return head;
|
|
}
|
|
|
|
|
|
/* Free a list of reference structures. */
|
|
|
|
void
|
|
gfc_free_ref_list (gfc_ref *p)
|
|
{
|
|
gfc_ref *q;
|
|
int i;
|
|
|
|
for (; p; p = q)
|
|
{
|
|
q = p->next;
|
|
|
|
switch (p->type)
|
|
{
|
|
case REF_ARRAY:
|
|
for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
|
|
{
|
|
gfc_free_expr (p->u.ar.start[i]);
|
|
gfc_free_expr (p->u.ar.end[i]);
|
|
gfc_free_expr (p->u.ar.stride[i]);
|
|
}
|
|
|
|
break;
|
|
|
|
case REF_SUBSTRING:
|
|
gfc_free_expr (p->u.ss.start);
|
|
gfc_free_expr (p->u.ss.end);
|
|
break;
|
|
|
|
case REF_COMPONENT:
|
|
break;
|
|
}
|
|
|
|
gfc_free (p);
|
|
}
|
|
}
|
|
|
|
|
|
/* Workhorse function for gfc_free_expr() that frees everything
|
|
beneath an expression node, but not the node itself. This is
|
|
useful when we want to simplify a node and replace it with
|
|
something else or the expression node belongs to another structure. */
|
|
|
|
static void
|
|
free_expr0 (gfc_expr *e)
|
|
{
|
|
int n;
|
|
|
|
switch (e->expr_type)
|
|
{
|
|
case EXPR_CONSTANT:
|
|
if (e->from_H)
|
|
{
|
|
gfc_free (e->value.character.string);
|
|
break;
|
|
}
|
|
|
|
switch (e->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
mpz_clear (e->value.integer);
|
|
break;
|
|
|
|
case BT_REAL:
|
|
mpfr_clear (e->value.real);
|
|
break;
|
|
|
|
case BT_CHARACTER:
|
|
case BT_HOLLERITH:
|
|
gfc_free (e->value.character.string);
|
|
break;
|
|
|
|
case BT_COMPLEX:
|
|
mpfr_clear (e->value.complex.r);
|
|
mpfr_clear (e->value.complex.i);
|
|
break;
|
|
|
|
default:
|
|
break;
|
|
}
|
|
|
|
break;
|
|
|
|
case EXPR_OP:
|
|
if (e->value.op.op1 != NULL)
|
|
gfc_free_expr (e->value.op.op1);
|
|
if (e->value.op.op2 != NULL)
|
|
gfc_free_expr (e->value.op.op2);
|
|
break;
|
|
|
|
case EXPR_FUNCTION:
|
|
gfc_free_actual_arglist (e->value.function.actual);
|
|
break;
|
|
|
|
case EXPR_VARIABLE:
|
|
break;
|
|
|
|
case EXPR_ARRAY:
|
|
case EXPR_STRUCTURE:
|
|
gfc_free_constructor (e->value.constructor);
|
|
break;
|
|
|
|
case EXPR_SUBSTRING:
|
|
gfc_free (e->value.character.string);
|
|
break;
|
|
|
|
case EXPR_NULL:
|
|
break;
|
|
|
|
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]);
|
|
|
|
gfc_free (e->shape);
|
|
}
|
|
|
|
gfc_free_ref_list (e->ref);
|
|
|
|
memset (e, '\0', sizeof (gfc_expr));
|
|
}
|
|
|
|
|
|
/* Free an expression node and everything beneath it. */
|
|
|
|
void
|
|
gfc_free_expr (gfc_expr *e)
|
|
{
|
|
if (e == NULL)
|
|
return;
|
|
if (e->con_by_offset)
|
|
splay_tree_delete (e->con_by_offset);
|
|
free_expr0 (e);
|
|
gfc_free (e);
|
|
}
|
|
|
|
|
|
/* Graft the *src expression onto the *dest subexpression. */
|
|
|
|
void
|
|
gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
|
|
{
|
|
free_expr0 (dest);
|
|
*dest = *src;
|
|
gfc_free (src);
|
|
}
|
|
|
|
|
|
/* Try to extract an integer constant from the passed expression node.
|
|
Returns an error message or NULL if the result is set. It is
|
|
tempting to generate an error and return SUCCESS or FAILURE, but
|
|
failure is OK for some callers. */
|
|
|
|
const char *
|
|
gfc_extract_int (gfc_expr *expr, int *result)
|
|
{
|
|
if (expr->expr_type != EXPR_CONSTANT)
|
|
return _("Constant expression required at %C");
|
|
|
|
if (expr->ts.type != BT_INTEGER)
|
|
return _("Integer expression required at %C");
|
|
|
|
if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
|
|
|| (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
|
|
{
|
|
return _("Integer value too large in expression at %C");
|
|
}
|
|
|
|
*result = (int) mpz_get_si (expr->value.integer);
|
|
|
|
return NULL;
|
|
}
|
|
|
|
|
|
/* Recursively copy a list of reference structures. */
|
|
|
|
static gfc_ref *
|
|
copy_ref (gfc_ref *src)
|
|
{
|
|
gfc_array_ref *ar;
|
|
gfc_ref *dest;
|
|
|
|
if (src == NULL)
|
|
return NULL;
|
|
|
|
dest = gfc_get_ref ();
|
|
dest->type = src->type;
|
|
|
|
switch (src->type)
|
|
{
|
|
case REF_ARRAY:
|
|
ar = gfc_copy_array_ref (&src->u.ar);
|
|
dest->u.ar = *ar;
|
|
gfc_free (ar);
|
|
break;
|
|
|
|
case REF_COMPONENT:
|
|
dest->u.c = src->u.c;
|
|
break;
|
|
|
|
case REF_SUBSTRING:
|
|
dest->u.ss = src->u.ss;
|
|
dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
|
|
dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
|
|
break;
|
|
}
|
|
|
|
dest->next = 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;
|
|
char *s;
|
|
|
|
if (p == NULL)
|
|
return NULL;
|
|
|
|
q = gfc_get_expr ();
|
|
*q = *p;
|
|
|
|
switch (q->expr_type)
|
|
{
|
|
case EXPR_SUBSTRING:
|
|
s = gfc_getmem (p->value.character.length + 1);
|
|
q->value.character.string = s;
|
|
|
|
memcpy (s, p->value.character.string, p->value.character.length + 1);
|
|
break;
|
|
|
|
case EXPR_CONSTANT:
|
|
if (p->from_H)
|
|
{
|
|
s = gfc_getmem (p->value.character.length + 1);
|
|
q->value.character.string = s;
|
|
|
|
memcpy (s, p->value.character.string, p->value.character.length + 1);
|
|
break;
|
|
}
|
|
switch (q->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
mpz_init_set (q->value.integer, p->value.integer);
|
|
break;
|
|
|
|
case BT_REAL:
|
|
gfc_set_model_kind (q->ts.kind);
|
|
mpfr_init (q->value.real);
|
|
mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
|
|
break;
|
|
|
|
case BT_COMPLEX:
|
|
gfc_set_model_kind (q->ts.kind);
|
|
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);
|
|
break;
|
|
|
|
case BT_CHARACTER:
|
|
case BT_HOLLERITH:
|
|
s = gfc_getmem (p->value.character.length + 1);
|
|
q->value.character.string = s;
|
|
|
|
memcpy (s, p->value.character.string, p->value.character.length + 1);
|
|
break;
|
|
|
|
case BT_LOGICAL:
|
|
case BT_DERIVED:
|
|
break; /* Already done */
|
|
|
|
case BT_PROCEDURE:
|
|
case BT_UNKNOWN:
|
|
gfc_internal_error ("gfc_copy_expr(): Bad expr node");
|
|
/* Not reached */
|
|
}
|
|
|
|
break;
|
|
|
|
case EXPR_OP:
|
|
switch (q->value.op.operator)
|
|
{
|
|
case INTRINSIC_NOT:
|
|
case INTRINSIC_UPLUS:
|
|
case INTRINSIC_UMINUS:
|
|
q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
|
|
break;
|
|
|
|
default: /* Binary operators */
|
|
q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
|
|
q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
|
|
break;
|
|
}
|
|
|
|
break;
|
|
|
|
case EXPR_FUNCTION:
|
|
q->value.function.actual =
|
|
gfc_copy_actual_arglist (p->value.function.actual);
|
|
break;
|
|
|
|
case EXPR_STRUCTURE:
|
|
case EXPR_ARRAY:
|
|
q->value.constructor = gfc_copy_constructor (p->value.constructor);
|
|
break;
|
|
|
|
case EXPR_VARIABLE:
|
|
case EXPR_NULL:
|
|
break;
|
|
}
|
|
|
|
q->shape = gfc_copy_shape (p->shape, p->rank);
|
|
|
|
q->ref = copy_ref (p->ref);
|
|
|
|
return q;
|
|
}
|
|
|
|
|
|
/* Return the maximum kind of two expressions. In general, higher
|
|
kind numbers mean more precision for numeric types. */
|
|
|
|
int
|
|
gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
|
|
{
|
|
return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
|
|
}
|
|
|
|
|
|
/* Returns nonzero if the type is numeric, zero otherwise. */
|
|
|
|
static int
|
|
numeric_type (bt type)
|
|
{
|
|
return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
|
|
}
|
|
|
|
|
|
/* Returns nonzero if the typespec is a numeric type, zero otherwise. */
|
|
|
|
int
|
|
gfc_numeric_ts (gfc_typespec *ts)
|
|
{
|
|
return numeric_type (ts->type);
|
|
}
|
|
|
|
|
|
/* Returns an expression node that is an integer constant. */
|
|
|
|
gfc_expr *
|
|
gfc_int_expr (int i)
|
|
{
|
|
gfc_expr *p;
|
|
|
|
p = gfc_get_expr ();
|
|
|
|
p->expr_type = EXPR_CONSTANT;
|
|
p->ts.type = BT_INTEGER;
|
|
p->ts.kind = gfc_default_integer_kind;
|
|
|
|
p->where = gfc_current_locus;
|
|
mpz_init_set_si (p->value.integer, i);
|
|
|
|
return p;
|
|
}
|
|
|
|
|
|
/* Returns an expression node that is a logical constant. */
|
|
|
|
gfc_expr *
|
|
gfc_logical_expr (int i, locus *where)
|
|
{
|
|
gfc_expr *p;
|
|
|
|
p = gfc_get_expr ();
|
|
|
|
p->expr_type = EXPR_CONSTANT;
|
|
p->ts.type = BT_LOGICAL;
|
|
p->ts.kind = gfc_default_logical_kind;
|
|
|
|
if (where == NULL)
|
|
where = &gfc_current_locus;
|
|
p->where = *where;
|
|
p->value.logical = i;
|
|
|
|
return p;
|
|
}
|
|
|
|
|
|
/* Return an expression node with an optional argument list attached.
|
|
A variable number of gfc_expr pointers are strung together in an
|
|
argument list with a NULL pointer terminating the list. */
|
|
|
|
gfc_expr *
|
|
gfc_build_conversion (gfc_expr *e)
|
|
{
|
|
gfc_expr *p;
|
|
|
|
p = gfc_get_expr ();
|
|
p->expr_type = EXPR_FUNCTION;
|
|
p->symtree = NULL;
|
|
p->value.function.actual = NULL;
|
|
|
|
p->value.function.actual = gfc_get_actual_arglist ();
|
|
p->value.function.actual->expr = e;
|
|
|
|
return p;
|
|
}
|
|
|
|
|
|
/* Given an expression node with some sort of numeric binary
|
|
expression, insert type conversions required to make the operands
|
|
have the same type.
|
|
|
|
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)
|
|
{
|
|
gfc_expr *op1, *op2;
|
|
|
|
op1 = e->value.op.op1;
|
|
op2 = e->value.op.op2;
|
|
|
|
if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
|
|
{
|
|
gfc_clear_ts (&e->ts);
|
|
return;
|
|
}
|
|
|
|
/* Kind conversions of same type. */
|
|
if (op1->ts.type == op2->ts.type)
|
|
{
|
|
if (op1->ts.kind == op2->ts.kind)
|
|
{
|
|
/* No type conversions. */
|
|
e->ts = op1->ts;
|
|
goto done;
|
|
}
|
|
|
|
if (op1->ts.kind > op2->ts.kind)
|
|
gfc_convert_type (op2, &op1->ts, 2);
|
|
else
|
|
gfc_convert_type (op1, &op2->ts, 2);
|
|
|
|
e->ts = op1->ts;
|
|
goto done;
|
|
}
|
|
|
|
/* Integer combined with real or complex. */
|
|
if (op2->ts.type == BT_INTEGER)
|
|
{
|
|
e->ts = op1->ts;
|
|
|
|
/* Special case for ** operator. */
|
|
if (e->value.op.operator == INTRINSIC_POWER)
|
|
goto done;
|
|
|
|
gfc_convert_type (e->value.op.op2, &e->ts, 2);
|
|
goto done;
|
|
}
|
|
|
|
if (op1->ts.type == BT_INTEGER)
|
|
{
|
|
e->ts = op2->ts;
|
|
gfc_convert_type (e->value.op.op1, &e->ts, 2);
|
|
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 (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;
|
|
}
|
|
|
|
|
|
/* Function to determine if an expression is constant or not. This
|
|
function expects that the expression has already been simplified. */
|
|
|
|
int
|
|
gfc_is_constant_expr (gfc_expr *e)
|
|
{
|
|
gfc_constructor *c;
|
|
gfc_actual_arglist *arg;
|
|
int rv;
|
|
|
|
if (e == NULL)
|
|
return 1;
|
|
|
|
switch (e->expr_type)
|
|
{
|
|
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:
|
|
/* Call to intrinsic with at least one argument. */
|
|
rv = 0;
|
|
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))
|
|
break;
|
|
}
|
|
if (arg == NULL)
|
|
rv = 1;
|
|
}
|
|
break;
|
|
|
|
case EXPR_CONSTANT:
|
|
case EXPR_NULL:
|
|
rv = 1;
|
|
break;
|
|
|
|
case EXPR_SUBSTRING:
|
|
rv = (gfc_is_constant_expr (e->ref->u.ss.start)
|
|
&& gfc_is_constant_expr (e->ref->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))
|
|
break;
|
|
|
|
if (c == NULL)
|
|
rv = 1;
|
|
break;
|
|
|
|
case EXPR_ARRAY:
|
|
rv = gfc_constant_ac (e);
|
|
break;
|
|
|
|
default:
|
|
gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
|
|
}
|
|
|
|
return rv;
|
|
}
|
|
|
|
|
|
/* Try to collapse intrinsic expressions. */
|
|
|
|
static try
|
|
simplify_intrinsic_op (gfc_expr *p, int type)
|
|
{
|
|
gfc_expr *op1, *op2, *result;
|
|
|
|
if (p->value.op.operator == INTRINSIC_USER)
|
|
return SUCCESS;
|
|
|
|
op1 = p->value.op.op1;
|
|
op2 = p->value.op.op2;
|
|
|
|
if (gfc_simplify_expr (op1, type) == FAILURE)
|
|
return FAILURE;
|
|
if (gfc_simplify_expr (op2, type) == FAILURE)
|
|
return FAILURE;
|
|
|
|
if (!gfc_is_constant_expr (op1)
|
|
|| (op2 != NULL && !gfc_is_constant_expr (op2)))
|
|
return SUCCESS;
|
|
|
|
/* Rip p apart */
|
|
p->value.op.op1 = NULL;
|
|
p->value.op.op2 = NULL;
|
|
|
|
switch (p->value.op.operator)
|
|
{
|
|
case INTRINSIC_UPLUS:
|
|
case INTRINSIC_PARENTHESES:
|
|
result = gfc_uplus (op1);
|
|
break;
|
|
|
|
case INTRINSIC_UMINUS:
|
|
result = gfc_uminus (op1);
|
|
break;
|
|
|
|
case INTRINSIC_PLUS:
|
|
result = gfc_add (op1, op2);
|
|
break;
|
|
|
|
case INTRINSIC_MINUS:
|
|
result = gfc_subtract (op1, op2);
|
|
break;
|
|
|
|
case INTRINSIC_TIMES:
|
|
result = gfc_multiply (op1, op2);
|
|
break;
|
|
|
|
case INTRINSIC_DIVIDE:
|
|
result = gfc_divide (op1, op2);
|
|
break;
|
|
|
|
case INTRINSIC_POWER:
|
|
result = gfc_power (op1, op2);
|
|
break;
|
|
|
|
case INTRINSIC_CONCAT:
|
|
result = gfc_concat (op1, op2);
|
|
break;
|
|
|
|
case INTRINSIC_EQ:
|
|
result = gfc_eq (op1, op2);
|
|
break;
|
|
|
|
case INTRINSIC_NE:
|
|
result = gfc_ne (op1, op2);
|
|
break;
|
|
|
|
case INTRINSIC_GT:
|
|
result = gfc_gt (op1, op2);
|
|
break;
|
|
|
|
case INTRINSIC_GE:
|
|
result = gfc_ge (op1, op2);
|
|
break;
|
|
|
|
case INTRINSIC_LT:
|
|
result = gfc_lt (op1, op2);
|
|
break;
|
|
|
|
case INTRINSIC_LE:
|
|
result = gfc_le (op1, op2);
|
|
break;
|
|
|
|
case INTRINSIC_NOT:
|
|
result = gfc_not (op1);
|
|
break;
|
|
|
|
case INTRINSIC_AND:
|
|
result = gfc_and (op1, op2);
|
|
break;
|
|
|
|
case INTRINSIC_OR:
|
|
result = gfc_or (op1, op2);
|
|
break;
|
|
|
|
case INTRINSIC_EQV:
|
|
result = gfc_eqv (op1, op2);
|
|
break;
|
|
|
|
case INTRINSIC_NEQV:
|
|
result = gfc_neqv (op1, op2);
|
|
break;
|
|
|
|
default:
|
|
gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
|
|
}
|
|
|
|
if (result == NULL)
|
|
{
|
|
gfc_free_expr (op1);
|
|
gfc_free_expr (op2);
|
|
return FAILURE;
|
|
}
|
|
|
|
result->rank = p->rank;
|
|
result->where = p->where;
|
|
gfc_replace_expr (p, result);
|
|
|
|
return SUCCESS;
|
|
}
|
|
|
|
|
|
/* Subroutine to simplify constructor expressions. Mutually recursive
|
|
with gfc_simplify_expr(). */
|
|
|
|
static try
|
|
simplify_constructor (gfc_constructor *c, int type)
|
|
{
|
|
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 && gfc_simplify_expr (c->expr, type) == FAILURE)
|
|
return FAILURE;
|
|
}
|
|
|
|
return SUCCESS;
|
|
}
|
|
|
|
|
|
/* Pull a single array element out of an array constructor. */
|
|
|
|
static try
|
|
find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
|
|
gfc_constructor **rval)
|
|
{
|
|
unsigned long nelemen;
|
|
int i;
|
|
mpz_t delta;
|
|
mpz_t offset;
|
|
mpz_t span;
|
|
mpz_t tmp;
|
|
gfc_expr *e;
|
|
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++)
|
|
{
|
|
e = gfc_copy_expr (ar->start[i]);
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
{
|
|
cons = NULL;
|
|
goto depart;
|
|
}
|
|
|
|
/* 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);
|
|
}
|
|
|
|
if (cons)
|
|
{
|
|
for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
|
|
{
|
|
if (cons->iterator)
|
|
{
|
|
cons = NULL;
|
|
goto depart;
|
|
}
|
|
cons = cons->next;
|
|
}
|
|
}
|
|
|
|
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 *cons, gfc_ref *ref)
|
|
{
|
|
gfc_component *comp;
|
|
gfc_component *pick;
|
|
|
|
comp = ref->u.c.sym->components;
|
|
pick = ref->u.c.component;
|
|
while (comp != pick)
|
|
{
|
|
comp = comp->next;
|
|
cons = cons->next;
|
|
}
|
|
|
|
return cons;
|
|
}
|
|
|
|
|
|
/* 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;
|
|
|
|
e = cons->expr;
|
|
cons->expr = NULL;
|
|
e->ref = p->ref->next;
|
|
p->ref->next = NULL;
|
|
gfc_replace_expr (p, e);
|
|
}
|
|
|
|
|
|
/* Pull an array section out of an array constructor. */
|
|
|
|
static 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;
|
|
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. */
|
|
{
|
|
gcc_assert (begin);
|
|
|
|
if (begin->expr_type != EXPR_ARRAY)
|
|
{
|
|
t = FAILURE;
|
|
goto cleanup;
|
|
}
|
|
|
|
gcc_assert (begin->rank == 1);
|
|
gcc_assert (begin->shape);
|
|
|
|
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]);
|
|
|
|
/* 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;
|
|
}
|
|
|
|
/* 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 (index);
|
|
mpz_init (ptr);
|
|
cons = 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 (!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]);
|
|
|
|
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;
|
|
}
|
|
}
|
|
|
|
/* 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;
|
|
}
|
|
|
|
while (mpz_cmp (ptr, index) > 0)
|
|
{
|
|
mpz_add_ui (index, index, one);
|
|
cons = cons->next;
|
|
}
|
|
|
|
gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
|
|
}
|
|
|
|
mpz_clear (ptr);
|
|
mpz_clear (index);
|
|
|
|
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_free_constructor (base);
|
|
return t;
|
|
}
|
|
|
|
/* Pull a substring out of an expression. */
|
|
|
|
static try
|
|
find_substring_ref (gfc_expr *p, gfc_expr **newp)
|
|
{
|
|
int end;
|
|
int start;
|
|
char *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);
|
|
chr = p->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);
|
|
|
|
(*newp)->value.character.length = end - start + 1;
|
|
strncpy ((*newp)->value.character.string, &chr[start - 1],
|
|
(*newp)->value.character.length);
|
|
return SUCCESS;
|
|
}
|
|
|
|
|
|
|
|
/* Simplify a subobject reference of a constructor. This occurs when
|
|
parameter variable values are substituted. */
|
|
|
|
static try
|
|
simplify_const_ref (gfc_expr *p)
|
|
{
|
|
gfc_constructor *cons;
|
|
gfc_expr *newp;
|
|
|
|
while (p->ref)
|
|
{
|
|
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;
|
|
|
|
/* FALLTHROUGH */
|
|
|
|
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 = copy_ref (p->ref->next);
|
|
simplify_const_ref (cons->expr);
|
|
}
|
|
}
|
|
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 try
|
|
simplify_ref_chain (gfc_ref *ref, int type)
|
|
{
|
|
int n;
|
|
|
|
for (; ref; ref = ref->next)
|
|
{
|
|
switch (ref->type)
|
|
{
|
|
case REF_ARRAY:
|
|
for (n = 0; n < ref->u.ar.dimen; n++)
|
|
{
|
|
if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
|
|
return FAILURE;
|
|
if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
|
|
return FAILURE;
|
|
if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
|
|
return FAILURE;
|
|
}
|
|
break;
|
|
|
|
case REF_SUBSTRING:
|
|
if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
|
|
return FAILURE;
|
|
if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
|
|
return FAILURE;
|
|
break;
|
|
|
|
default:
|
|
break;
|
|
}
|
|
}
|
|
return SUCCESS;
|
|
}
|
|
|
|
|
|
/* Try to substitute the value of a parameter variable. */
|
|
static try
|
|
simplify_parameter_variable (gfc_expr *p, int type)
|
|
{
|
|
gfc_expr *e;
|
|
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 = 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. */
|
|
|
|
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))
|
|
{
|
|
char *s;
|
|
int start, end;
|
|
|
|
gfc_extract_int (p->ref->u.ss.start, &start);
|
|
start--; /* Convert from one-based to zero-based. */
|
|
gfc_extract_int (p->ref->u.ss.end, &end);
|
|
s = gfc_getmem (end - start + 2);
|
|
memcpy (s, p->value.character.string + start, end - start);
|
|
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;
|
|
}
|
|
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 || 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);
|
|
|
|
if (simplify_const_ref (p) == FAILURE)
|
|
return FAILURE;
|
|
|
|
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 try check_init_expr (gfc_expr *);
|
|
|
|
static try
|
|
check_intrinsic_op (gfc_expr *e, 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.operator)
|
|
{
|
|
case INTRINSIC_UPLUS:
|
|
case INTRINSIC_UMINUS:
|
|
if (!numeric_type (et0 (op1)))
|
|
goto not_numeric;
|
|
break;
|
|
|
|
case INTRINSIC_EQ:
|
|
case INTRINSIC_NE:
|
|
case INTRINSIC_GT:
|
|
case INTRINSIC_GE:
|
|
case INTRINSIC_LT:
|
|
case INTRINSIC_LE:
|
|
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;
|
|
|
|
if (e->value.op.operator == INTRINSIC_POWER
|
|
&& check_function == check_init_expr && et0 (op2) != BT_INTEGER)
|
|
{
|
|
if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
|
|
"exponent in an initialization "
|
|
"expression at %L", &op2->where)
|
|
== FAILURE)
|
|
return FAILURE;
|
|
}
|
|
|
|
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;
|
|
}
|
|
|
|
|
|
|
|
/* Certain inquiry functions are specifically allowed to have variable
|
|
arguments, which is an exception to the normal requirement that an
|
|
initialization function have initialization arguments. We head off
|
|
this problem here. */
|
|
|
|
static try
|
|
check_inquiry (gfc_expr *e, int not_restricted)
|
|
{
|
|
const char *name;
|
|
|
|
/* FIXME: This should be moved into the intrinsic definitions,
|
|
to eliminate this ugly hack. */
|
|
static const char * const inquiry_function[] = {
|
|
"digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
|
|
"precision", "radix", "range", "tiny", "bit_size", "size", "shape",
|
|
"lbound", "ubound", NULL
|
|
};
|
|
|
|
int i;
|
|
|
|
/* An undeclared parameter will get us here (PR25018). */
|
|
if (e->symtree == NULL)
|
|
return FAILURE;
|
|
|
|
name = e->symtree->n.sym->name;
|
|
|
|
for (i = 0; inquiry_function[i]; i++)
|
|
if (strcmp (inquiry_function[i], name) == 0)
|
|
break;
|
|
|
|
if (inquiry_function[i] == NULL)
|
|
return FAILURE;
|
|
|
|
e = e->value.function.actual->expr;
|
|
|
|
if (e == NULL || e->expr_type != EXPR_VARIABLE)
|
|
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 allowed to be undefined. */
|
|
|
|
if (e->ts.type == BT_UNKNOWN)
|
|
{
|
|
if (e->symtree->n.sym->ts.type == BT_UNKNOWN
|
|
&& gfc_set_default_type (e->symtree->n.sym, 0, gfc_current_ns)
|
|
== FAILURE)
|
|
return FAILURE;
|
|
|
|
e->ts = e->symtree->n.sym->ts;
|
|
}
|
|
|
|
/* Assumed character length will not reduce to a constant expression
|
|
with LEN, as required by the standard. */
|
|
if (i == 4 && not_restricted
|
|
&& e->symtree->n.sym->ts.type == BT_CHARACTER
|
|
&& e->symtree->n.sym->ts.cl->length == NULL)
|
|
gfc_notify_std (GFC_STD_GNU, "assumed character length "
|
|
"variable '%s' in constant expression at %L",
|
|
e->symtree->n.sym->name, &e->where);
|
|
|
|
return SUCCESS;
|
|
}
|
|
|
|
|
|
/* 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 try
|
|
check_init_expr (gfc_expr *e)
|
|
{
|
|
gfc_actual_arglist *ap;
|
|
match m;
|
|
try t;
|
|
|
|
if (e == NULL)
|
|
return SUCCESS;
|
|
|
|
switch (e->expr_type)
|
|
{
|
|
case EXPR_OP:
|
|
t = check_intrinsic_op (e, check_init_expr);
|
|
if (t == SUCCESS)
|
|
t = gfc_simplify_expr (e, 0);
|
|
|
|
break;
|
|
|
|
case EXPR_FUNCTION:
|
|
t = SUCCESS;
|
|
|
|
if (check_inquiry (e, 1) != SUCCESS)
|
|
{
|
|
t = SUCCESS;
|
|
for (ap = e->value.function.actual; ap; ap = ap->next)
|
|
if (check_init_expr (ap->expr) == FAILURE)
|
|
{
|
|
t = FAILURE;
|
|
break;
|
|
}
|
|
}
|
|
|
|
if (t == SUCCESS)
|
|
{
|
|
m = gfc_intrinsic_func_interface (e, 0);
|
|
|
|
if (m == MATCH_NO)
|
|
gfc_error ("Function '%s' in initialization expression at %L "
|
|
"must be an intrinsic function",
|
|
e->symtree->n.sym->name, &e->where);
|
|
|
|
if (m != MATCH_YES)
|
|
t = FAILURE;
|
|
}
|
|
|
|
break;
|
|
|
|
case EXPR_VARIABLE:
|
|
t = SUCCESS;
|
|
|
|
if (gfc_check_iter_variable (e) == SUCCESS)
|
|
break;
|
|
|
|
if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
|
|
{
|
|
t = simplify_parameter_variable (e, 0);
|
|
break;
|
|
}
|
|
|
|
if (gfc_in_match_data ())
|
|
break;
|
|
|
|
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);
|
|
t = FAILURE;
|
|
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:
|
|
t = gfc_check_constructor (e, check_init_expr);
|
|
break;
|
|
|
|
case EXPR_ARRAY:
|
|
t = gfc_check_constructor (e, check_init_expr);
|
|
if (t == FAILURE)
|
|
break;
|
|
|
|
t = gfc_expand_constructor (e);
|
|
if (t == FAILURE)
|
|
break;
|
|
|
|
t = gfc_check_constructor_type (e);
|
|
break;
|
|
|
|
default:
|
|
gfc_internal_error ("check_init_expr(): Unknown expression type");
|
|
}
|
|
|
|
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;
|
|
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)
|
|
{
|
|
gfc_free_expr (expr);
|
|
return MATCH_ERROR;
|
|
}
|
|
|
|
if (expr->expr_type == EXPR_ARRAY
|
|
&& (gfc_check_constructor_type (expr) == FAILURE
|
|
|| gfc_expand_constructor (expr) == FAILURE))
|
|
{
|
|
gfc_free_expr (expr);
|
|
return MATCH_ERROR;
|
|
}
|
|
|
|
/* 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) == FAILURE
|
|
&& !gfc_in_match_data ())
|
|
{
|
|
gfc_error ("Initialization expression didn't reduce %C");
|
|
return MATCH_ERROR;
|
|
}
|
|
|
|
*result = expr;
|
|
|
|
return MATCH_YES;
|
|
}
|
|
|
|
|
|
static try check_restricted (gfc_expr *);
|
|
|
|
/* 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 try
|
|
restricted_args (gfc_actual_arglist *a)
|
|
{
|
|
for (; a; a = a->next)
|
|
{
|
|
if (check_restricted (a->expr) == FAILURE)
|
|
return FAILURE;
|
|
}
|
|
|
|
return SUCCESS;
|
|
}
|
|
|
|
|
|
/************* Restricted/specification expressions *************/
|
|
|
|
|
|
/* Make sure a non-intrinsic function is a specification function. */
|
|
|
|
static try
|
|
external_spec_function (gfc_expr *e)
|
|
{
|
|
gfc_symbol *f;
|
|
|
|
f = e->value.function.esym;
|
|
|
|
if (f->attr.proc == PROC_ST_FUNCTION)
|
|
{
|
|
gfc_error ("Specification function '%s' at %L cannot be a statement "
|
|
"function", f->name, &e->where);
|
|
return FAILURE;
|
|
}
|
|
|
|
if (f->attr.proc == PROC_INTERNAL)
|
|
{
|
|
gfc_error ("Specification function '%s' at %L cannot be an internal "
|
|
"function", f->name, &e->where);
|
|
return FAILURE;
|
|
}
|
|
|
|
if (!f->attr.pure && !f->attr.elemental)
|
|
{
|
|
gfc_error ("Specification function '%s' at %L must be PURE", f->name,
|
|
&e->where);
|
|
return FAILURE;
|
|
}
|
|
|
|
if (f->attr.recursive)
|
|
{
|
|
gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
|
|
f->name, &e->where);
|
|
return FAILURE;
|
|
}
|
|
|
|
return restricted_args (e->value.function.actual);
|
|
}
|
|
|
|
|
|
/* Check to see that a function reference to an intrinsic is a
|
|
restricted expression. */
|
|
|
|
static try
|
|
restricted_intrinsic (gfc_expr *e)
|
|
{
|
|
/* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
|
|
if (check_inquiry (e, 0) == SUCCESS)
|
|
return SUCCESS;
|
|
|
|
return restricted_args (e->value.function.actual);
|
|
}
|
|
|
|
|
|
/* Verify that an expression is a restricted expression. Like its
|
|
cousin check_init_expr(), an error message is generated if we
|
|
return FAILURE. */
|
|
|
|
static try
|
|
check_restricted (gfc_expr *e)
|
|
{
|
|
gfc_symbol *sym;
|
|
try t;
|
|
|
|
if (e == NULL)
|
|
return SUCCESS;
|
|
|
|
switch (e->expr_type)
|
|
{
|
|
case EXPR_OP:
|
|
t = check_intrinsic_op (e, check_restricted);
|
|
if (t == SUCCESS)
|
|
t = gfc_simplify_expr (e, 0);
|
|
|
|
break;
|
|
|
|
case EXPR_FUNCTION:
|
|
t = e->value.function.esym ? external_spec_function (e)
|
|
: restricted_intrinsic (e);
|
|
|
|
break;
|
|
|
|
case EXPR_VARIABLE:
|
|
sym = e->symtree->n.sym;
|
|
t = FAILURE;
|
|
|
|
if (sym->attr.optional)
|
|
{
|
|
gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
|
|
sym->name, &e->where);
|
|
break;
|
|
}
|
|
|
|
if (sym->attr.intent == INTENT_OUT)
|
|
{
|
|
gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
|
|
sym->name, &e->where);
|
|
break;
|
|
}
|
|
|
|
/* 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->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)))
|
|
{
|
|
t = SUCCESS;
|
|
break;
|
|
}
|
|
|
|
gfc_error ("Variable '%s' cannot appear in the expression at %L",
|
|
sym->name, &e->where);
|
|
|
|
break;
|
|
|
|
case EXPR_NULL:
|
|
case EXPR_CONSTANT:
|
|
t = SUCCESS;
|
|
break;
|
|
|
|
case EXPR_SUBSTRING:
|
|
t = gfc_specification_expr (e->ref->u.ss.start);
|
|
if (t == FAILURE)
|
|
break;
|
|
|
|
t = gfc_specification_expr (e->ref->u.ss.end);
|
|
if (t == SUCCESS)
|
|
t = gfc_simplify_expr (e, 0);
|
|
|
|
break;
|
|
|
|
case EXPR_STRUCTURE:
|
|
t = gfc_check_constructor (e, check_restricted);
|
|
break;
|
|
|
|
case EXPR_ARRAY:
|
|
t = gfc_check_constructor (e, check_restricted);
|
|
break;
|
|
|
|
default:
|
|
gfc_internal_error ("check_restricted(): Unknown expression type");
|
|
}
|
|
|
|
return t;
|
|
}
|
|
|
|
|
|
/* Check to see that an expression is a specification expression. If
|
|
we return FAILURE, an error has been generated. */
|
|
|
|
try
|
|
gfc_specification_expr (gfc_expr *e)
|
|
{
|
|
if (e == NULL)
|
|
return SUCCESS;
|
|
|
|
if (e->ts.type != BT_INTEGER)
|
|
{
|
|
gfc_error ("Expression at %L must be of INTEGER type", &e->where);
|
|
return FAILURE;
|
|
}
|
|
|
|
if (e->rank != 0)
|
|
{
|
|
gfc_error ("Expression at %L must be scalar", &e->where);
|
|
return FAILURE;
|
|
}
|
|
|
|
if (gfc_simplify_expr (e, 0) == FAILURE)
|
|
return FAILURE;
|
|
|
|
return check_restricted (e);
|
|
}
|
|
|
|
|
|
/************** Expression conformance checks. *************/
|
|
|
|
/* Given two expressions, make sure that the arrays are conformable. */
|
|
|
|
try
|
|
gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
|
|
{
|
|
int op1_flag, op2_flag, d;
|
|
mpz_t op1_size, op2_size;
|
|
try t;
|
|
|
|
if (op1->rank == 0 || op2->rank == 0)
|
|
return SUCCESS;
|
|
|
|
if (op1->rank != op2->rank)
|
|
{
|
|
gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid),
|
|
&op1->where);
|
|
return FAILURE;
|
|
}
|
|
|
|
t = SUCCESS;
|
|
|
|
for (d = 0; d < op1->rank; d++)
|
|
{
|
|
op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
|
|
op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
|
|
|
|
if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
|
|
{
|
|
gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
|
|
_(optype_msgid), &op1->where, d + 1,
|
|
(int) mpz_get_si (op1_size),
|
|
(int) mpz_get_si (op2_size));
|
|
|
|
t = FAILURE;
|
|
}
|
|
|
|
if (op1_flag)
|
|
mpz_clear (op1_size);
|
|
if (op2_flag)
|
|
mpz_clear (op2_size);
|
|
|
|
if (t == FAILURE)
|
|
return FAILURE;
|
|
}
|
|
|
|
return SUCCESS;
|
|
}
|
|
|
|
|
|
/* Given an assignable expression and an arbitrary expression, make
|
|
sure that the assignment can take place. */
|
|
|
|
try
|
|
gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
|
|
{
|
|
gfc_symbol *sym;
|
|
gfc_ref *ref;
|
|
int has_pointer;
|
|
|
|
sym = lvalue->symtree->n.sym;
|
|
|
|
/* Check INTENT(IN), unless the object itself is the component or
|
|
sub-component 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->pointer)
|
|
{
|
|
has_pointer = 1;
|
|
break;
|
|
}
|
|
|
|
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;
|
|
}
|
|
|
|
/* 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 varaiable, when it is: */
|
|
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
|
|
&& !sym->attr.external)
|
|
{
|
|
bool bad_proc;
|
|
bad_proc = false;
|
|
|
|
/* (i) Use associated; */
|
|
if (sym->attr.use_assoc)
|
|
bad_proc = true;
|
|
|
|
/* (ii) The assignment is in the main program; or */
|
|
if (gfc_current_ns->proc_name->attr.is_main_program)
|
|
bad_proc = true;
|
|
|
|
/* (iii) A module or internal procedure.... */
|
|
if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
|
|
|| gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
|
|
&& gfc_current_ns->parent
|
|
&& (!(gfc_current_ns->parent->proc_name->attr.function
|
|
|| gfc_current_ns->parent->proc_name->attr.subroutine)
|
|
|| gfc_current_ns->parent->proc_name->attr.is_main_program))
|
|
{
|
|
/* .... that is not a function.... */
|
|
if (!gfc_current_ns->proc_name->attr.function)
|
|
bad_proc = true;
|
|
|
|
/* .... or is not an entry and has a different name. */
|
|
if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
|
|
bad_proc = true;
|
|
}
|
|
|
|
if (bad_proc)
|
|
{
|
|
gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
|
|
return FAILURE;
|
|
}
|
|
}
|
|
|
|
if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
|
|
{
|
|
gfc_error ("Incompatible ranks %d and %d in assignment at %L",
|
|
lvalue->rank, rvalue->rank, &lvalue->where);
|
|
return FAILURE;
|
|
}
|
|
|
|
if (lvalue->ts.type == BT_UNKNOWN)
|
|
{
|
|
gfc_error ("Variable type is UNKNOWN in assignment at %L",
|
|
&lvalue->where);
|
|
return FAILURE;
|
|
}
|
|
|
|
if (rvalue->expr_type == EXPR_NULL)
|
|
{
|
|
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;
|
|
}
|
|
|
|
/* 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);
|
|
|
|
/* Check size of array assignments. */
|
|
if (lvalue->rank != 0 && rvalue->rank != 0
|
|
&& gfc_check_conformance ("Array assignment", lvalue, rvalue) != SUCCESS)
|
|
return FAILURE;
|
|
|
|
if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
|
|
return SUCCESS;
|
|
|
|
if (!conform)
|
|
{
|
|
/* Numeric can be converted to any other numeric. And Hollerith can be
|
|
converted to any other type. */
|
|
if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
|
|
|| rvalue->ts.type == BT_HOLLERITH)
|
|
return SUCCESS;
|
|
|
|
if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
|
|
return SUCCESS;
|
|
|
|
gfc_error ("Incompatible types in assignment at %L, %s to %s",
|
|
&rvalue->where, gfc_typename (&rvalue->ts),
|
|
gfc_typename (&lvalue->ts));
|
|
|
|
return FAILURE;
|
|
}
|
|
|
|
return gfc_convert_type (rvalue, &lvalue->ts, 1);
|
|
}
|
|
|
|
|
|
/* Check that a pointer assignment is OK. We first check lvalue, and
|
|
we only check rvalue if it's not an assignment to NULL() or a
|
|
NULLIFY statement. */
|
|
|
|
try
|
|
gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
|
|
{
|
|
symbol_attribute attr;
|
|
gfc_ref *ref;
|
|
int is_pure;
|
|
int pointer, check_intent_in;
|
|
|
|
if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
|
|
{
|
|
gfc_error ("Pointer assignment target is not a POINTER at %L",
|
|
&lvalue->where);
|
|
return FAILURE;
|
|
}
|
|
|
|
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;
|
|
}
|
|
|
|
|
|
/* 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;
|
|
|
|
for (ref = lvalue->ref; ref; ref = ref->next)
|
|
{
|
|
if (pointer)
|
|
check_intent_in = 0;
|
|
|
|
if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
|
|
pointer = 1;
|
|
}
|
|
|
|
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;
|
|
}
|
|
|
|
if (!pointer)
|
|
{
|
|
gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
|
|
return FAILURE;
|
|
}
|
|
|
|
is_pure = gfc_pure (NULL);
|
|
|
|
if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
|
|
{
|
|
gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
|
|
return FAILURE;
|
|
}
|
|
|
|
/* 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_compare_types (&lvalue->ts, &rvalue->ts))
|
|
{
|
|
gfc_error ("Different types in pointer assignment at %L",
|
|
&lvalue->where);
|
|
return FAILURE;
|
|
}
|
|
|
|
if (lvalue->ts.kind != rvalue->ts.kind)
|
|
{
|
|
gfc_error ("Different kind type parameters in pointer "
|
|
"assignment at %L", &lvalue->where);
|
|
return FAILURE;
|
|
}
|
|
|
|
if (lvalue->rank != rvalue->rank)
|
|
{
|
|
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;
|
|
|
|
if (lvalue->ts.type == BT_CHARACTER
|
|
&& 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;
|
|
}
|
|
|
|
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;
|
|
}
|
|
|
|
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;
|
|
}
|
|
|
|
if (attr.protected && attr.use_assoc)
|
|
{
|
|
gfc_error ("Pointer assigment target has PROTECTED "
|
|
"attribute at %L", &rvalue->where);
|
|
return FAILURE;
|
|
}
|
|
|
|
return SUCCESS;
|
|
}
|
|
|
|
|
|
/* Relative of gfc_check_assign() except that the lvalue is a single
|
|
symbol. Used for initialization assignments. */
|
|
|
|
try
|
|
gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
|
|
{
|
|
gfc_expr lvalue;
|
|
try r;
|
|
|
|
memset (&lvalue, '\0', sizeof (gfc_expr));
|
|
|
|
lvalue.expr_type = EXPR_VARIABLE;
|
|
lvalue.ts = sym->ts;
|
|
if (sym->as)
|
|
lvalue.rank = sym->as->rank;
|
|
lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
|
|
lvalue.symtree->n.sym = sym;
|
|
lvalue.where = sym->declared_at;
|
|
|
|
if (sym->attr.pointer)
|
|
r = gfc_check_pointer_assign (&lvalue, rvalue);
|
|
else
|
|
r = gfc_check_assign (&lvalue, rvalue, 1);
|
|
|
|
gfc_free (lvalue.symtree);
|
|
|
|
return r;
|
|
}
|
|
|
|
|
|
/* Get an expression for a default initializer. */
|
|
|
|
gfc_expr *
|
|
gfc_default_initializer (gfc_typespec *ts)
|
|
{
|
|
gfc_constructor *tail;
|
|
gfc_expr *init;
|
|
gfc_component *c;
|
|
|
|
init = NULL;
|
|
|
|
/* See if we have a default initializer. */
|
|
for (c = ts->derived->components; c; c = c->next)
|
|
{
|
|
if ((c->initializer || c->allocatable) && init == NULL)
|
|
init = gfc_get_expr ();
|
|
}
|
|
|
|
if (init == NULL)
|
|
return NULL;
|
|
|
|
/* Build the constructor. */
|
|
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)
|
|
{
|
|
if (tail == NULL)
|
|
init->value.constructor = tail = gfc_get_constructor ();
|
|
else
|
|
{
|
|
tail->next = gfc_get_constructor ();
|
|
tail = tail->next;
|
|
}
|
|
|
|
if (c->initializer)
|
|
tail->expr = gfc_copy_expr (c->initializer);
|
|
|
|
if (c->allocatable)
|
|
{
|
|
tail->expr = gfc_get_expr ();
|
|
tail->expr->expr_type = EXPR_NULL;
|
|
tail->expr->ts = c->ts;
|
|
}
|
|
}
|
|
return init;
|
|
}
|
|
|
|
|
|
/* Given a symbol, create an expression node with that symbol as a
|
|
variable. If the symbol is array valued, setup a reference of the
|
|
whole array. */
|
|
|
|
gfc_expr *
|
|
gfc_get_variable_expr (gfc_symtree *var)
|
|
{
|
|
gfc_expr *e;
|
|
|
|
e = gfc_get_expr ();
|
|
e->expr_type = EXPR_VARIABLE;
|
|
e->symtree = var;
|
|
e->ts = var->n.sym->ts;
|
|
|
|
if (var->n.sym->as != NULL)
|
|
{
|
|
e->rank = var->n.sym->as->rank;
|
|
e->ref = gfc_get_ref ();
|
|
e->ref->type = REF_ARRAY;
|
|
e->ref->u.ar.type = AR_FULL;
|
|
}
|
|
|
|
return e;
|
|
}
|
|
|
|
|
|
/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
|
|
|
|
void
|
|
gfc_expr_set_symbols_referenced (gfc_expr *expr)
|
|
{
|
|
gfc_actual_arglist *arg;
|
|
gfc_constructor *c;
|
|
gfc_ref *ref;
|
|
int i;
|
|
|
|
if (!expr) return;
|
|
|
|
switch (expr->expr_type)
|
|
{
|
|
case EXPR_OP:
|
|
gfc_expr_set_symbols_referenced (expr->value.op.op1);
|
|
gfc_expr_set_symbols_referenced (expr->value.op.op2);
|
|
break;
|
|
|
|
case EXPR_FUNCTION:
|
|
for (arg = expr->value.function.actual; arg; arg = arg->next)
|
|
gfc_expr_set_symbols_referenced (arg->expr);
|
|
break;
|
|
|
|
case EXPR_VARIABLE:
|
|
gfc_set_sym_referenced (expr->symtree->n.sym);
|
|
break;
|
|
|
|
case EXPR_CONSTANT:
|
|
case EXPR_NULL:
|
|
case EXPR_SUBSTRING:
|
|
break;
|
|
|
|
case EXPR_STRUCTURE:
|
|
case EXPR_ARRAY:
|
|
for (c = expr->value.constructor; c; c = c->next)
|
|
gfc_expr_set_symbols_referenced (c->expr);
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
break;
|
|
}
|
|
|
|
for (ref = expr->ref; ref; ref = ref->next)
|
|
switch (ref->type)
|
|
{
|
|
case REF_ARRAY:
|
|
for (i = 0; i < ref->u.ar.dimen; i++)
|
|
{
|
|
gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
|
|
gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
|
|
gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
|
|
}
|
|
break;
|
|
|
|
case REF_COMPONENT:
|
|
break;
|
|
|
|
case REF_SUBSTRING:
|
|
gfc_expr_set_symbols_referenced (ref->u.ss.start);
|
|
gfc_expr_set_symbols_referenced (ref->u.ss.end);
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
break;
|
|
}
|
|
}
|