/* Routines for manipulation of expression nodes.
- Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
- Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
+ Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
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, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
#include "config.h"
-#include <stdarg.h>
-#include <stdio.h>
-#include <string.h>
-
+#include "system.h"
#include "gfortran.h"
#include "arith.h"
#include "match.h"
e = gfc_getmem (sizeof (gfc_expr));
gfc_clear_ts (&e->ts);
- e->op1 = NULL;
- e->op2 = NULL;
e->shape = NULL;
e->ref = NULL;
e->symtree = NULL;
- e->uop = NULL;
return e;
}
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:
break;
case BT_REAL:
- mpf_clear (e->value.real);
+ mpfr_clear (e->value.real);
break;
case BT_CHARACTER:
+ case BT_HOLLERITH:
gfc_free (e->value.character.string);
break;
case BT_COMPLEX:
- mpf_clear (e->value.complex.r);
- mpf_clear (e->value.complex.i);
+ mpfr_clear (e->value.complex.r);
+ mpfr_clear (e->value.complex.i);
break;
default:
break;
case EXPR_OP:
- if (e->op1 != NULL)
- gfc_free_expr (e->op1);
- if (e->op2 != NULL)
- gfc_free_expr (e->op2);
+ 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:
{
if (expr->expr_type != EXPR_CONSTANT)
- return "Constant expression required at %C";
+ return _("Constant expression required at %C");
if (expr->ts.type != BT_INTEGER)
- return "Integer expression required at %C";
+ 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";
+ return _("Integer value too large in expression at %C");
}
*result = (int) mpz_get_si (expr->value.integer);
}
+/* 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 *
}
+/* 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. */
q->value.character.string = s;
memcpy (s, p->value.character.string, p->value.character.length + 1);
-
- q->op1 = gfc_copy_expr (p->op1);
- q->op2 = gfc_copy_expr (p->op2);
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:
break;
case BT_REAL:
- mpf_init_set (q->value.real, p->value.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:
- mpf_init_set (q->value.complex.r, p->value.complex.r);
- mpf_init_set (q->value.complex.i, p->value.complex.i);
+ 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;
break;
case EXPR_OP:
- switch (q->operator)
+ switch (q->value.op.operator)
{
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
- q->op1 = gfc_copy_expr (p->op1);
+ q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
break;
default: /* Binary operators */
- q->op1 = gfc_copy_expr (p->op1);
- q->op2 = gfc_copy_expr (p->op2);
+ q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
+ q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
break;
}
p->expr_type = EXPR_CONSTANT;
p->ts.type = BT_INTEGER;
- p->ts.kind = gfc_default_integer_kind ();
+ p->ts.kind = gfc_default_integer_kind;
- p->where = *gfc_current_locus ();
+ p->where = gfc_current_locus;
mpz_init_set_si (p->value.integer, i);
return p;
p->expr_type = EXPR_CONSTANT;
p->ts.type = BT_LOGICAL;
- p->ts.kind = gfc_default_logical_kind ();
+ p->ts.kind = gfc_default_logical_kind;
if (where == NULL)
- where = gfc_current_locus ();
+ where = &gfc_current_locus;
p->where = *where;
p->value.logical = i;
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. */
+ 1.0**2 stays as it is. */
void
gfc_type_convert_binary (gfc_expr * e)
{
gfc_expr *op1, *op2;
- op1 = e->op1;
- op2 = e->op2;
+ op1 = e->value.op.op1;
+ op2 = e->value.op.op2;
if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
{
{
e->ts = op1->ts;
- /* Special cose for ** operator. */
- if (e->operator == INTRINSIC_POWER)
+ /* Special case for ** operator. */
+ if (e->value.op.operator == INTRINSIC_POWER)
goto done;
- gfc_convert_type (e->op2, &e->ts, 2);
+ 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->op1, &e->ts, 2);
+ gfc_convert_type (e->value.op.op1, &e->ts, 2);
goto done;
}
else
e->ts.kind = op2->ts.kind;
if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
- gfc_convert_type (e->op1, &e->ts, 2);
+ 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->op2, &e->ts, 2);
+ gfc_convert_type (e->value.op.op2, &e->ts, 2);
done:
return;
switch (e->expr_type)
{
case EXPR_OP:
- rv = (gfc_is_constant_expr (e->op1)
- && (e->op2 == NULL
- || gfc_is_constant_expr (e->op2)));
+ rv = (gfc_is_constant_expr (e->value.op.op1)
+ && (e->value.op.op2 == NULL
+ || gfc_is_constant_expr (e->value.op.op2)));
break;
break;
case EXPR_SUBSTRING:
- rv = gfc_is_constant_expr (e->op1) && gfc_is_constant_expr (e->op2);
+ rv = (gfc_is_constant_expr (e->ref->u.ss.start)
+ && gfc_is_constant_expr (e->ref->u.ss.end));
break;
case EXPR_STRUCTURE:
{
gfc_expr *op1, *op2, *result;
- if (p->operator == INTRINSIC_USER)
+ if (p->value.op.operator == INTRINSIC_USER)
return SUCCESS;
- op1 = p->op1;
- op2 = p->op2;
+ op1 = p->value.op.op1;
+ op2 = p->value.op.op2;
if (gfc_simplify_expr (op1, type) == FAILURE)
return FAILURE;
return SUCCESS;
/* Rip p apart */
- p->op1 = NULL;
- p->op2 = NULL;
+ p->value.op.op1 = NULL;
+ p->value.op.op2 = NULL;
- switch (p->operator)
+ switch (p->value.op.operator)
{
case INTRINSIC_UPLUS:
+ case INTRINSIC_PARENTHESES:
result = gfc_uplus (op1);
break;
try t;
e = gfc_copy_expr (p->symtree->n.sym->value);
- if (p->ref)
+ /* 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);
break;
case EXPR_SUBSTRING:
- if (gfc_simplify_expr (p->op1, type) == FAILURE
- || gfc_simplify_expr (p->op2, type) == FAILURE)
+ if (simplify_ref_chain (p->ref, type) == FAILURE)
return FAILURE;
- /* TODO: evaluate constant substrings. */
-
+ 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 + 1);
+ memcpy (s, p->value.character.string + start, end - start);
+ s[end] = '\0'; /* TODO: C-style string for debugging. */
+ 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:
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) (e->op1) == FAILURE)
+ if ((*check_function) (op1) == FAILURE)
return FAILURE;
- switch (e->operator)
+ switch (e->value.op.operator)
{
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
- if (!numeric_type (et0 (e->op1)))
+ if (!numeric_type (et0 (op1)))
goto not_numeric;
break;
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) (e->op2) == FAILURE)
+ if ((*check_function) (op2) == FAILURE)
return FAILURE;
- if (!numeric_type (et0 (e->op1)) || !numeric_type (et0 (e->op2)))
+ if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
goto not_numeric;
- if (e->operator != INTRINSIC_POWER)
- break;
-
- if (check_function == check_init_expr && et0 (e->op2) != BT_INTEGER)
+ if (e->value.op.operator == INTRINSIC_POWER
+ && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
{
gfc_error ("Exponent at %L must be INTEGER for an initialization "
- "expression", &e->op2->where);
+ "expression", &op2->where);
return FAILURE;
}
break;
case INTRINSIC_CONCAT:
- if ((*check_function) (e->op2) == FAILURE)
+ if ((*check_function) (op2) == FAILURE)
return FAILURE;
- if (et0 (e->op1) != BT_CHARACTER || et0 (e->op2) != BT_CHARACTER)
+ if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
{
gfc_error ("Concatenation operator in expression at %L "
- "must have two CHARACTER operands", &e->op1->where);
+ "must have two CHARACTER operands", &op1->where);
return FAILURE;
}
- if (e->op1->ts.kind != e->op2->ts.kind)
+ if (op1->ts.kind != op2->ts.kind)
{
gfc_error ("Concat operator at %L must concatenate strings of the "
"same kind", &e->where);
break;
case INTRINSIC_NOT:
- if (et0 (e->op1) != BT_LOGICAL)
+ if (et0 (op1) != BT_LOGICAL)
{
gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
- "operand", &e->op1->where);
+ "operand", &op1->where);
return FAILURE;
}
case INTRINSIC_OR:
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
- if ((*check_function) (e->op2) == FAILURE)
+ if ((*check_function) (op2) == FAILURE)
return FAILURE;
- if (et0 (e->op1) != BT_LOGICAL || et0 (e->op2) != BT_LOGICAL)
+ if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
{
gfc_error ("LOGICAL operands are required in expression at %L",
&e->where);
break;
+ case INTRINSIC_PARENTHESES:
+ break;
+
default:
gfc_error ("Only intrinsic operators can be used in expression at %L",
&e->where);
this problem here. */
static try
-check_inquiry (gfc_expr * e)
+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", "maxexponent", "minexponent",
+ "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
"precision", "radix", "range", "tiny", "bit_size", "size", "shape",
"lbound", "ubound", NULL
};
int i;
- /* These functions must have exactly one argument. */
- if (e->value.function.actual == NULL
- || e->value.function.actual->next != NULL)
- return FAILURE;
-
- if (e->value.function.name != NULL
- && e->value.function.name[0] != '\0')
+ /* An undeclared parameter will get us here (PR25018). */
+ if (e->symtree == NULL)
return FAILURE;
name = e->symtree->n.sym->name;
if (e == NULL || e->expr_type != EXPR_VARIABLE)
return FAILURE;
- /* At this point we have a numeric 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. */
+ /* 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)
{
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;
}
case EXPR_FUNCTION:
t = SUCCESS;
- if (check_inquiry (e) != SUCCESS)
+ if (check_inquiry (e, 1) != SUCCESS)
{
t = SUCCESS;
for (ap = e->value.function.actual; ap; ap = ap->next)
break;
}
- gfc_error ("Variable '%s' at %L cannot appear in an initialization "
+ 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;
break;
case EXPR_SUBSTRING:
- t = check_init_expr (e->op1);
+ t = check_init_expr (e->ref->u.ss.start);
if (t == FAILURE)
break;
- t = check_init_expr (e->op2);
+ t = check_init_expr (e->ref->u.ss.end);
if (t == SUCCESS)
t = gfc_simplify_expr (e, 0);
return MATCH_ERROR;
}
- if (!gfc_is_constant_expr (expr))
- gfc_internal_error ("Initialization expression didn't reduce %C");
+ /* 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_error ("Initialization expression didn't reduce %C");
+ return MATCH_ERROR;
+ }
*result = expr;
integer or character. */
static try
-restricted_args (gfc_actual_arglist * a, int check_type)
+restricted_args (gfc_actual_arglist * a)
{
- bt type;
-
for (; a; a = a->next)
{
if (check_restricted (a->expr) == FAILURE)
return FAILURE;
-
- if (!check_type)
- continue;
-
- type = a->expr->ts.type;
- if (type != BT_CHARACTER && type != BT_INTEGER)
- {
- gfc_error
- ("Function argument at %L must be of type INTEGER or CHARACTER",
- &a->expr->where);
- return FAILURE;
- }
}
return SUCCESS;
return FAILURE;
}
- if (!f->attr.pure)
+ if (!f->attr.pure && !f->attr.elemental)
{
gfc_error ("Specification function '%s' at %L must be PURE", f->name,
&e->where);
return FAILURE;
}
- return restricted_args (e->value.function.actual, 0);
+ return restricted_args (e->value.function.actual);
}
/* Check to see that a function reference to an intrinsic is a
- restricted expression. Some functions required by the standard are
- omitted because references to them have already been simplified.
- Strictly speaking, a lot of these checks are redundant with other
- checks. If a function is indeed a particular intrinsic, then the
- type of its argument have already been checked and passed. */
+ restricted expression. */
static try
restricted_intrinsic (gfc_expr * e)
{
- gfc_intrinsic_sym *sym;
-
- static struct
- {
- const char *name;
- int case_number;
- }
- const *cp, cases[] =
- {
- {"repeat", 0},
- {"reshape", 0},
- {"selected_int_kind", 0},
- {"selected_real_kind", 0},
- {"transfer", 0},
- {"trim", 0},
- {"null", 1},
- {"lbound", 2},
- {"shape", 2},
- {"size", 2},
- {"ubound", 2},
- /* bit_size() has already been reduced */
- {"len", 0},
- /* kind() has already been reduced */
- /* Numeric inquiry functions have been reduced */
- { NULL, 0}
- };
-
- try t;
-
- sym = e->value.function.isym;
- if (!sym)
- return FAILURE;
-
- if (sym->elemental)
- return restricted_args (e->value.function.actual, 1);
-
- for (cp = cases; cp->name; cp++)
- if (strcmp (cp->name, sym->name) == 0)
- break;
-
- if (cp->name == NULL)
- {
- gfc_error ("Intrinsic function '%s' at %L is not a restricted function",
- sym->name, &e->where);
- return FAILURE;
- }
-
- switch (cp->case_number)
- {
- case 0:
- /* Functions that are restricted if they have character/integer args. */
- t = restricted_args (e->value.function.actual, 1);
- break;
-
- case 1: /* NULL() */
- t = SUCCESS;
- break;
-
- case 2:
- /* Functions that could be checking the bounds of an assumed-size array. */
- t = SUCCESS;
- /* TODO: implement checks from 7.1.6.2 (10) */
- break;
-
- default:
- gfc_internal_error ("restricted_intrinsic(): Bad case");
- }
+ /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
+ if (check_inquiry (e, 0) == SUCCESS)
+ return SUCCESS;
- return t;
+ return restricted_args (e->value.function.actual);
}
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). */
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))
+ && sym->ns->proc_name->attr.flavor == FL_MODULE)
+ || gfc_is_formal_arg ())
{
t = SUCCESS;
break;
break;
case EXPR_SUBSTRING:
- t = gfc_specification_expr (e->op1);
+ t = gfc_specification_expr (e->ref->u.ss.start);
if (t == FAILURE)
break;
- t = gfc_specification_expr (e->op2);
+ t = gfc_specification_expr (e->ref->u.ss.end);
if (t == SUCCESS)
t = gfc_simplify_expr (e, 0);
try
gfc_specification_expr (gfc_expr * e)
{
+ if (e == NULL)
+ return SUCCESS;
if (e->ts.type != BT_INTEGER)
{
/* Given two expressions, make sure that the arrays are conformable. */
try
-gfc_check_conformance (const char *optype, gfc_expr * op1, gfc_expr * op2)
+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;
if (op1->rank != op2->rank)
{
- gfc_error ("Incompatible ranks in %s at %L", optype, &op1->where);
+ gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid),
+ &op1->where);
return FAILURE;
}
if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
{
- gfc_error ("%s at %L has different shape on dimension %d (%d/%d)",
- optype, &op1->where, d + 1, (int) mpz_get_si (op1_size),
+ 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;
return FAILURE;
}
+ if (sym->attr.flavor == FL_PROCEDURE && sym->attr.use_assoc)
+ {
+ gfc_error ("'%s' in the assignment at %L cannot be an l-value "
+ "since it is a procedure", sym->name, &lvalue->where);
+ return FAILURE;
+ }
+
+
if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
{
- gfc_error ("Incompatible ranks in assignment at %L", &lvalue->where);
+ gfc_error ("Incompatible ranks %d and %d in assignment at %L",
+ lvalue->rank, rvalue->rank, &lvalue->where);
return FAILURE;
}
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)
if (!conform)
{
- if (gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
+ /* 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",
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;
+ }
+
attr = gfc_variable_attr (lvalue, NULL);
if (!attr.pointer)
{
/* 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)
+ 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 (!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->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;
+ }
- 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;
- }
+ /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
+ if (rvalue->expr_type == EXPR_NULL)
+ return SUCCESS;
- 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 (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;
}
return SUCCESS;
/* Relative of gfc_check_assign() except that the lvalue is a single
- symbol. */
+ symbol. Used for initialization assignments. */
try
gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue)
lvalue.symtree->n.sym = sym;
lvalue.where = sym->declared_at;
- r = gfc_check_assign (&lvalue, rvalue, 1);
+ if (sym->attr.pointer)
+ r = gfc_check_pointer_assign (&lvalue, rvalue);
+ else
+ r = gfc_check_assign (&lvalue, rvalue, 1);
gfc_free (lvalue.symtree);
}
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;
+ }
+}
OSDN Git Service
