/* Routines for manipulation of expression nodes.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010, 2011
- Free Software Foundation, Inc.
+ Copyright (C) 2000-2014 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "config.h"
#include "system.h"
+#include "coretypes.h"
+#include "flags.h"
#include "gfortran.h"
#include "arith.h"
#include "match.h"
case BT_LOGICAL:
case BT_DERIVED:
case BT_CLASS:
+ case BT_ASSUMED:
break; /* Already done. */
case BT_PROCEDURE:
}
+void
+gfc_clear_shape (mpz_t *shape, int rank)
+{
+ int i;
+
+ for (i = 0; i < rank; i++)
+ mpz_clear (shape[i]);
+}
+
+
+void
+gfc_free_shape (mpz_t **shape, int rank)
+{
+ if (*shape == NULL)
+ return;
+
+ gfc_clear_shape (*shape, rank);
+ free (*shape);
+ *shape = NULL;
+}
+
+
/* Workhorse function for gfc_free_expr() that frees everything
beneath an expression node, but not the node itself. This is
useful when we want to simplify a node and replace it with
static void
free_expr0 (gfc_expr *e)
{
- int n;
-
switch (e->expr_type)
{
case EXPR_CONSTANT:
}
/* Free a shape array. */
- if (e->shape != NULL)
- {
- for (n = 0; n < e->rank; n++)
- mpz_clear (e->shape[n]);
-
- free (e->shape);
- }
+ gfc_free_shape (&e->shape, e->rank);
gfc_free_ref_list (e->ref);
/* 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
+ tempting to generate an error and return true or false, but
failure is OK for some callers. */
const char *
/* Copy a shape array excluding dimension N, where N is an integer
- constant expression. Dimensions are numbered in fortran style --
+ constant expression. Dimensions are numbered in Fortran style --
starting with ONE.
So, if the original shape array contains R elements
mpz_t *new_shape, *s;
int i, n;
- if (shape == NULL
+ if (shape == NULL
|| rank <= 1
|| dim == NULL
- || dim->expr_type != EXPR_CONSTANT
+ || dim->expr_type != EXPR_CONSTANT
|| dim->ts.type != BT_INTEGER)
return NULL;
&& sym->attr.proc != PROC_INTERNAL
&& sym->attr.proc != PROC_ST_FUNCTION
&& sym->attr.proc != PROC_UNKNOWN
- && sym->formal == NULL)
+ && gfc_sym_get_dummy_args (sym) == NULL)
return 1;
if (e->value.function.isym
/* Try to collapse intrinsic expressions. */
-static gfc_try
+static bool
simplify_intrinsic_op (gfc_expr *p, int type)
{
gfc_intrinsic_op op;
gfc_expr *op1, *op2, *result;
if (p->value.op.op == INTRINSIC_USER)
- return SUCCESS;
+ return true;
op1 = p->value.op.op1;
op2 = p->value.op.op2;
op = p->value.op.op;
- if (gfc_simplify_expr (op1, type) == FAILURE)
- return FAILURE;
- if (gfc_simplify_expr (op2, type) == FAILURE)
- return FAILURE;
+ if (!gfc_simplify_expr (op1, type))
+ return false;
+ if (!gfc_simplify_expr (op2, type))
+ return false;
if (!gfc_is_constant_expr (op1)
|| (op2 != NULL && !gfc_is_constant_expr (op2)))
- return SUCCESS;
+ return true;
/* Rip p apart. */
p->value.op.op1 = NULL;
{
gfc_free_expr (op1);
gfc_free_expr (op2);
- return FAILURE;
+ return false;
}
result->rank = p->rank;
result->where = p->where;
gfc_replace_expr (p, result);
- return SUCCESS;
+ return true;
}
/* Subroutine to simplify constructor expressions. Mutually recursive
with gfc_simplify_expr(). */
-static gfc_try
+static bool
simplify_constructor (gfc_constructor_base base, int type)
{
gfc_constructor *c;
for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
if (c->iterator
- && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
- || gfc_simplify_expr (c->iterator->end, type) == FAILURE
- || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
- return FAILURE;
+ && (!gfc_simplify_expr(c->iterator->start, type)
+ || !gfc_simplify_expr (c->iterator->end, type)
+ || !gfc_simplify_expr (c->iterator->step, type)))
+ return false;
if (c->expr)
{
doing so can make a dog's dinner of complicated things. */
p = gfc_copy_expr (c->expr);
- if (gfc_simplify_expr (p, type) == FAILURE)
+ if (!gfc_simplify_expr (p, type))
{
gfc_free_expr (p);
continue;
}
}
- return SUCCESS;
+ return true;
}
/* Pull a single array element out of an array constructor. */
-static gfc_try
+static bool
find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
gfc_constructor **rval)
{
mpz_t tmp;
gfc_constructor *cons;
gfc_expr *e;
- gfc_try t;
+ bool t;
- t = SUCCESS;
+ t = true;
e = NULL;
mpz_init_set_ui (offset, 0);
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)
+ if (!gfc_reduce_init_expr (ar->as->lower[i])
+ || !gfc_reduce_init_expr (ar->as->upper[i]))
{
- t = FAILURE;
+ t = false;
cons = NULL;
goto depart;
}
- e = gfc_copy_expr (ar->start[i]);
+ e = ar->start[i];
if (e->expr_type != EXPR_CONSTANT)
{
cons = NULL;
gfc_error ("Index in dimension %d is out of bounds "
"at %L", i + 1, &ar->c_where[i]);
cons = NULL;
- t = FAILURE;
+ t = false;
goto depart;
}
mpz_clear (offset);
mpz_clear (span);
mpz_clear (tmp);
- if (e)
- gfc_free_expr (e);
*rval = cons;
return t;
}
/* Pull an array section out of an array constructor. */
-static gfc_try
+static bool
find_array_section (gfc_expr *expr, gfc_ref *ref)
{
int idx;
gfc_expr *step;
gfc_expr *upper;
gfc_expr *lower;
- gfc_try t;
+ bool t;
- t = SUCCESS;
+ t = true;
base = expr->value.constructor;
expr->value.constructor = NULL;
if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
{
- t = FAILURE;
+ t = false;
goto cleanup;
}
gcc_assert (begin->rank == 1);
/* Zero-sized arrays have no shape and no elements, stop early. */
- if (!begin->shape)
+ if (!begin->shape)
{
mpz_init_set_ui (nelts, 0);
break;
{
gfc_error ("index in dimension %d is out of bounds "
"at %L", d + 1, &ref->u.ar.c_where[d]);
- t = FAILURE;
+ t = false;
goto cleanup;
}
}
|| (finish && finish->expr_type != EXPR_CONSTANT)
|| (step && step->expr_type != EXPR_CONSTANT))
{
- t = FAILURE;
+ t = false;
goto cleanup;
}
{
gfc_error ("index in dimension %d is out of bounds "
"at %L", d + 1, &ref->u.ar.c_where[d]);
- t = FAILURE;
+ t = false;
goto cleanup;
}
/* 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)
+ if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
mpz_set (expr->shape[shape_i++], tmp_mpz);
}
/* Now clock through the array reference, calculating the index in
the source constructor and transferring the elements to the new
- constructor. */
+ 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);
+ mpz_init_set_ui (ptr, 0);
incr_ctr = true;
for (d = 0; d < rank; d++)
}
else
{
- mpz_add (ctr[d], ctr[d], stride[d]);
+ mpz_add (ctr[d], ctr[d], stride[d]);
if (mpz_cmp_ui (stride[d], 0) > 0
? mpz_cmp (ctr[d], end[d]) > 0
"upper limit. See -fmax-array-constructor "
"option", &expr->where,
gfc_option.flag_max_array_constructor);
- return FAILURE;
+ return false;
}
cons = gfc_constructor_lookup (base, limit);
/* Pull a substring out of an expression. */
-static gfc_try
+static bool
find_substring_ref (gfc_expr *p, gfc_expr **newp)
{
int end;
if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
|| p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
- return FAILURE;
+ return false;
*newp = gfc_copy_expr (p);
free ((*newp)->value.character.string);
memcpy (chr, &p->value.character.string[start - 1],
length * sizeof (gfc_char_t));
chr[length] = '\0';
- return SUCCESS;
+ return true;
}
/* Simplify a subobject reference of a constructor. This occurs when
parameter variable values are substituted. */
-static gfc_try
+static bool
simplify_const_ref (gfc_expr *p)
{
gfc_constructor *cons, *c;
remove_subobject_ref (p, NULL);
break;
}
- if (find_array_element (p->value.constructor, &p->ref->u.ar,
- &cons) == FAILURE)
- return FAILURE;
+ if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons))
+ return false;
if (!cons)
- return SUCCESS;
+ return true;
remove_subobject_ref (p, cons);
break;
case AR_SECTION:
- if (find_array_section (p, p->ref) == FAILURE)
- return FAILURE;
+ if (!find_array_section (p, p->ref))
+ return false;
p->ref->u.ar.type = AR_FULL;
/* Fall through. */
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 (!simplify_const_ref (c->expr))
+ return false;
}
if (p->ts.type == BT_DERIVED
break;
default:
- return SUCCESS;
+ return true;
}
break;
break;
case REF_SUBSTRING:
- if (find_substring_ref (p, &newp) == FAILURE)
- return FAILURE;
+ if (!find_substring_ref (p, &newp))
+ return false;
gfc_replace_expr (p, newp);
gfc_free_ref_list (p->ref);
}
}
- return SUCCESS;
+ return true;
}
/* Simplify a chain of references. */
-static gfc_try
+static bool
simplify_ref_chain (gfc_ref *ref, int type)
{
int n;
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;
+ if (!gfc_simplify_expr (ref->u.ar.start[n], type))
+ return false;
+ if (!gfc_simplify_expr (ref->u.ar.end[n], type))
+ return false;
+ if (!gfc_simplify_expr (ref->u.ar.stride[n], type))
+ return false;
}
break;
case REF_SUBSTRING:
- if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
- return FAILURE;
- if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
- return FAILURE;
+ if (!gfc_simplify_expr (ref->u.ss.start, type))
+ return false;
+ if (!gfc_simplify_expr (ref->u.ss.end, type))
+ return false;
break;
default:
break;
}
}
- return SUCCESS;
+ return true;
}
/* Try to substitute the value of a parameter variable. */
-static gfc_try
+static bool
simplify_parameter_variable (gfc_expr *p, int type)
{
gfc_expr *e;
- gfc_try t;
+ bool t;
e = gfc_copy_expr (p->symtree->n.sym->value);
if (e == NULL)
- return FAILURE;
+ return false;
e->rank = p->rank;
t = gfc_simplify_expr (e, type);
/* Only use the simplification if it eliminated all subobject references. */
- if (t == SUCCESS && !e->ref)
+ if (t && !e->ref)
gfc_replace_expr (p, e);
else
gfc_free_expr (e);
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. */
+ Returns false on error, true otherwise.
+ NOTE: Will return true even if the expression can not be simplified. */
-gfc_try
+bool
gfc_simplify_expr (gfc_expr *p, int type)
{
gfc_actual_arglist *ap;
if (p == NULL)
- return SUCCESS;
+ return true;
switch (p->expr_type)
{
case EXPR_FUNCTION:
for (ap = p->value.function.actual; ap; ap = ap->next)
- if (gfc_simplify_expr (ap->expr, type) == FAILURE)
- return FAILURE;
+ if (!gfc_simplify_expr (ap->expr, type))
+ return false;
if (p->value.function.isym != NULL
&& gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
- return FAILURE;
+ return false;
break;
case EXPR_SUBSTRING:
- if (simplify_ref_chain (p->ref, type) == FAILURE)
- return FAILURE;
+ if (!simplify_ref_chain (p->ref, type))
+ return false;
if (gfc_is_constant_expr (p))
{
if (p->ref && p->ref->u.ss.end)
gfc_extract_int (p->ref->u.ss.end, &end);
- if (end < 0)
- end = 0;
+ if (end < start)
+ end = start;
s = gfc_get_wide_string (end - start + 2);
memcpy (s, p->value.character.string + start,
break;
case EXPR_OP:
- if (simplify_intrinsic_op (p, type) == FAILURE)
- return FAILURE;
+ if (!simplify_intrinsic_op (p, type))
+ return false;
break;
case EXPR_VARIABLE:
&& (gfc_init_expr_flag || p->ref
|| p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
{
- if (simplify_parameter_variable (p, type) == FAILURE)
- return FAILURE;
+ if (!simplify_parameter_variable (p, type))
+ return false;
break;
}
}
/* Simplify subcomponent references. */
- if (simplify_ref_chain (p->ref, type) == FAILURE)
- return FAILURE;
+ if (!simplify_ref_chain (p->ref, type))
+ return false;
break;
case EXPR_STRUCTURE:
case EXPR_ARRAY:
- if (simplify_ref_chain (p->ref, type) == FAILURE)
- return FAILURE;
+ if (!simplify_ref_chain (p->ref, type))
+ return false;
- if (simplify_constructor (p->value.constructor, type) == FAILURE)
- return FAILURE;
+ if (!simplify_constructor (p->value.constructor, type))
+ return false;
if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
&& p->ref->u.ar.type == AR_FULL)
gfc_expand_constructor (p, false);
- if (simplify_const_ref (p) == FAILURE)
- return FAILURE;
+ if (!simplify_const_ref (p))
+ return false;
break;
case EXPR_COMPCALL:
case EXPR_PPC:
- gcc_unreachable ();
break;
}
- return SUCCESS;
+ return true;
}
static bt
et0 (gfc_expr *e)
{
- if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
+ if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e))
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
+static bool
scalarize_intrinsic_call (gfc_expr *e)
{
gfc_actual_arglist *a, *b;
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.*/
for (; a; a = a->next)
{
n++;
- if (a->expr->expr_type != EXPR_ARRAY)
+ if (!a->expr || a->expr->expr_type != EXPR_ARRAY)
continue;
array_arg = n;
expr = gfc_copy_expr (a->expr);
}
if (!array_arg)
- return FAILURE;
+ return false;
old = gfc_copy_expr (e);
for (; a; a = a->next)
{
/* Check that this is OK for an initialization expression. */
- if (a->expr && check_init_expr (a->expr) == FAILURE)
+ if (a->expr && !gfc_check_init_expr (a->expr))
goto cleanup;
rank[n] = 0;
free_expr0 (e);
*e = *expr;
+ /* Free "expr" but not the pointers it contains. */
+ free (expr);
gfc_free_expr (old);
- return SUCCESS;
+ return true;
compliance:
gfc_error_now ("elemental function arguments at %C are not compliant");
cleanup:
gfc_free_expr (expr);
gfc_free_expr (old);
- return FAILURE;
+ return false;
}
-static gfc_try
-check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
+static bool
+check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *))
{
gfc_expr *op1 = e->value.op.op1;
gfc_expr *op2 = e->value.op.op2;
- if ((*check_function) (op1) == FAILURE)
- return FAILURE;
+ if (!(*check_function)(op1))
+ return false;
switch (e->value.op.op)
{
case INTRINSIC_LT_OS:
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
- if ((*check_function) (op2) == FAILURE)
- return FAILURE;
-
+ if (!(*check_function)(op2))
+ return false;
+
if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
&& !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
{
gfc_error ("Numeric or CHARACTER operands are required in "
"expression at %L", &e->where);
- return FAILURE;
+ return false;
}
break;
case INTRINSIC_TIMES:
case INTRINSIC_DIVIDE:
case INTRINSIC_POWER:
- if ((*check_function) (op2) == FAILURE)
- return FAILURE;
+ if (!(*check_function)(op2))
+ return false;
if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
goto not_numeric;
break;
case INTRINSIC_CONCAT:
- if ((*check_function) (op2) == FAILURE)
- return FAILURE;
+ if (!(*check_function)(op2))
+ return false;
if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
{
gfc_error ("Concatenation operator in expression at %L "
"must have two CHARACTER operands", &op1->where);
- return FAILURE;
+ return false;
}
if (op1->ts.kind != op2->ts.kind)
{
gfc_error ("Concat operator at %L must concatenate strings of the "
"same kind", &e->where);
- return FAILURE;
+ return false;
}
break;
{
gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
"operand", &op1->where);
- return FAILURE;
+ return false;
}
break;
case INTRINSIC_OR:
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
- if ((*check_function) (op2) == FAILURE)
- return FAILURE;
+ if (!(*check_function)(op2))
+ return false;
if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
{
gfc_error ("LOGICAL operands are required in expression at %L",
&e->where);
- return FAILURE;
+ return false;
}
break;
default:
gfc_error ("Only intrinsic operators can be used in expression at %L",
&e->where);
- return FAILURE;
+ return false;
}
- return SUCCESS;
+ return true;
not_numeric:
gfc_error ("Numeric operands are required in expression at %L", &e->where);
- return FAILURE;
+ return false;
}
/* F2003, 7.1.7 (3): In init expression, allocatable components
must not be data-initialized. */
-static gfc_try
+static bool
check_alloc_comp_init (gfc_expr *e)
{
gfc_component *comp;
gfc_error("Invalid initialization expression for ALLOCATABLE "
"component '%s' in structure constructor at %L",
comp->name, &ctor->expr->where);
- return FAILURE;
+ return false;
}
}
- return SUCCESS;
+ return true;
}
static match
gfc_actual_arglist *ap;
for (ap = e->value.function.actual; ap; ap = ap->next)
- if (check_init_expr (ap->expr) == FAILURE)
+ if (!gfc_check_init_expr (ap->expr))
return MATCH_ERROR;
return MATCH_YES;
}
-static gfc_try check_restricted (gfc_expr *);
+static bool check_restricted (gfc_expr *);
/* F95, 7.1.6.1, Initialization expressions, (7)
F2003, 7.1.7 Initialization expression, (8) */
"new_line", NULL
};
- int i;
+ int i = 0;
gfc_actual_arglist *ap;
if (!e->value.function.isym
if (e->symtree == NULL)
return MATCH_NO;
- name = e->symtree->n.sym->name;
+ if (e->symtree->n.sym->from_intmod)
+ {
+ if (e->symtree->n.sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
+ && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
+ return MATCH_NO;
+
+ if (e->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING
+ && e->symtree->n.sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
+ return MATCH_NO;
+ }
+ else
+ {
+ name = e->symtree->n.sym->name;
- functions = (gfc_option.warn_std & GFC_STD_F2003)
+ 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;
+ for (i = 0; functions[i]; i++)
+ if (strcmp (functions[i], name) == 0)
+ break;
- if (functions[i] == NULL)
- return MATCH_ERROR;
+ 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
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)
+ && !gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns))
return MATCH_NO;
ap->expr->ts = ap->expr->symtree->n.sym->ts;
&ap->expr->where);
return MATCH_ERROR;
}
- else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
+ else if (not_restricted && !gfc_check_init_expr (ap->expr))
return MATCH_ERROR;
if (not_restricted == 0
&& ap->expr->expr_type != EXPR_VARIABLE
- && check_restricted (ap->expr) == FAILURE)
+ && !check_restricted (ap->expr))
return MATCH_ERROR;
if (not_restricted == 0
name = e->symtree->n.sym->name;
- functions = (gfc_option.allow_std & GFC_STD_F2003)
+ functions = (gfc_option.allow_std & GFC_STD_F2003)
? trans_func_f2003 : trans_func_f95;
/* NULL() is dealt with below. */
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)
+ && !gfc_notify_std (GFC_STD_F2003, "Evaluation of nonstandard "
+ "initialization expression at %L", &e->where))
return MATCH_ERROR;
return check_init_expr_arguments (e);
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. */
+ false is returned an error message has been generated. */
-static gfc_try
-check_init_expr (gfc_expr *e)
+bool
+gfc_check_init_expr (gfc_expr *e)
{
match m;
- gfc_try t;
+ bool t;
if (e == NULL)
- return SUCCESS;
+ return true;
switch (e->expr_type)
{
case EXPR_OP:
- t = check_intrinsic_op (e, check_init_expr);
- if (t == SUCCESS)
+ t = check_intrinsic_op (e, gfc_check_init_expr);
+ if (t)
t = gfc_simplify_expr (e, 0);
break;
case EXPR_FUNCTION:
- t = FAILURE;
+ t = false;
{
gfc_intrinsic_sym* isym;
- gfc_symbol* sym;
+ gfc_symbol* sym = e->symtree->n.sym;
+
+ /* Special case for IEEE_SELECTED_REAL_KIND from the intrinsic
+ module IEEE_ARITHMETIC, which is allowed in initialization
+ expressions. */
+ if (!strcmp(sym->name, "ieee_selected_real_kind")
+ && sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
+ {
+ gfc_expr *new_expr = gfc_simplify_ieee_selected_real_kind (e);
+ if (new_expr)
+ {
+ gfc_replace_expr (e, new_expr);
+ t = true;
+ break;
+ }
+ }
- sym = e->symtree->n.sym;
if (!gfc_is_intrinsic (sym, 0, e->where)
|| (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
{
m = MATCH_ERROR;
}
+ if (m == MATCH_ERROR)
+ return false;
+
/* Try to scalarize an elemental intrinsic function that has an
array argument. */
isym = gfc_find_function (e->symtree->n.sym->name);
if (isym && isym->elemental
- && (t = scalarize_intrinsic_call (e)) == SUCCESS)
+ && (t = scalarize_intrinsic_call(e)))
break;
}
break;
case EXPR_VARIABLE:
- t = SUCCESS;
+ t = true;
- if (gfc_check_iter_variable (e) == SUCCESS)
+ if (gfc_check_iter_variable (e))
break;
if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
{
gfc_error("PARAMETER '%s' is used at %L before its definition "
"is complete", e->symtree->n.sym->name, &e->where);
- t = FAILURE;
+ t = false;
}
else
t = simplify_parameter_variable (e, 0);
if (gfc_in_match_data ())
break;
- t = FAILURE;
+ t = false;
if (e->symtree->n.sym->as)
{
case EXPR_CONSTANT:
case EXPR_NULL:
- t = SUCCESS;
+ t = true;
break;
case EXPR_SUBSTRING:
- t = check_init_expr (e->ref->u.ss.start);
- if (t == FAILURE)
+ t = gfc_check_init_expr (e->ref->u.ss.start);
+ if (!t)
break;
- t = check_init_expr (e->ref->u.ss.end);
- if (t == SUCCESS)
+ t = gfc_check_init_expr (e->ref->u.ss.end);
+ if (t)
t = gfc_simplify_expr (e, 0);
break;
case EXPR_STRUCTURE:
- t = e->ts.is_iso_c ? SUCCESS : FAILURE;
- if (t == SUCCESS)
+ t = e->ts.is_iso_c ? true : false;
+ if (t)
break;
t = check_alloc_comp_init (e);
- if (t == FAILURE)
+ if (!t)
break;
- t = gfc_check_constructor (e, check_init_expr);
- if (t == FAILURE)
+ t = gfc_check_constructor (e, gfc_check_init_expr);
+ if (!t)
break;
break;
case EXPR_ARRAY:
- t = gfc_check_constructor (e, check_init_expr);
- if (t == FAILURE)
+ t = gfc_check_constructor (e, gfc_check_init_expr);
+ if (!t)
break;
t = gfc_expand_constructor (e, true);
- if (t == FAILURE)
+ if (!t)
break;
t = gfc_check_constructor_type (e);
/* 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. */
+ Note that this function doesn't free the given expression on false. */
-gfc_try
+bool
gfc_reduce_init_expr (gfc_expr *expr)
{
- gfc_try t;
+ bool t;
gfc_init_expr_flag = true;
t = gfc_resolve_expr (expr);
- if (t == SUCCESS)
- t = check_init_expr (expr);
+ if (t)
+ t = gfc_check_init_expr (expr);
gfc_init_expr_flag = false;
- if (t == FAILURE)
- return FAILURE;
+ if (!t)
+ return false;
if (expr->expr_type == EXPR_ARRAY)
{
- if (gfc_check_constructor_type (expr) == FAILURE)
- return FAILURE;
- if (gfc_expand_constructor (expr, true) == FAILURE)
- return FAILURE;
+ if (!gfc_check_constructor_type (expr))
+ return false;
+ if (!gfc_expand_constructor (expr, true))
+ return false;
}
- return SUCCESS;
+ return true;
}
{
gfc_expr *expr;
match m;
- gfc_try t;
+ bool t;
expr = NULL;
}
t = gfc_reduce_init_expr (expr);
- if (t != SUCCESS)
+ if (!t)
{
gfc_free_expr (expr);
gfc_init_expr_flag = false;
restricted expression and optionally if the expression type is
integer or character. */
-static gfc_try
+static bool
restricted_args (gfc_actual_arglist *a)
{
for (; a; a = a->next)
{
- if (check_restricted (a->expr) == FAILURE)
- return FAILURE;
+ if (!check_restricted (a->expr))
+ return false;
}
- return SUCCESS;
+ return true;
}
/* Make sure a non-intrinsic function is a specification function. */
-static gfc_try
+static bool
external_spec_function (gfc_expr *e)
{
gfc_symbol *f;
{
gfc_error ("Specification function '%s' at %L cannot be a statement "
"function", f->name, &e->where);
- return FAILURE;
+ return false;
}
if (f->attr.proc == PROC_INTERNAL)
{
gfc_error ("Specification function '%s' at %L cannot be an internal "
"function", f->name, &e->where);
- return FAILURE;
+ return false;
}
if (!f->attr.pure && !f->attr.elemental)
{
gfc_error ("Specification function '%s' at %L must be PURE", f->name,
&e->where);
- return FAILURE;
+ return false;
}
if (f->attr.recursive)
{
gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
f->name, &e->where);
- return FAILURE;
+ return false;
}
return restricted_args (e->value.function.actual);
/* Check to see that a function reference to an intrinsic is a
restricted expression. */
-static gfc_try
+static bool
restricted_intrinsic (gfc_expr *e)
{
/* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
if (check_inquiry (e, 0) == MATCH_YES)
- return SUCCESS;
+ return true;
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*))
+static bool
+check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*))
{
for (; arg; arg = arg->next)
- if (checker (arg->expr) == FAILURE)
- return FAILURE;
+ if (!checker (arg->expr))
+ return false;
- return SUCCESS;
+ return true;
}
/* 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*))
+static bool
+check_references (gfc_ref* ref, bool (*checker) (gfc_expr*))
{
int dim;
if (!ref)
- return SUCCESS;
+ return true;
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;
+ if (!checker (ref->u.ar.start[dim]))
+ return false;
+ if (!checker (ref->u.ar.end[dim]))
+ return false;
+ if (!checker (ref->u.ar.stride[dim]))
+ return false;
}
break;
break;
case REF_SUBSTRING:
- if (checker (ref->u.ss.start) == FAILURE)
- return FAILURE;
- if (checker (ref->u.ss.end) == FAILURE)
- return FAILURE;
+ if (!checker (ref->u.ss.start))
+ return false;
+ if (!checker (ref->u.ss.end))
+ return false;
break;
default:
/* Verify that an expression is a restricted expression. Like its
cousin check_init_expr(), an error message is generated if we
- return FAILURE. */
+ return false. */
-static gfc_try
+static bool
check_restricted (gfc_expr *e)
{
gfc_symbol* sym;
- gfc_try t;
+ bool t;
if (e == NULL)
- return SUCCESS;
+ return true;
switch (e->expr_type)
{
case EXPR_OP:
t = check_intrinsic_op (e, check_restricted);
- if (t == SUCCESS)
+ if (t)
t = gfc_simplify_expr (e, 0);
break;
if (e->value.function.esym)
{
t = check_arglist (e->value.function.actual, &check_restricted);
- if (t == SUCCESS)
+ if (t)
t = external_spec_function (e);
}
else
{
if (e->value.function.isym && e->value.function.isym->inquiry)
- t = SUCCESS;
+ t = true;
else
t = check_arglist (e->value.function.actual, &check_restricted);
- if (t == SUCCESS)
+ if (t)
t = restricted_intrinsic (e);
}
break;
case EXPR_VARIABLE:
sym = e->symtree->n.sym;
- t = FAILURE;
+ t = false;
/* If a dummy argument appears in a context that is valid for a
restricted expression in an elemental procedure, it will have
}
/* Check reference chain if any. */
- if (check_references (e->ref, &check_restricted) == FAILURE)
+ if (!check_references (e->ref, &check_restricted))
break;
/* gfc_is_formal_arg broadcasts that a formal argument list is being
&& sym->ns->proc_name->attr.flavor == FL_MODULE)
|| (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
{
- t = SUCCESS;
+ t = true;
break;
}
case EXPR_NULL:
case EXPR_CONSTANT:
- t = SUCCESS;
+ t = true;
break;
case EXPR_SUBSTRING:
t = gfc_specification_expr (e->ref->u.ss.start);
- if (t == FAILURE)
+ if (!t)
break;
t = gfc_specification_expr (e->ref->u.ss.end);
- if (t == SUCCESS)
+ if (t)
t = gfc_simplify_expr (e, 0);
break;
/* Check to see that an expression is a specification expression. If
- we return FAILURE, an error has been generated. */
+ we return false, an error has been generated. */
-gfc_try
+bool
gfc_specification_expr (gfc_expr *e)
{
gfc_component *comp;
if (e == NULL)
- return SUCCESS;
+ return true;
if (e->ts.type != BT_INTEGER)
{
gfc_error ("Expression at %L must be of INTEGER type, found %s",
&e->where, gfc_basic_typename (e->ts.type));
- return FAILURE;
+ return false;
}
+ comp = gfc_get_proc_ptr_comp (e);
if (e->expr_type == EXPR_FUNCTION
- && !e->value.function.isym
- && !e->value.function.esym
- && !gfc_pure (e->symtree->n.sym)
- && (!gfc_is_proc_ptr_comp (e, &comp)
- || !comp->attr.pure))
+ && !e->value.function.isym
+ && !e->value.function.esym
+ && !gfc_pure (e->symtree->n.sym)
+ && (!comp || !comp->attr.pure))
{
gfc_error ("Function '%s' at %L must be PURE",
e->symtree->n.sym->name, &e->where);
/* Prevent repeat error messages. */
e->symtree->n.sym->attr.pure = 1;
- return FAILURE;
+ return false;
}
if (e->rank != 0)
{
gfc_error ("Expression at %L must be scalar", &e->where);
- return FAILURE;
+ return false;
}
- if (gfc_simplify_expr (e, 0) == FAILURE)
- return FAILURE;
+ if (!gfc_simplify_expr (e, 0))
+ return false;
return check_restricted (e);
}
/* Given two expressions, make sure that the arrays are conformable. */
-gfc_try
+bool
gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
{
int op1_flag, op2_flag, d;
mpz_t op1_size, op2_size;
- gfc_try t;
+ bool t;
va_list argp;
char buffer[240];
if (op1->rank == 0 || op2->rank == 0)
- return SUCCESS;
+ return true;
va_start (argp, optype_msgid);
vsnprintf (buffer, 240, optype_msgid, argp);
{
gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
op1->rank, op2->rank, &op1->where);
- return FAILURE;
+ return false;
}
- t = SUCCESS;
+ t = true;
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;
+ op1_flag = gfc_array_dimen_size(op1, d, &op1_size);
+ op2_flag = gfc_array_dimen_size(op2, d, &op2_size);
if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
{
(int) mpz_get_si (op1_size),
(int) mpz_get_si (op2_size));
- t = FAILURE;
+ t = false;
}
if (op1_flag)
if (op2_flag)
mpz_clear (op2_size);
- if (t == FAILURE)
- return FAILURE;
+ if (!t)
+ return false;
}
- return SUCCESS;
+ return true;
}
/* Given an assignable expression and an arbitrary expression, make
sure that the assignment can take place. */
-gfc_try
+bool
gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
{
gfc_symbol *sym;
|| gfc_current_ns->parent->proc_name->attr.subroutine)
|| gfc_current_ns->parent->proc_name->attr.is_main_program))
{
- /* ... that is not a function... */
+ /* ... that is not a function... */
if (!gfc_current_ns->proc_name->attr.function)
bad_proc = true;
if (bad_proc)
{
gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
- return FAILURE;
+ return false;
}
}
{
gfc_error ("Incompatible ranks %d and %d in assignment at %L",
lvalue->rank, rvalue->rank, &lvalue->where);
- return FAILURE;
+ return false;
}
if (lvalue->ts.type == BT_UNKNOWN)
{
gfc_error ("Variable type is UNKNOWN in assignment at %L",
&lvalue->where);
- return FAILURE;
+ return false;
}
if (rvalue->expr_type == EXPR_NULL)
- {
+ {
if (has_pointer && (ref == NULL || ref->next == NULL)
&& lvalue->symtree->n.sym->attr.data)
- return SUCCESS;
+ return true;
else
{
gfc_error ("NULL appears on right-hand side in assignment at %L",
&rvalue->where);
- return FAILURE;
+ return false;
}
}
/* 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 "
+ if (warn_surprising
+ && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer)
+ gfc_warning ("POINTER-valued function appears on right-hand side of "
"assignment at %L", &rvalue->where);
/* Check size of array assignments. */
if (lvalue->rank != 0 && rvalue->rank != 0
- && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
- return FAILURE;
+ && !gfc_check_conformance (lvalue, rvalue, "array assignment"))
+ return false;
if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
&& lvalue->symtree->n.sym->attr.data
- && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
- "initialize non-integer variable '%s'",
- &rvalue->where, lvalue->symtree->n.sym->name)
- == FAILURE)
- return FAILURE;
+ && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to "
+ "initialize non-integer variable '%s'",
+ &rvalue->where, lvalue->symtree->n.sym->name))
+ return false;
else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
- && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
- "a DATA statement and outside INT/REAL/DBLE/CMPLX",
- &rvalue->where) == FAILURE)
- return FAILURE;
+ && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
+ "a DATA statement and outside INT/REAL/DBLE/CMPLX",
+ &rvalue->where))
+ return false;
/* Handle the case of a BOZ literal on the RHS. */
if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
{
int rc;
- if (gfc_option.warn_surprising)
+ if (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;
+ return false;
if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
{
if (rc == ARITH_UNDERFLOW)
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;
+ return false;
}
}
if (rvalue->expr_type == EXPR_CONSTANT && lvalue->ts.type == rvalue->ts.type
&& (lvalue->ts.type == BT_REAL || lvalue->ts.type == BT_COMPLEX))
{
- if (lvalue->ts.kind < rvalue->ts.kind && gfc_option.gfc_warn_conversion)
+ if (lvalue->ts.kind < rvalue->ts.kind && warn_conversion)
{
/* As a special bonus, don't warn about REAL rvalues which are not
changed by the conversion if -Wconversion is specified. */
mpfr_init (rv);
gfc_set_model_kind (rvalue->ts.kind);
mpfr_init (diff);
-
+
mpfr_set (rv, rvalue->value.real, GFC_RND_MODE);
mpfr_sub (diff, rv, rvalue->value.real, GFC_RND_MODE);
-
+
if (!mpfr_zero_p (diff))
gfc_warning ("Change of value in conversion from "
" %s to %s at %L", gfc_typename (&rvalue->ts),
gfc_typename (&lvalue->ts), &rvalue->where);
-
+
mpfr_clear (rv);
mpfr_clear (diff);
}
gfc_typename (&lvalue->ts), &rvalue->where);
}
- else if (gfc_option.warn_conversion_extra
- && lvalue->ts.kind > rvalue->ts.kind)
+ else if (warn_conversion_extra && lvalue->ts.kind > rvalue->ts.kind)
{
gfc_warning ("Conversion from %s to %s at %L",
gfc_typename (&rvalue->ts),
}
if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
- return SUCCESS;
+ return true;
/* Only DATA Statements come here. */
if (!conform)
converted to any other type. */
if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
|| rvalue->ts.type == BT_HOLLERITH)
- return SUCCESS;
+ return true;
if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
- return SUCCESS;
+ return true;
gfc_error ("Incompatible types in DATA statement at %L; attempted "
"conversion of %s to %s", &lvalue->where,
gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
- return FAILURE;
+ return false;
}
/* Assignment is the only case where character variables of different
if (lvalue->ts.kind != rvalue->ts.kind)
gfc_convert_chartype (rvalue, &lvalue->ts);
- return SUCCESS;
+ return true;
}
return gfc_convert_type (rvalue, &lvalue->ts, 1);
we only check rvalue if it's not an assignment to NULL() or a
NULLIFY statement. */
-gfc_try
+bool
gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
{
- symbol_attribute attr;
+ symbol_attribute attr, lhs_attr;
gfc_ref *ref;
bool is_pure, is_implicit_pure, rank_remap;
int proc_pointer;
- if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
- && !lvalue->symtree->n.sym->attr.proc_pointer)
+ lhs_attr = gfc_expr_attr (lvalue);
+ if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer)
{
gfc_error ("Pointer assignment target is not a POINTER at %L",
&lvalue->where);
- return FAILURE;
+ return false;
}
- if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
- && lvalue->symtree->n.sym->attr.use_assoc
- && !lvalue->symtree->n.sym->attr.proc_pointer)
+ if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc
+ && !lhs_attr.proc_pointer)
{
gfc_error ("'%s' in the pointer assignment at %L cannot be an "
"l-value since it is a procedure",
lvalue->symtree->n.sym->name, &lvalue->where);
- return FAILURE;
+ return false;
}
proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
{
gfc_error ("Expected bounds specification for '%s' at %L",
lvalue->symtree->n.sym->name, &lvalue->where);
- return FAILURE;
+ return false;
}
- 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;
+ if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification "
+ "for '%s' in pointer assignment at %L",
+ lvalue->symtree->n.sym->name, &lvalue->where))
+ return false;
/* When bounds are given, all lbounds are necessary and either all
or none of the upper bounds; no strides are allowed. If the
{
gfc_error ("Lower bound has to be present at %L",
&lvalue->where);
- return FAILURE;
+ return false;
}
if (ref->u.ar.stride[dim])
{
gfc_error ("Stride must not be present at %L",
&lvalue->where);
- return FAILURE;
+ return false;
}
if (dim == 0)
{
gfc_error ("Either all or none of the upper bounds"
" must be specified at %L", &lvalue->where);
- return FAILURE;
+ return false;
}
}
}
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;
+ return true;
/* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
if (lvalue->expr_type == EXPR_VARIABLE
{
gfc_error ("Pointer object at %L shall not have a coindex",
&lvalue->where);
- return FAILURE;
+ return false;
}
}
{
gfc_error ("Invalid procedure pointer assignment at %L",
&rvalue->where);
- return FAILURE;
+ return false;
+ }
+ if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer)
+ {
+ /* Check for intrinsics. */
+ gfc_symbol *sym = rvalue->symtree->n.sym;
+ if (!sym->attr.intrinsic
+ && (gfc_is_intrinsic (sym, 0, sym->declared_at)
+ || gfc_is_intrinsic (sym, 1, sym->declared_at)))
+ {
+ sym->attr.intrinsic = 1;
+ gfc_resolve_intrinsic (sym, &rvalue->where);
+ attr = gfc_expr_attr (rvalue);
+ }
+ /* Check for result of embracing function. */
+ if (sym->attr.function && sym->result == sym)
+ {
+ gfc_namespace *ns;
+
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ if (sym == ns->proc_name)
+ {
+ gfc_error ("Function result '%s' is invalid as proc-target "
+ "in procedure pointer assignment at %L",
+ sym->name, &rvalue->where);
+ return false;
+ }
+ }
}
if (attr.abstract)
{
gfc_error ("Abstract interface '%s' is invalid "
"in procedure pointer assignment at %L",
rvalue->symtree->name, &rvalue->where);
- return FAILURE;
+ return false;
}
- /* Check for C727. */
+ /* Check for F08:C729. */
if (attr.flavor == FL_PROCEDURE)
{
if (attr.proc == PROC_ST_FUNCTION)
gfc_error ("Statement function '%s' is invalid "
"in procedure pointer assignment at %L",
rvalue->symtree->name, &rvalue->where);
- return FAILURE;
+ return false;
}
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;
+ !gfc_notify_std(GFC_STD_F2008, "Internal procedure '%s' "
+ "is invalid in procedure pointer assignment "
+ "at %L", rvalue->symtree->name, &rvalue->where))
+ return false;
+ if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name,
+ attr.subroutine) == 0)
+ {
+ gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer "
+ "assignment", rvalue->symtree->name, &rvalue->where);
+ return false;
+ }
+ }
+ /* Check for F08:C730. */
+ if (attr.elemental && !attr.intrinsic)
+ {
+ gfc_error ("Nonintrinsic elemental procedure '%s' is invalid "
+ "in procedure pointer assignment at %L",
+ rvalue->symtree->name, &rvalue->where);
+ return false;
}
/* Ensure that the calling convention is the same. As other attributes
gfc_error ("Mismatch in the procedure pointer assignment "
"at %L: mismatch in the calling convention",
&rvalue->where);
- return FAILURE;
+ return false;
}
}
- if (gfc_is_proc_ptr_comp (lvalue, &comp))
+ comp = gfc_get_proc_ptr_comp (lvalue);
+ if (comp)
s1 = comp->ts.interface;
else
- s1 = lvalue->symtree->n.sym;
+ {
+ s1 = lvalue->symtree->n.sym;
+ if (s1->ts.interface)
+ s1 = s1->ts.interface;
+ }
- if (gfc_is_proc_ptr_comp (rvalue, &comp))
+ comp = gfc_get_proc_ptr_comp (rvalue);
+ if (comp)
{
- s2 = comp->ts.interface;
- name = comp->name;
+ if (rvalue->expr_type == EXPR_FUNCTION)
+ {
+ s2 = comp->ts.interface->result;
+ name = s2->name;
+ }
+ else
+ {
+ s2 = comp->ts.interface;
+ name = comp->name;
+ }
}
else if (rvalue->expr_type == EXPR_FUNCTION)
{
- s2 = rvalue->symtree->n.sym->result;
- name = rvalue->symtree->n.sym->result->name;
+ if (rvalue->value.function.esym)
+ s2 = rvalue->value.function.esym->result;
+ else
+ s2 = rvalue->symtree->n.sym->result;
+
+ name = s2->name;
}
else
{
s2 = rvalue->symtree->n.sym;
- name = rvalue->symtree->n.sym->name;
+ name = s2->name;
+ }
+
+ if (s2 && s2->attr.proc_pointer && s2->ts.interface)
+ s2 = s2->ts.interface;
+
+ if (s1 == s2 || !s1 || !s2)
+ return true;
+
+ /* F08:7.2.2.4 (4) */
+ if (s1->attr.if_source == IFSRC_UNKNOWN
+ && gfc_explicit_interface_required (s2, err, sizeof(err)))
+ {
+ gfc_error ("Explicit interface required for '%s' at %L: %s",
+ s1->name, &lvalue->where, err);
+ return false;
+ }
+ if (s2->attr.if_source == IFSRC_UNKNOWN
+ && gfc_explicit_interface_required (s1, err, sizeof(err)))
+ {
+ gfc_error ("Explicit interface required for '%s' at %L: %s",
+ s2->name, &rvalue->where, err);
+ return false;
}
- if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
- err, sizeof(err)))
+ if (!gfc_compare_interfaces (s1, s2, name, 0, 1,
+ err, sizeof(err), NULL, NULL))
{
gfc_error ("Interface mismatch in procedure pointer assignment "
"at %L: %s", &rvalue->where, err);
- return FAILURE;
+ return false;
}
- return SUCCESS;
+ /* Check F2008Cor2, C729. */
+ if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN
+ && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function)
+ {
+ gfc_error ("Procedure pointer target '%s' at %L must be either an "
+ "intrinsic, host or use associated, referenced or have "
+ "the EXTERNAL attribute", s2->name, &rvalue->where);
+ return false;
+ }
+
+ return true;
}
if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
{
- 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;
+ /* Check for F03:C717. */
+ if (UNLIMITED_POLY (rvalue)
+ && !(UNLIMITED_POLY (lvalue)
+ || (lvalue->ts.type == BT_DERIVED
+ && (lvalue->ts.u.derived->attr.is_bind_c
+ || lvalue->ts.u.derived->attr.sequence))))
+ gfc_error ("Data-pointer-object &L must be unlimited "
+ "polymorphic, a sequence derived type or of a "
+ "type with the BIND attribute assignment at %L "
+ "to be compatible with an unlimited polymorphic "
+ "target", &lvalue->where);
+ else
+ gfc_error ("Different types in pointer assignment at %L; "
+ "attempted assignment of %s to %s", &lvalue->where,
+ gfc_typename (&rvalue->ts),
+ gfc_typename (&lvalue->ts));
+ return false;
}
if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
{
gfc_error ("Different kind type parameters in pointer "
"assignment at %L", &lvalue->where);
- return FAILURE;
+ return false;
}
if (lvalue->rank != rvalue->rank && !rank_remap)
{
gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
- return FAILURE;
+ return false;
}
- 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);
+ /* Make sure the vtab is present. */
+ if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue))
+ gfc_find_vtab (&rvalue->ts);
/* Check rank remapping. */
if (rank_remap)
/* 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
+ if (gfc_array_size (lvalue, &lsize)
+ && gfc_array_size (rvalue, &rsize)
&& mpz_cmp (rsize, lsize) < 0)
{
gfc_error ("Rank remapping target is smaller than size of the"
" pointer (%ld < %ld) at %L",
mpz_get_si (rsize), mpz_get_si (lsize),
&lvalue->where);
- return FAILURE;
+ return false;
}
/* The target must be either rank one or it must be simply contiguous
{
gfc_error ("Rank remapping target must be rank 1 or"
" simply contiguous at %L", &rvalue->where);
- return FAILURE;
+ return false;
}
- if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Rank remapping"
- " target is not rank 1 at %L", &rvalue->where)
- == FAILURE)
- return FAILURE;
+ if (!gfc_notify_std (GFC_STD_F2008, "Rank remapping target is not "
+ "rank 1 at %L", &rvalue->where))
+ return false;
}
}
/* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
if (rvalue->expr_type == EXPR_NULL)
- return SUCCESS;
+ return true;
if (lvalue->ts.type == BT_CHARACTER)
{
- gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
- if (t == FAILURE)
- return FAILURE;
+ bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
+ if (!t)
+ return false;
}
if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
gfc_error ("Target expression in pointer assignment "
"at %L must deliver a pointer result",
&rvalue->where);
- return FAILURE;
+ return false;
}
if (!attr.target && !attr.pointer)
{
gfc_error ("Pointer assignment target is neither TARGET "
"nor POINTER at %L", &rvalue->where);
- return FAILURE;
+ return false;
}
if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
}
if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
-
+ gfc_unset_implicit_pure (gfc_current_ns->proc_name);
if (gfc_has_vector_index (rvalue))
{
gfc_error ("Pointer assignment with vector subscript "
"on rhs at %L", &rvalue->where);
- return FAILURE;
+ return false;
}
if (attr.is_protected && attr.use_assoc
{
gfc_error ("Pointer assignment target has PROTECTED "
"attribute at %L", &rvalue->where);
- return FAILURE;
+ return false;
}
/* F2008, C725. For PURE also C1283. */
{
gfc_error ("Data target at %L shall not have a coindex",
&rvalue->where);
- return FAILURE;
+ return false;
+ }
+ }
+
+ /* Warn if it is the LHS pointer may lives longer than the RHS target. */
+ if (warn_target_lifetime
+ && rvalue->expr_type == EXPR_VARIABLE
+ && !rvalue->symtree->n.sym->attr.save
+ && !attr.pointer && !rvalue->symtree->n.sym->attr.host_assoc
+ && !rvalue->symtree->n.sym->attr.in_common
+ && !rvalue->symtree->n.sym->attr.use_assoc
+ && !rvalue->symtree->n.sym->attr.dummy)
+ {
+ bool warn;
+ gfc_namespace *ns;
+
+ warn = lvalue->symtree->n.sym->attr.dummy
+ || lvalue->symtree->n.sym->attr.result
+ || lvalue->symtree->n.sym->attr.function
+ || (lvalue->symtree->n.sym->attr.host_assoc
+ && lvalue->symtree->n.sym->ns
+ != rvalue->symtree->n.sym->ns)
+ || lvalue->symtree->n.sym->attr.use_assoc
+ || lvalue->symtree->n.sym->attr.in_common;
+
+ if (rvalue->symtree->n.sym->ns->proc_name
+ && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE
+ && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM)
+ for (ns = rvalue->symtree->n.sym->ns;
+ ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE;
+ ns = ns->parent)
+ if (ns->parent == lvalue->symtree->n.sym->ns)
+ {
+ warn = true;
+ break;
}
+
+ if (warn)
+ gfc_warning ("Pointer at %L in pointer assignment might outlive the "
+ "pointer target", &lvalue->where);
}
- return SUCCESS;
+ return true;
}
/* Relative of gfc_check_assign() except that the lvalue is a single
symbol. Used for initialization assignments. */
-gfc_try
-gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
+bool
+gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
{
gfc_expr lvalue;
- gfc_try r;
+ bool r;
+ bool pointer, proc_pointer;
memset (&lvalue, '\0', sizeof (gfc_expr));
lvalue.symtree->n.sym = sym;
lvalue.where = sym->declared_at;
- if (sym->attr.pointer || sym->attr.proc_pointer
- || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer
- && rvalue->expr_type == EXPR_NULL))
+ if (comp)
+ {
+ lvalue.ref = gfc_get_ref ();
+ lvalue.ref->type = REF_COMPONENT;
+ lvalue.ref->u.c.component = comp;
+ lvalue.ref->u.c.sym = sym;
+ lvalue.ts = comp->ts;
+ lvalue.rank = comp->as ? comp->as->rank : 0;
+ lvalue.where = comp->loc;
+ pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ ? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer;
+ proc_pointer = comp->attr.proc_pointer;
+ }
+ else
+ {
+ pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
+ proc_pointer = sym->attr.proc_pointer;
+ }
+
+ if (pointer || proc_pointer)
r = gfc_check_pointer_assign (&lvalue, rvalue);
else
r = gfc_check_assign (&lvalue, rvalue, 1);
free (lvalue.symtree);
+ free (lvalue.ref);
- if (r == FAILURE)
+ if (!r)
return r;
-
- if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL)
+
+ if (pointer && rvalue->expr_type != EXPR_NULL)
{
/* F08:C461. Additional checks for pointer initialization. */
symbol_attribute attr;
attr = gfc_expr_attr (rvalue);
if (attr.allocatable)
{
- gfc_error ("Pointer initialization target at %C "
- "must not be ALLOCATABLE ");
- return FAILURE;
+ gfc_error ("Pointer initialization target at %L "
+ "must not be ALLOCATABLE", &rvalue->where);
+ return false;
}
if (!attr.target || attr.pointer)
{
- gfc_error ("Pointer initialization target at %C "
- "must have the TARGET attribute");
- return FAILURE;
+ gfc_error ("Pointer initialization target at %L "
+ "must have the TARGET attribute", &rvalue->where);
+ return false;
}
+
+ if (!attr.save && rvalue->expr_type == EXPR_VARIABLE
+ && rvalue->symtree->n.sym->ns->proc_name
+ && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program)
+ {
+ rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT;
+ attr.save = SAVE_IMPLICIT;
+ }
+
if (!attr.save)
{
- gfc_error ("Pointer initialization target at %C "
- "must have the SAVE attribute");
- return FAILURE;
+ gfc_error ("Pointer initialization target at %L "
+ "must have the SAVE attribute", &rvalue->where);
+ return false;
}
}
-
- if (sym->attr.proc_pointer && rvalue->expr_type != EXPR_NULL)
+
+ if (proc_pointer && rvalue->expr_type != EXPR_NULL)
{
/* F08:C1220. Additional checks for procedure pointer initialization. */
symbol_attribute attr = gfc_expr_attr (rvalue);
{
gfc_error ("Procedure pointer initialization target at %L "
"may not be a procedure pointer", &rvalue->where);
- return FAILURE;
+ return false;
}
}
- return SUCCESS;
+ return true;
}
if (!c->attr.pointer
&& gfc_has_default_initializer (c->ts.u.derived))
return true;
+ if (c->attr.pointer && c->initializer)
+ return true;
}
else
{
return false;
}
+
/* Get an expression for a default initializer. */
gfc_expr *
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))
+ || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ && CLASS_DATA (comp)->attr.allocatable))
break;
if (!comp)
gfc_constructor *ctor = gfc_constructor_get();
if (comp->initializer)
- ctor->expr = gfc_copy_expr (comp->initializer);
+ {
+ ctor->expr = gfc_copy_expr (comp->initializer);
+ if ((comp->ts.type != comp->initializer->ts.type
+ || comp->ts.kind != comp->initializer->ts.kind)
+ && !comp->attr.pointer && !comp->attr.proc_pointer)
+ gfc_convert_type_warn (ctor->expr, &comp->ts, 2, false);
+ }
if (comp->attr.allocatable
|| (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
e->symtree = var;
e->ts = var->n.sym->ts;
- if (var->n.sym->as != NULL)
+ if (var->n.sym->attr.flavor != FL_PROCEDURE
+ && ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS)
+ || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym)
+ && CLASS_DATA (var->n.sym)->as)))
{
- e->rank = var->n.sym->as->rank;
+ e->rank = var->n.sym->ts.type == BT_CLASS
+ ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank;
e->ref = gfc_get_ref ();
e->ref->type = REF_ARRAY;
e->ref->u.ar.type = AR_FULL;
+ e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS
+ ? CLASS_DATA (var->n.sym)->as
+ : var->n.sym->as);
}
return e;
}
+/* Adds a full array reference to an expression, as needed. */
+
+void
+gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as)
+{
+ gfc_ref *ref;
+ for (ref = e->ref; ref; ref = ref->next)
+ if (!ref->next)
+ break;
+ if (ref)
+ {
+ ref->next = gfc_get_ref ();
+ ref = ref->next;
+ }
+ else
+ {
+ e->ref = gfc_get_ref ();
+ ref = e->ref;
+ }
+ ref->type = REF_ARRAY;
+ ref->u.ar.type = AR_FULL;
+ ref->u.ar.dimen = e->rank;
+ ref->u.ar.where = e->where;
+ ref->u.ar.as = as;
+}
+
+
gfc_expr *
gfc_lval_expr_from_sym (gfc_symbol *sym)
{
/* It will always be a full array. */
lval->rank = sym->as ? sym->as->rank : 0;
if (lval->rank)
- {
- 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;
- }
-
+ gfc_add_full_array_ref (lval, sym->ts.type == BT_CLASS ?
+ CLASS_DATA (sym)->as : sym->as);
return lval;
}
}
-/* Determine if an expression is a procedure pointer component. If yes, the
- argument 'comp' will point to the component (provided that 'comp' was
- provided). */
+/* Determine if an expression is a procedure pointer component and return
+ the component in that case. Otherwise return NULL. */
-bool
-gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
+gfc_component *
+gfc_get_proc_ptr_comp (gfc_expr *expr)
{
gfc_ref *ref;
- bool ppc = false;
if (!expr || !expr->ref)
- return false;
+ return NULL;
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;
- }
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->attr.proc_pointer)
+ return ref->u.c.component;
- return ppc;
+ return NULL;
+}
+
+
+/* Determine if an expression is a procedure pointer component. */
+
+bool
+gfc_is_proc_ptr_comp (gfc_expr *expr)
+{
+ return (gfc_get_proc_ptr_comp (expr) != NULL);
}
expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
int* f ATTRIBUTE_UNUSED)
{
- gfc_try t;
+ bool t;
if (e->expr_type != EXPR_VARIABLE)
return false;
t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
true, e->where);
- return (t == FAILURE);
+ return (!t);
}
-gfc_try
+bool
gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
{
bool error_found;
if (e->expr_type == EXPR_OP)
{
- gfc_try t = SUCCESS;
+ bool t = true;
gcc_assert (e->value.op.op1);
t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
- if (t == SUCCESS && e->value.op.op2)
+ if (t && e->value.op.op2)
t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
return t;
check_typed_ns = ns;
error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
- 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_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;
-}
-
-void
-gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
-{
- gfc_traverse_expr (expr, dest, &replace_symbol, 0);
-}
-
-/* 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). */
-
-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_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;
-}
-
-void
-gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
-{
- gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
+ return error_found ? false : true;
}
{
case REF_COMPONENT:
comp = ref->u.c.component;
- if (comp->attr.pointer || comp->attr.allocatable)
+ if (comp->ts.type == BT_CLASS && comp->attr.class_ok
+ && (CLASS_DATA (comp)->attr.class_pointer
+ || CLASS_DATA (comp)->attr.allocatable))
+ {
+ coindexed = false;
+ coarray = CLASS_DATA (comp)->attr.codimension;
+ }
+ else if (comp->attr.pointer || comp->attr.allocatable)
{
coindexed = false;
- if (comp->ts.type == BT_CLASS && comp->attr.class_ok)
- coarray = CLASS_DATA (comp)->attr.codimension;
- else
- coarray = comp->attr.codimension;
+ coarray = comp->attr.codimension;
}
break;
{
int corank;
gfc_ref *ref;
- corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
+
+ if (!gfc_is_coarray (e))
+ return 0;
+
+ if (e->ts.type == BT_CLASS && e->ts.u.derived->components)
+ corank = e->ts.u.derived->components->as
+ ? e->ts.u.derived->components->as->corank : 0;
+ else
+ corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
+
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type == REF_ARRAY)
corank = ref->u.ar.as->corank;
gcc_assert (ref->type != REF_SUBSTRING);
}
+
return corank;
}
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)
/* 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,
+ if bool is not strict, some further checks are done - for instance,
a "(::1)" is accepted. */
bool
int i;
gfc_array_ref *ar = NULL;
gfc_ref *ref, *part_ref = NULL;
+ gfc_symbol *sym;
if (expr->expr_type == EXPR_FUNCTION)
return expr->value.function.esym
for (ref = expr->ref; ref; ref = ref->next)
{
if (ar)
- return false; /* Array shall be last part-ref. */
+ return false; /* Array shall be last part-ref. */
if (ref->type == REF_COMPONENT)
part_ref = ref;
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)))
+ sym = expr->symtree->n.sym;
+ if (expr->ts.type != BT_CLASS
+ && ((part_ref
+ && !part_ref->u.c.component->attr.contiguous
+ && part_ref->u.c.component->attr.pointer)
+ || (!part_ref
+ && !sym->attr.contiguous
+ && (sym->attr.pointer
+ || sym->as->type == AS_ASSUMED_RANK
+ || sym->as->type == AS_ASSUMED_SHAPE))))
return false;
if (!ar || ar->type == AR_FULL)
return false;
/* Following the standard, "(::1)" or - if known at compile time -
- "(lbound:ubound)" are not simply contigous; if strict
+ "(lbound:ubound)" are not simply contiguous; if strict
is false, they are regarded as simply contiguous. */
if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT
|| ar->stride[i]->ts.type != BT_INTEGER
ar->as->upper[i]->value.integer) != 0))
colon = false;
}
-
+
return true;
}
want to add arguments but with a NULL-expression. */
gfc_expr*
-gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
+gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name,
+ locus where, unsigned numarg, ...)
{
gfc_expr* result;
gfc_actual_arglist* atail;
gfc_intrinsic_sym* isym;
va_list ap;
unsigned i;
+ const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name);
- isym = gfc_find_function (name);
+ isym = gfc_intrinsic_function_by_id (id);
gcc_assert (isym);
-
+
result = gfc_get_expr ();
result->expr_type = EXPR_FUNCTION;
result->ts = isym->ts;
result->where = where;
- result->value.function.name = name;
+ result->value.function.name = mangled_name;
result->value.function.isym = isym;
+ gfc_get_sym_tree (mangled_name, ns, &result->symtree, false);
+ gfc_commit_symbol (result->symtree->n.sym);
+ gcc_assert (result->symtree
+ && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE
+ || result->symtree->n.sym->attr.flavor == FL_UNKNOWN));
+ result->symtree->n.sym->intmod_sym_id = id;
+ result->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ result->symtree->n.sym->attr.intrinsic = 1;
+ result->symtree->n.sym->attr.artificial = 1;
+
va_start (ap, numarg);
atail = NULL;
for (i = 0; i < numarg; ++i)
(F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
This is called from the various places when resolving
the pieces that make up such a context.
+ If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
+ variables), some checks are not performed.
Optionally, a possible error message can be suppressed if context is NULL
- and just the return status (SUCCESS / FAILURE) be requested. */
+ and just the return status (true / false) be requested. */
-gfc_try
+bool
gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
- const char* context)
+ bool own_scope, const char* context)
{
gfc_symbol* sym = NULL;
bool is_pointer;
bool ptr_component;
symbol_attribute attr;
gfc_ref* ref;
+ int i;
if (e->expr_type == EXPR_VARIABLE)
{
if (context)
gfc_error ("Fortran 2008: Pointer functions in variable definition"
" context (%s) at %L", context, &e->where);
- return FAILURE;
+ return false;
}
}
else if (e->expr_type != EXPR_VARIABLE)
if (context)
gfc_error ("Non-variable expression in variable definition context (%s)"
" at %L", context, &e->where);
- return FAILURE;
+ 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;
+ return false;
}
if (!pointer && sym->attr.flavor != FL_VARIABLE
&& !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result)
if (context)
gfc_error ("'%s' in variable definition context (%s) at %L is not"
" a variable", sym->name, context, &e->where);
- return FAILURE;
+ return false;
}
/* Find out whether the expr is a pointer; this also means following
if (context)
gfc_error ("Non-POINTER in pointer association context (%s)"
" at %L", context, &e->where);
- return FAILURE;
+ return false;
}
/* F2008, C1303. */
if (context)
gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
context, &e->where);
- return FAILURE;
+ return false;
}
- /* 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;
+ /* INTENT(IN) dummy argument. Check this, unless the object itself is the
+ component of sub-component of a pointer; we need to distinguish
+ assignment to a pointer component from pointer-assignment to a pointer
+ component. Note that (normal) assignment to procedure pointers is not
+ possible. */
+ check_intentin = !own_scope;
+ ptr_component = (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+ ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
for (ref = e->ref; ref && check_intentin; ref = ref->next)
{
if (ptr_component && ref->type == REF_COMPONENT)
check_intentin = false;
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
- ptr_component = true;
+ {
+ ptr_component = true;
+ if (!pointer)
+ check_intentin = false;
+ }
}
if (check_intentin && sym->attr.intent == INTENT_IN)
{
gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
" association context (%s) at %L",
sym->name, context, &e->where);
- return FAILURE;
+ return false;
}
- if (!pointer && !is_pointer)
+ if (!pointer && !is_pointer && !sym->attr.pointer)
{
if (context)
gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
" definition context (%s) at %L",
sym->name, context, &e->where);
- return FAILURE;
+ return false;
}
}
/* PROTECTED and use-associated. */
- if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin)
+ if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin)
{
if (pointer && is_pointer)
{
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;
+ return false;
}
if (!pointer && !is_pointer)
{
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;
+ return false;
}
}
/* Variable not assignable from a PURE procedure but appears in
variable definition context. */
- if (!pointer && gfc_pure (NULL) && gfc_impure_variable (sym))
+ if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym))
{
if (context)
gfc_error ("Variable '%s' can not appear in a variable definition"
" context (%s) at %L in PURE procedure",
sym->name, context, &e->where);
- return FAILURE;
+ return false;
}
- if (!pointer && gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ if (!pointer && context && gfc_implicit_pure (NULL)
+ && gfc_impure_variable (sym))
+ {
+ gfc_namespace *ns;
+ gfc_symbol *sym;
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ {
+ sym = ns->proc_name;
+ if (sym == NULL)
+ break;
+ if (sym->attr.flavor == FL_PROCEDURE)
+ {
+ sym->attr.implicit_pure = 0;
+ break;
+ }
+ }
+ }
/* Check variable definition context for associate-names. */
if (!pointer && sym->assoc)
{
" not be used in a variable definition context (%s)",
name, &e->where, context);
}
- return FAILURE;
+ return false;
}
/* Target must be allowed to appear in a variable definition context. */
- if (gfc_check_vardef_context (assoc->target, pointer, false, NULL)
- == FAILURE)
+ if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL))
{
if (context)
gfc_error ("Associate-name '%s' can not appear in a variable"
" at %L can not, either",
name, context, &e->where,
&assoc->target->where);
- return FAILURE;
+ return false;
}
}
- return SUCCESS;
+ /* Check for same value in vector expression subscript. */
+
+ if (e->rank > 0)
+ for (ref = e->ref; ref != NULL; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
+ for (i = 0; i < GFC_MAX_DIMENSIONS
+ && ref->u.ar.dimen_type[i] != 0; i++)
+ if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+ {
+ gfc_expr *arr = ref->u.ar.start[i];
+ if (arr->expr_type == EXPR_ARRAY)
+ {
+ gfc_constructor *c, *n;
+ gfc_expr *ec, *en;
+
+ for (c = gfc_constructor_first (arr->value.constructor);
+ c != NULL; c = gfc_constructor_next (c))
+ {
+ if (c == NULL || c->iterator != NULL)
+ continue;
+
+ ec = c->expr;
+
+ for (n = gfc_constructor_next (c); n != NULL;
+ n = gfc_constructor_next (n))
+ {
+ if (n->iterator != NULL)
+ continue;
+
+ en = n->expr;
+ if (gfc_dep_compare_expr (ec, en) == 0)
+ {
+ if (context)
+ gfc_error_now_1 ("Elements with the same value "
+ "at %L and %L in vector "
+ "subscript in a variable "
+ "definition context (%s)",
+ &(ec->where), &(en->where),
+ context);
+ return false;
+ }
+ }
+ }
+ }
+ }
+
+ return true;
}
projects / gcc.git / blobdiff