/* Routines for manipulation of expression nodes.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010, 2011, 2012
- Free Software Foundation, Inc.
+ Copyright (C) 2000-2017 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "config.h"
#include "system.h"
+#include "coretypes.h"
+#include "options.h"
#include "gfortran.h"
#include "arith.h"
#include "match.h"
gfc_expr *e;
if (!where)
- gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL");
+ gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be "
+ "NULL");
e = gfc_get_expr ();
case BT_HOLLERITH:
case BT_LOGICAL:
- case BT_DERIVED:
+ case_bt_struct:
case BT_CLASS:
case BT_ASSUMED:
break; /* Already done. */
/* 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 *
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;
p = gfc_get_expr ();
p->expr_type = EXPR_FUNCTION;
p->symtree = NULL;
- p->value.function.actual = NULL;
-
p->value.function.actual = gfc_get_actual_arglist ();
p->value.function.actual->expr = e;
}
-/* Function to determine if an expression is constant or not. This
- function expects that the expression has already been simplified. */
+/* Determine if an expression is constant in the sense of F08:7.1.12.
+ * This function expects that the expression has already been simplified. */
-int
+bool
gfc_is_constant_expr (gfc_expr *e)
{
gfc_constructor *c;
gfc_actual_arglist *arg;
- gfc_symbol *sym;
if (e == NULL)
- return 1;
+ return true;
switch (e->expr_type)
{
|| gfc_is_constant_expr (e->value.op.op2)));
case EXPR_VARIABLE:
- return 0;
+ return false;
case EXPR_FUNCTION:
case EXPR_PPC:
{
for (arg = e->value.function.actual; arg; arg = arg->next)
if (!gfc_is_constant_expr (arg->expr))
- return 0;
+ return false;
}
- /* Specification functions are constant. */
- /* F95, 7.1.6.2; F2003, 7.1.7 */
- sym = NULL;
- if (e->symtree)
- sym = e->symtree->n.sym;
- if (e->value.function.esym)
- sym = e->value.function.esym;
-
- if (sym
- && sym->attr.function
- && sym->attr.pure
- && !sym->attr.intrinsic
- && !sym->attr.recursive
- && sym->attr.proc != PROC_INTERNAL
- && sym->attr.proc != PROC_ST_FUNCTION
- && sym->attr.proc != PROC_UNKNOWN
- && sym->formal == NULL)
- return 1;
-
if (e->value.function.isym
&& (e->value.function.isym->elemental
|| e->value.function.isym->pure
|| e->value.function.isym->inquiry
|| e->value.function.isym->transformational))
- return 1;
+ return true;
- return 0;
+ return false;
case EXPR_CONSTANT:
case EXPR_NULL:
- return 1;
+ return true;
case EXPR_SUBSTRING:
return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
for (; c; c = gfc_constructor_next (c))
if (!gfc_is_constant_expr (c->expr))
- return 0;
+ return false;
- return 1;
+ return true;
default:
gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
- return 0;
+ return false;
}
}
/* 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;
}
static gfc_constructor *
find_component_ref (gfc_constructor_base base, gfc_ref *ref)
{
- gfc_component *comp;
- gfc_component *pick;
+ gfc_component *pick = ref->u.c.component;
gfc_constructor *c = gfc_constructor_first (base);
- comp = ref->u.c.sym->components;
- pick = ref->u.c.component;
+ gfc_symbol *dt = ref->u.c.sym;
+ int ext = dt->attr.extension;
+
+ /* For extended types, check if the desired component is in one of the
+ * parent types. */
+ while (ext > 0 && gfc_find_component (dt->components->ts.u.derived,
+ pick->name, true, true, NULL))
+ {
+ dt = dt->components->ts.u.derived;
+ c = gfc_constructor_first (c->expr->value.constructor);
+ ext--;
+ }
+
+ gfc_component *comp = dt->components;
while (comp != pick)
{
comp = comp->next;
/* 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
}
limit = mpz_get_ui (ptr);
- if (limit >= gfc_option.flag_max_array_constructor)
+ if (limit >= flag_max_array_constructor)
{
gfc_error ("The number of elements in the array constructor "
"at %L requires an increase of the allowed %d "
"upper limit. See -fmax-array-constructor "
- "option", &expr->where,
- gfc_option.flag_max_array_constructor);
- return FAILURE;
+ "option", &expr->where, flag_max_array_constructor);
+ 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. */
case AR_FULL:
if (p->ref->next != NULL
- && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
+ && (p->ts.type == BT_CHARACTER || gfc_bt_struct (p->ts.type)))
{
for (c = gfc_constructor_first (p->value.constructor);
c; c = gfc_constructor_next (c))
{
c->expr->ref = gfc_copy_ref (p->ref->next);
- if (simplify_const_ref (c->expr) == FAILURE)
- return FAILURE;
+ if (!simplify_const_ref (c->expr))
+ return false;
}
- if (p->ts.type == BT_DERIVED
+ if (gfc_bt_struct (p->ts.type)
&& p->ref->next
&& (c = gfc_constructor_first (p->value.constructor)))
{
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))
{
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_constructor *ctor;
gcc_assert (e->expr_type == EXPR_STRUCTURE);
- gcc_assert (e->ts.type == BT_DERIVED);
+ gcc_assert (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS);
for (comp = e->ts.u.derived->components,
ctor = gfc_constructor_first (e->value.constructor);
comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
{
- if (comp->attr.allocatable
+ if (comp->attr.allocatable && ctor->expr
&& ctor->expr->expr_type != EXPR_NULL)
{
- gfc_error("Invalid initialization expression for ALLOCATABLE "
- "component '%s' in structure constructor at %L",
- comp->name, &ctor->expr->where);
- return FAILURE;
+ gfc_error ("Invalid initialization expression for ALLOCATABLE "
+ "component %qs in structure constructor at %L",
+ comp->name, &ctor->expr->where);
+ 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->symtree->n.sym->ts.u.cl->length == NULL
|| ap->expr->symtree->n.sym->ts.deferred))
{
- gfc_error ("Assumed or deferred character length variable '%s' "
+ gfc_error ("Assumed or deferred character length variable %qs "
" in constant expression at %L",
ap->expr->symtree->n.sym->name,
&ap->expr->where);
return MATCH_ERROR;
}
- else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
+ 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 (functions[i] == NULL)
{
- gfc_error("transformational intrinsic '%s' at %L is not permitted "
- "in an initialization expression", name, &e->where);
+ gfc_error ("transformational intrinsic %qs at %L is not permitted "
+ "in an initialization expression", name, &e->where);
return MATCH_ERROR;
}
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;
+ bool conversion;
+ gfc_intrinsic_sym* isym = NULL;
+ gfc_symbol* sym = e->symtree->n.sym;
+
+ /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
+ IEEE_EXCEPTIONS modules. */
+ int mod = sym->from_intmod;
+ if (mod == INTMOD_NONE && sym->generic)
+ mod = sym->generic->sym->from_intmod;
+ if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS)
+ {
+ gfc_expr *new_expr = gfc_simplify_ieee_functions (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)
+ /* If a conversion function, e.g., __convert_i8_i4, was inserted
+ into an array constructor, we need to skip the error check here.
+ Conversion errors are caught below in scalarize_intrinsic_call. */
+ conversion = e->value.function.isym
+ && (e->value.function.isym->conversion == 1);
+
+ if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where)
+ || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES))
{
- gfc_error ("Function '%s' in initialization expression at %L "
+ gfc_error ("Function %qs in initialization expression at %L "
"must be an intrinsic function",
e->symtree->n.sym->name, &e->where);
break;
&& (m = check_transformational (e)) == MATCH_NO
&& (m = check_elemental (e)) == MATCH_NO)
{
- gfc_error ("Intrinsic function '%s' at %L is not permitted "
+ gfc_error ("Intrinsic function %qs at %L is not permitted "
"in an initialization expression",
e->symtree->n.sym->name, &e->where);
m = MATCH_ERROR;
}
if (m == MATCH_ERROR)
- return FAILURE;
+ 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)
is invalid. */
if (!e->symtree->n.sym->value)
{
- gfc_error("PARAMETER '%s' is used at %L before its definition "
- "is complete", e->symtree->n.sym->name, &e->where);
- t = FAILURE;
+ gfc_error ("PARAMETER %qs is used at %L before its definition "
+ "is complete", e->symtree->n.sym->name, &e->where);
+ 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)
{
switch (e->symtree->n.sym->as->type)
{
case AS_ASSUMED_SIZE:
- gfc_error ("Assumed size array '%s' at %L is not permitted "
+ gfc_error ("Assumed size array %qs at %L is not permitted "
"in an initialization expression",
e->symtree->n.sym->name, &e->where);
break;
case AS_ASSUMED_SHAPE:
- gfc_error ("Assumed shape array '%s' at %L is not permitted "
+ gfc_error ("Assumed shape array %qs at %L is not permitted "
"in an initialization expression",
e->symtree->n.sym->name, &e->where);
break;
case AS_DEFERRED:
- gfc_error ("Deferred array '%s' at %L is not permitted "
+ gfc_error ("Deferred array %qs at %L is not permitted "
"in an initialization expression",
e->symtree->n.sym->name, &e->where);
break;
case AS_EXPLICIT:
- gfc_error ("Array '%s' at %L is a variable, which does "
+ gfc_error ("Array %qs at %L is a variable, which does "
"not reduce to a constant expression",
e->symtree->n.sym->name, &e->where);
break;
}
}
else
- gfc_error ("Parameter '%s' at %L has not been declared or is "
+ gfc_error ("Parameter %qs at %L has not been declared or is "
"a variable, which does not reduce to a constant "
"expression", e->symtree->n.sym->name, &e->where);
case EXPR_CONSTANT:
case EXPR_NULL:
- t = SUCCESS;
+ t = true;
break;
case EXPR_SUBSTRING:
- t = check_init_expr (e->ref->u.ss.start);
- if (t == FAILURE)
- break;
-
- t = check_init_expr (e->ref->u.ss.end);
- if (t == SUCCESS)
- t = gfc_simplify_expr (e, 0);
+ if (e->ref)
+ {
+ t = gfc_check_init_expr (e->ref->u.ss.start);
+ if (!t)
+ break;
+ t = gfc_check_init_expr (e->ref->u.ss.end);
+ if (t)
+ t = gfc_simplify_expr (e, 0);
+ }
+ else
+ t = false;
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;
}
/************* Restricted/specification expressions *************/
-/* Make sure a non-intrinsic function is a specification function. */
+/* Make sure a non-intrinsic function is a specification function,
+ * see F08:7.1.11.5. */
-static gfc_try
+static bool
external_spec_function (gfc_expr *e)
{
gfc_symbol *f;
f = e->value.function.esym;
+ /* IEEE functions allowed are "a reference to a transformational function
+ from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
+ "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
+ IEEE_EXCEPTIONS". */
+ if (f->from_intmod == INTMOD_IEEE_ARITHMETIC
+ || f->from_intmod == INTMOD_IEEE_EXCEPTIONS)
+ {
+ if (!strcmp (f->name, "ieee_selected_real_kind")
+ || !strcmp (f->name, "ieee_support_rounding")
+ || !strcmp (f->name, "ieee_support_flag")
+ || !strcmp (f->name, "ieee_support_halting")
+ || !strcmp (f->name, "ieee_support_datatype")
+ || !strcmp (f->name, "ieee_support_denormal")
+ || !strcmp (f->name, "ieee_support_divide")
+ || !strcmp (f->name, "ieee_support_inf")
+ || !strcmp (f->name, "ieee_support_io")
+ || !strcmp (f->name, "ieee_support_nan")
+ || !strcmp (f->name, "ieee_support_sqrt")
+ || !strcmp (f->name, "ieee_support_standard")
+ || !strcmp (f->name, "ieee_support_underflow_control"))
+ goto function_allowed;
+ }
+
if (f->attr.proc == PROC_ST_FUNCTION)
{
- gfc_error ("Specification function '%s' at %L cannot be a statement "
+ gfc_error ("Specification function %qs 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 "
+ gfc_error ("Specification function %qs 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,
+ gfc_error ("Specification function %qs 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;
- }
+ /* F08:7.1.11.6. */
+ if (f->attr.recursive
+ && !gfc_notify_std (GFC_STD_F2003,
+ "Specification function '%s' "
+ "at %L cannot be RECURSIVE", f->name, &e->where))
+ return false;
+function_allowed:
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:
return check_references (ref->next, checker);
}
+/* Return true if ns is a parent of the current ns. */
+
+static bool
+is_parent_of_current_ns (gfc_namespace *ns)
+{
+ gfc_namespace *p;
+ for (p = gfc_current_ns->parent; p; p = p->parent)
+ if (ns == p)
+ return true;
+
+ return false;
+}
/* 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
if (sym->attr.dummy && sym->ns == gfc_current_ns
&& sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
{
- gfc_error ("Dummy argument '%s' not allowed in expression at %L",
+ gfc_error ("Dummy argument %qs not allowed in expression at %L",
sym->name, &e->where);
break;
}
if (sym->attr.optional)
{
- gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
+ gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
sym->name, &e->where);
break;
}
if (sym->attr.intent == INTENT_OUT)
{
- gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
+ gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
sym->name, &e->where);
break;
}
/* 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->attr.dummy
|| sym->attr.implied_index
|| sym->attr.flavor == FL_PARAMETER
- || (sym->ns && sym->ns == gfc_current_ns->parent)
- || (sym->ns && gfc_current_ns->parent
- && sym->ns == gfc_current_ns->parent->parent)
+ || is_parent_of_current_ns (sym->ns)
|| (sym->ns->proc_name != NULL
&& sym->ns->proc_name->attr.flavor == FL_MODULE)
|| (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
{
- t = SUCCESS;
+ t = true;
break;
}
- gfc_error ("Variable '%s' cannot appear in the expression at %L",
+ gfc_error ("Variable %qs cannot appear in the expression at %L",
sym->name, &e->where);
/* Prevent a repetition of the error. */
e->error = 1;
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",
+ gfc_error ("Function %qs 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. */
+ sure that the assignment can take place. Only add a call to the intrinsic
+ conversion routines, when allow_convert is set. When this assign is a
+ coarray call, then the convert is done by the coarray routine implictly and
+ adding the intrinsic conversion would do harm in most cases. */
-gfc_try
-gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
+bool
+gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
+ bool allow_convert)
{
gfc_symbol *sym;
gfc_ref *ref;
bad_proc = true;
/* (ii) The assignment is in the main program; or */
- if (gfc_current_ns->proc_name->attr.is_main_program)
+ if (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.is_main_program)
bad_proc = true;
/* (iii) A module or internal procedure... */
- if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
- || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
+ if (gfc_current_ns->proc_name
+ && (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
+ || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
&& gfc_current_ns->parent
&& (!(gfc_current_ns->parent->proc_name->attr.function
|| gfc_current_ns->parent->proc_name->attr.subroutine)
|| gfc_current_ns->parent->proc_name->attr.is_main_program))
{
- /* ... that is not a function... */
- if (!gfc_current_ns->proc_name->attr.function)
+ /* ... that is not a function... */
+ if (gfc_current_ns->proc_name
+ && !gfc_current_ns->proc_name->attr.function)
bad_proc = true;
/* ... or is not an entry and has a different name. */
if (bad_proc)
{
- gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
- return FAILURE;
+ gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where);
+ 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 (OPT_Wsurprising,
+ "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 %qs",
+ &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)
- gfc_warning ("BOZ literal at %L is bitwise transferred "
- "non-integer symbol '%s'", &rvalue->where,
- lvalue->symtree->n.sym->name);
+ if (warn_surprising)
+ gfc_warning (OPT_Wsurprising,
+ "BOZ literal at %L is bitwise transferred "
+ "non-integer symbol %qs", &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 underflow of bit-wise transferred BOZ at %L"
". This check can be disabled with the option "
- "-fno-range-check", &rvalue->where);
+ "%<-fno-range-check%>", &rvalue->where);
else if (rc == ARITH_OVERFLOW)
gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
". This check can be disabled with the option "
- "-fno-range-check", &rvalue->where);
+ "%<-fno-range-check%>", &rvalue->where);
else if (rc == ARITH_NAN)
gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
". This check can be disabled with the option "
- "-fno-range-check", &rvalue->where);
- return FAILURE;
- }
- }
-
- /* Warn about type-changing conversions for REAL or COMPLEX constants.
- If lvalue and rvalue are mixed REAL and complex, gfc_compare_types
- will warn anyway, so there is no need to to so here. */
-
- if (rvalue->expr_type == EXPR_CONSTANT && lvalue->ts.type == rvalue->ts.type
- && (lvalue->ts.type == BT_REAL || lvalue->ts.type == BT_COMPLEX))
- {
- if (lvalue->ts.kind < rvalue->ts.kind && gfc_option.gfc_warn_conversion)
- {
- /* As a special bonus, don't warn about REAL rvalues which are not
- changed by the conversion if -Wconversion is specified. */
- if (rvalue->ts.type == BT_REAL && mpfr_number_p (rvalue->value.real))
- {
- /* Calculate the difference between the constant and the rounded
- value and check it against zero. */
- mpfr_t rv, diff;
- gfc_set_model_kind (lvalue->ts.kind);
- mpfr_init (rv);
- gfc_set_model_kind (rvalue->ts.kind);
- mpfr_init (diff);
-
- mpfr_set (rv, rvalue->value.real, GFC_RND_MODE);
- mpfr_sub (diff, rv, rvalue->value.real, GFC_RND_MODE);
-
- if (!mpfr_zero_p (diff))
- gfc_warning ("Change of value in conversion from "
- " %s to %s at %L", gfc_typename (&rvalue->ts),
- gfc_typename (&lvalue->ts), &rvalue->where);
-
- mpfr_clear (rv);
- mpfr_clear (diff);
- }
- else
- gfc_warning ("Possible change of value in conversion from %s "
- "to %s at %L",gfc_typename (&rvalue->ts),
- gfc_typename (&lvalue->ts), &rvalue->where);
-
- }
- else if (gfc_option.warn_conversion_extra
- && lvalue->ts.kind > rvalue->ts.kind)
- {
- gfc_warning ("Conversion from %s to %s at %L",
- gfc_typename (&rvalue->ts),
- gfc_typename (&lvalue->ts), &rvalue->where);
+ "%<-fno-range-check%>", &rvalue->where);
+ return false;
}
}
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
kind values can be converted into one another. */
if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
{
- if (lvalue->ts.kind != rvalue->ts.kind)
- gfc_convert_chartype (rvalue, &lvalue->ts);
-
- return SUCCESS;
+ if (lvalue->ts.kind != rvalue->ts.kind && allow_convert)
+ return gfc_convert_chartype (rvalue, &lvalue->ts);
+ else
+ return true;
}
+ if (!allow_convert)
+ 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 "
+ gfc_error ("%qs 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;
if (ref->u.ar.type != AR_SECTION)
{
- gfc_error ("Expected bounds specification for '%s' at %L",
+ gfc_error ("Expected bounds specification for %qs 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 %qs 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;
}
}
{
char err[200];
gfc_symbol *s1,*s2;
- gfc_component *comp;
+ gfc_component *comp1, *comp2;
const char *name;
attr = gfc_expr_attr (rvalue);
{
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 %qs 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 "
+ gfc_error ("Abstract interface %qs is invalid "
"in procedure pointer assignment at %L",
rvalue->symtree->name, &rvalue->where);
- return FAILURE;
+ return false;
}
/* Check for F08:C729. */
if (attr.flavor == FL_PROCEDURE)
{
if (attr.proc == PROC_ST_FUNCTION)
{
- gfc_error ("Statement function '%s' is invalid "
+ gfc_error ("Statement function %qs 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 %qs "
+ "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 %qs 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 assigment at %L",
+ gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
+ "in procedure pointer assignment at %L",
rvalue->symtree->name, &rvalue->where);
- return FAILURE;
+ 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))
- s1 = comp->ts.interface;
+ comp1 = gfc_get_proc_ptr_comp (lvalue);
+ if (comp1)
+ s1 = comp1->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))
+ comp2 = gfc_get_proc_ptr_comp (rvalue);
+ if (comp2)
{
- s2 = comp->ts.interface;
- name = comp->name;
+ if (rvalue->expr_type == EXPR_FUNCTION)
+ {
+ s2 = comp2->ts.interface->result;
+ name = s2->name;
+ }
+ else
+ {
+ s2 = comp2->ts.interface;
+ name = comp2->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 (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
- err, sizeof(err)))
+ if (s2 && s2->attr.proc_pointer && s2->ts.interface)
+ s2 = s2->ts.interface;
+
+ /* Special check for the case of absent interface on the lvalue.
+ * All other interface checks are done below. */
+ if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function)
+ {
+ gfc_error ("Interface mismatch in procedure pointer assignment "
+ "at %L: '%s' is not a subroutine", &rvalue->where, name);
+ return false;
+ }
+
+ 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 %qs 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 %qs at %L: %s",
+ s2->name, &rvalue->where, err);
+ return false;
+ }
+
+ 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 %qs 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 at %L must be unlimited "
+ "polymorphic, or of a type with the BIND or SEQUENCE "
+ "attribute, 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
and F2008 must be allowed. */
if (rvalue->rank != 1)
{
- if (!gfc_is_simply_contiguous (rvalue, true))
+ if (!gfc_is_simply_contiguous (rvalue, true, false))
{
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 (OPT_Wtarget_lifetime,
+ "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);
+ {
+ /* If a conversion function, e.g., __convert_i8_i4, was inserted
+ into an array constructor, we should check if it can be reduced
+ as an initialization expression. */
+ if (rvalue->expr_type == EXPR_FUNCTION
+ && rvalue->value.function.isym
+ && (rvalue->value.function.isym->conversion == 1))
+ gfc_check_init_expr (rvalue);
+
+ 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;
+}
+
+
+/* Build an initializer for a local integer, real, complex, logical, or
+ character variable, based on the command line flags finit-local-zero,
+ finit-integer=, finit-real=, finit-logical=, and finit-character=. */
+
+gfc_expr *
+gfc_build_default_init_expr (gfc_typespec *ts, locus *where)
+{
+ int char_len;
+ gfc_expr *init_expr;
+ int i;
+
+ /* Try to build an initializer expression. */
+ init_expr = gfc_get_constant_expr (ts->type, ts->kind, where);
+
+ /* We will only initialize integers, reals, complex, logicals, and
+ characters, and only if the corresponding command-line flags
+ were set. Otherwise, we free init_expr and return null. */
+ switch (ts->type)
+ {
+ case BT_INTEGER:
+ if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
+ mpz_set_si (init_expr->value.integer,
+ gfc_option.flag_init_integer_value);
+ else
+ {
+ gfc_free_expr (init_expr);
+ init_expr = NULL;
+ }
+ break;
+
+ case BT_REAL:
+ switch (flag_init_real)
+ {
+ case GFC_INIT_REAL_SNAN:
+ init_expr->is_snan = 1;
+ /* Fall through. */
+ case GFC_INIT_REAL_NAN:
+ mpfr_set_nan (init_expr->value.real);
+ break;
+
+ case GFC_INIT_REAL_INF:
+ mpfr_set_inf (init_expr->value.real, 1);
+ break;
+
+ case GFC_INIT_REAL_NEG_INF:
+ mpfr_set_inf (init_expr->value.real, -1);
+ break;
+
+ case GFC_INIT_REAL_ZERO:
+ mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
+ break;
+
+ default:
+ gfc_free_expr (init_expr);
+ init_expr = NULL;
+ break;
+ }
+ break;
+
+ case BT_COMPLEX:
+ switch (flag_init_real)
+ {
+ case GFC_INIT_REAL_SNAN:
+ init_expr->is_snan = 1;
+ /* Fall through. */
+ case GFC_INIT_REAL_NAN:
+ mpfr_set_nan (mpc_realref (init_expr->value.complex));
+ mpfr_set_nan (mpc_imagref (init_expr->value.complex));
+ break;
+
+ case GFC_INIT_REAL_INF:
+ mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
+ mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
+ break;
+
+ case GFC_INIT_REAL_NEG_INF:
+ mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
+ mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
+ break;
+
+ case GFC_INIT_REAL_ZERO:
+ mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gfc_free_expr (init_expr);
+ init_expr = NULL;
+ break;
+ }
+ break;
+
+ case BT_LOGICAL:
+ if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
+ init_expr->value.logical = 0;
+ else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
+ init_expr->value.logical = 1;
+ else
+ {
+ gfc_free_expr (init_expr);
+ init_expr = NULL;
+ }
+ break;
+
+ case BT_CHARACTER:
+ /* For characters, the length must be constant in order to
+ create a default initializer. */
+ if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
+ && ts->u.cl->length
+ && ts->u.cl->length->expr_type == EXPR_CONSTANT)
+ {
+ char_len = mpz_get_si (ts->u.cl->length->value.integer);
+ init_expr->value.character.length = char_len;
+ init_expr->value.character.string = gfc_get_wide_string (char_len+1);
+ for (i = 0; i < char_len; i++)
+ init_expr->value.character.string[i]
+ = (unsigned char) gfc_option.flag_init_character_value;
+ }
+ else
+ {
+ gfc_free_expr (init_expr);
+ init_expr = NULL;
+ }
+ if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
+ && ts->u.cl->length && flag_max_stack_var_size != 0)
+ {
+ gfc_actual_arglist *arg;
+ init_expr = gfc_get_expr ();
+ init_expr->where = *where;
+ init_expr->ts = *ts;
+ init_expr->expr_type = EXPR_FUNCTION;
+ init_expr->value.function.isym =
+ gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
+ init_expr->value.function.name = "repeat";
+ arg = gfc_get_actual_arglist ();
+ arg->expr = gfc_get_character_expr (ts->kind, where, NULL, 1);
+ arg->expr->value.character.string[0] =
+ gfc_option.flag_init_character_value;
+ arg->next = gfc_get_actual_arglist ();
+ arg->next->expr = gfc_copy_expr (ts->u.cl->length);
+ init_expr->value.function.actual = arg;
+ }
+ break;
+
+ default:
+ gfc_free_expr (init_expr);
+ init_expr = NULL;
+ }
+
+ return init_expr;
+}
+
+/* Apply an initialization expression to a typespec. Can be used for symbols or
+ components. Similar to add_init_expr_to_sym in decl.c; could probably be
+ combined with some effort. */
+
+void
+gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init)
+{
+ if (ts->type == BT_CHARACTER && !attr->pointer && init
+ && ts->u.cl
+ && ts->u.cl->length && ts->u.cl->length->expr_type == EXPR_CONSTANT)
+ {
+ int len;
+
+ gcc_assert (ts->u.cl && ts->u.cl->length);
+ gcc_assert (ts->u.cl->length->expr_type == EXPR_CONSTANT);
+ gcc_assert (ts->u.cl->length->ts.type == BT_INTEGER);
+
+ len = mpz_get_si (ts->u.cl->length->value.integer);
+
+ if (init->expr_type == EXPR_CONSTANT)
+ gfc_set_constant_character_len (len, init, -1);
+ else if (init
+ && init->ts.u.cl
+ && mpz_cmp (ts->u.cl->length->value.integer,
+ init->ts.u.cl->length->value.integer))
+ {
+ gfc_constructor *ctor;
+ ctor = gfc_constructor_first (init->value.constructor);
+
+ if (ctor)
+ {
+ int first_len;
+ bool has_ts = (init->ts.u.cl
+ && init->ts.u.cl->length_from_typespec);
+
+ /* Remember the length of the first element for checking
+ that all elements *in the constructor* have the same
+ length. This need not be the length of the LHS! */
+ gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
+ gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
+ first_len = ctor->expr->value.character.length;
+
+ for ( ; ctor; ctor = gfc_constructor_next (ctor))
+ if (ctor->expr->expr_type == EXPR_CONSTANT)
+ {
+ gfc_set_constant_character_len (len, ctor->expr,
+ has_ts ? -1 : first_len);
+ if (!ctor->expr->ts.u.cl)
+ ctor->expr->ts.u.cl
+ = gfc_new_charlen (gfc_current_ns, ts->u.cl);
+ else
+ ctor->expr->ts.u.cl->length
+ = gfc_copy_expr (ts->u.cl->length);
+ }
+ }
+ }
+ }
+}
+
+
+/* Check whether an expression is a structure constructor and whether it has
+ other values than NULL. */
+
+bool
+is_non_empty_structure_constructor (gfc_expr * e)
+{
+ if (e->expr_type != EXPR_STRUCTURE)
+ return false;
+
+ gfc_constructor *cons = gfc_constructor_first (e->value.constructor);
+ while (cons)
+ {
+ if (!cons->expr || cons->expr->expr_type != EXPR_NULL)
+ return true;
+ cons = gfc_constructor_next (cons);
+ }
+ return false;
}
{
gfc_component *c;
- gcc_assert (der->attr.flavor == FL_DERIVED);
+ gcc_assert (gfc_fl_struct (der->attr.flavor));
for (c = der->components; c; c = c->next)
- if (c->ts.type == BT_DERIVED)
+ if (gfc_bt_struct (c->ts.type))
{
- if (!c->attr.pointer
- && gfc_has_default_initializer (c->ts.u.derived))
+ if (!c->attr.pointer && !c->attr.proc_pointer
+ && !(c->attr.allocatable && der == c->ts.u.derived)
+ && ((c->initializer
+ && is_non_empty_structure_constructor (c->initializer))
+ || gfc_has_default_initializer (c->ts.u.derived)))
return true;
if (c->attr.pointer && c->initializer)
return true;
}
-/* Get an expression for a default initializer. */
+/*
+ Generate an initializer expression which initializes the entirety of a union.
+ A normal structure constructor is insufficient without undue effort, because
+ components of maps may be oddly aligned/overlapped. (For example if a
+ character is initialized from one map overtop a real from the other, only one
+ byte of the real is actually initialized.) Unfortunately we don't know the
+ size of the union right now, so we can't generate a proper initializer, but
+ we use a NULL expr as a placeholder and do the right thing later in
+ gfc_trans_subcomponent_assign.
+ */
+static gfc_expr *
+generate_union_initializer (gfc_component *un)
+{
+ if (un == NULL || un->ts.type != BT_UNION)
+ return NULL;
+
+ gfc_expr *placeholder = gfc_get_null_expr (&un->loc);
+ placeholder->ts = un->ts;
+ return placeholder;
+}
+
+
+/* Get the user-specified initializer for a union, if any. This means the user
+ has said to initialize component(s) of a map. For simplicity's sake we
+ only allow the user to initialize the first map. We don't have to worry
+ about overlapping initializers as they are released early in resolution (see
+ resolve_fl_struct). */
+
+static gfc_expr *
+get_union_initializer (gfc_symbol *union_type, gfc_component **map_p)
+{
+ gfc_component *map;
+ gfc_expr *init=NULL;
+
+ if (!union_type || union_type->attr.flavor != FL_UNION)
+ return NULL;
+
+ for (map = union_type->components; map; map = map->next)
+ {
+ if (gfc_has_default_initializer (map->ts.u.derived))
+ {
+ init = gfc_default_initializer (&map->ts);
+ if (map_p)
+ *map_p = map;
+ break;
+ }
+ }
+
+ if (map_p && !init)
+ *map_p = NULL;
+
+ return init;
+}
+
+/* Fetch or generate an initializer for the given component.
+ Only generate an initializer if generate is true. */
+
+static gfc_expr *
+component_initializer (gfc_typespec *ts, gfc_component *c, bool generate)
+{
+ gfc_expr *init = NULL;
+
+ /* See if we can find the initializer immediately. */
+ if (c->initializer || !generate
+ || (ts->type == BT_CLASS && !c->attr.allocatable))
+ return c->initializer;
+
+ /* Recursively handle derived type components. */
+ if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ init = gfc_generate_initializer (&c->ts, true);
+
+ else if (c->ts.type == BT_UNION && c->ts.u.derived->components)
+ {
+ gfc_component *map = NULL;
+ gfc_constructor *ctor;
+ gfc_expr *user_init;
+
+ /* If we don't have a user initializer and we aren't generating one, this
+ union has no initializer. */
+ user_init = get_union_initializer (c->ts.u.derived, &map);
+ if (!user_init && !generate)
+ return NULL;
+
+ /* Otherwise use a structure constructor. */
+ init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind,
+ &c->loc);
+ init->ts = c->ts;
+
+ /* If we are to generate an initializer for the union, add a constructor
+ which initializes the whole union first. */
+ if (generate)
+ {
+ ctor = gfc_constructor_get ();
+ ctor->expr = generate_union_initializer (c);
+ gfc_constructor_append (&init->value.constructor, ctor);
+ }
+
+ /* If we found an initializer in one of our maps, apply it. Note this
+ is applied _after_ the entire-union initializer above if any. */
+ if (user_init)
+ {
+ ctor = gfc_constructor_get ();
+ ctor->expr = user_init;
+ ctor->n.component = map;
+ gfc_constructor_append (&init->value.constructor, ctor);
+ }
+ }
+
+ /* Treat simple components like locals. */
+ else
+ {
+ init = gfc_build_default_init_expr (&c->ts, &c->loc);
+ gfc_apply_init (&c->ts, &c->attr, init);
+ }
+
+ return init;
+}
+
+
+/* Get an expression for a default initializer of a derived type. */
gfc_expr *
gfc_default_initializer (gfc_typespec *ts)
{
- gfc_expr *init;
+ return gfc_generate_initializer (ts, false);
+}
+
+
+/* Get or generate an expression for a default initializer of a derived type.
+ If -finit-derived is specified, generate default initialization expressions
+ for components that lack them when generate is set. */
+
+gfc_expr *
+gfc_generate_initializer (gfc_typespec *ts, bool generate)
+{
+ gfc_expr *init, *tmp;
gfc_component *comp;
+ generate = flag_init_derived && generate;
/* See if we have a default initializer in this, but not in nested
- types (otherwise we could use gfc_has_default_initializer()). */
- for (comp = ts->u.derived->components; comp; comp = comp->next)
- if (comp->initializer || comp->attr.allocatable
- || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
- break;
+ types (otherwise we could use gfc_has_default_initializer()).
+ We don't need to check if we are going to generate them. */
+ comp = ts->u.derived->components;
+ if (!generate)
+ {
+ for (; comp; comp = comp->next)
+ if (comp->initializer || comp->attr.allocatable
+ || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ && CLASS_DATA (comp)->attr.allocatable))
+ break;
+ }
if (!comp)
return NULL;
{
gfc_constructor *ctor = gfc_constructor_get();
- if (comp->initializer)
+ /* Fetch or generate an initializer for the component. */
+ tmp = component_initializer (ts, comp, generate);
+ if (tmp)
{
- ctor->expr = gfc_copy_expr (comp->initializer);
- if ((comp->ts.type != comp->initializer->ts.type
- || comp->ts.kind != comp->initializer->ts.kind)
+ /* Save the component ref for STRUCTUREs and UNIONs. */
+ if (ts->u.derived->attr.flavor == FL_STRUCT
+ || ts->u.derived->attr.flavor == FL_UNION)
+ ctor->n.component = comp;
+
+ /* If the initializer was not generated, we need a copy. */
+ ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp;
+ if ((comp->ts.type != tmp->ts.type
+ || comp->ts.kind != tmp->ts.kind)
&& !comp->attr.pointer && !comp->attr.proc_pointer)
gfc_convert_type_warn (ctor->expr, &comp->ts, 2, false);
}
{
ctor->expr = gfc_get_expr ();
ctor->expr->expr_type = EXPR_NULL;
+ ctor->expr->where = init->where;
ctor->expr->ts = comp->ts;
}
e->symtree = var;
e->ts = var->n.sym->ts;
- if ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS)
- || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym)
- && CLASS_DATA (var->n.sym)->as))
+ 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->ts.type == BT_CLASS
? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank;
}
+/* Adds a full array reference to an expression, as needed. */
+
+void
+gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as)
+{
+ gfc_ref *ref;
+ for (ref = e->ref; ref; ref = ref->next)
+ if (!ref->next)
+ break;
+ if (ref)
+ {
+ ref->next = gfc_get_ref ();
+ ref = ref->next;
+ }
+ else
+ {
+ e->ref = gfc_get_ref ();
+ ref = e->ref;
+ }
+ ref->type = REF_ARRAY;
+ ref->u.ar.type = AR_FULL;
+ ref->u.ar.dimen = e->rank;
+ ref->u.ar.where = e->where;
+ ref->u.ar.as = as;
+}
+
+
gfc_expr *
gfc_lval_expr_from_sym (gfc_symbol *sym)
{
gfc_expr *lval;
+ gfc_array_spec *as;
lval = gfc_get_expr ();
lval->expr_type = EXPR_VARIABLE;
lval->where = sym->declared_at;
lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
/* It will always be a full array. */
- lval->rank = sym->as ? sym->as->rank : 0;
+ as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
+ lval->rank = as ? 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->ts.type == BT_CLASS
- ? CLASS_DATA (sym)->as : sym->as;
- }
-
+ gfc_add_full_array_ref (lval, 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);
+}
+
+
+/* Determine if an expression is a function with an allocatable class scalar
+ result. */
+bool
+gfc_is_alloc_class_scalar_function (gfc_expr *expr)
+{
+ if (expr->expr_type == EXPR_FUNCTION
+ && expr->value.function.esym
+ && expr->value.function.esym->result
+ && expr->value.function.esym->result->ts.type == BT_CLASS
+ && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension
+ && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable)
+ return true;
+
+ return false;
+}
+
+
+/* Determine if an expression is a function with an allocatable class array
+ result. */
+bool
+gfc_is_alloc_class_array_function (gfc_expr *expr)
+{
+ if (expr->expr_type == EXPR_FUNCTION
+ && expr->value.function.esym
+ && expr->value.function.esym->result
+ && expr->value.function.esym->result->ts.type == BT_CLASS
+ && CLASS_DATA (expr->value.function.esym->result)->attr.dimension
+ && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable)
+ return true;
+
+ return false;
}
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 dummy symbols by the 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
- && expr->symtree->n.sym->attr.dummy)
- {
- gfc_symtree *root = sym->formal_ns ? sym->formal_ns->sym_root
- : gfc_current_ns->sym_root;
- gfc_symtree *stree = gfc_find_symtree (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;
}
return true;
}
+gfc_expr *
+gfc_find_stat_co(gfc_expr *e)
+{
+ gfc_ref *ref;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+ return ref->u.ar.stat;
+
+ if (e->value.function.actual->expr)
+ for (ref = e->value.function.actual->expr->ref; ref;
+ ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+ return ref->u.ar.stat;
+
+ return NULL;
+}
bool
gfc_is_coindexed (gfc_expr *e)
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
+ else
corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
for (ref = e->ref; ref; ref = ref->next)
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)
a "(::1)" is accepted. */
bool
-gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
+gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element)
{
bool colon;
int i;
else if (expr->expr_type != EXPR_VARIABLE)
return false;
- if (expr->rank == 0)
+ if (!permit_element && expr->rank == 0)
return false;
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;
|| (!part_ref
&& !sym->attr.contiguous
&& (sym->attr.pointer
- || sym->as->type == AS_ASSUMED_SHAPE))))
+ || sym->as->type == AS_ASSUMED_RANK
+ || sym->as->type == AS_ASSUMED_SHAPE))))
return false;
if (!ar || ar->type == AR_FULL)
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;
- result->symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ 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;
(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)"
+ gfc_error ("Named constant %qs 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)
&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
{
if (context)
- gfc_error ("'%s' in variable definition context (%s) at %L is not"
+ gfc_error ("%qs 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;
+ }
+
+ if (e->ts.type == BT_DERIVED
+ && e->ts.u.derived == NULL)
+ {
+ if (context)
+ gfc_error ("Type inaccessible in variable definition context (%s) "
+ "at %L", context, &e->where);
+ return false;
}
/* F2008, C1303. */
if (context)
gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
context, &e->where);
- return FAILURE;
+ return false;
+ }
+
+ /* TS18508, C702/C203. */
+ if (!alloc_obj
+ && (attr.lock_comp
+ || (e->ts.type == BT_DERIVED
+ && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)))
+ {
+ if (context)
+ gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
+ context, &e->where);
+ return false;
}
/* INTENT(IN) dummy argument. Check this, unless the object itself is the
assignment to a pointer component from pointer-assignment to a pointer
component. Note that (normal) assignment to procedure pointers is not
possible. */
- check_intentin = true;
- ptr_component = (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+ check_intentin = !own_scope;
+ ptr_component = (sym->ts.type == BT_CLASS && sym->ts.u.derived
+ && CLASS_DATA (sym))
? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
for (ref = e->ref; ref && check_intentin; ref = ref->next)
{
if (pointer && is_pointer)
{
if (context)
- gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
+ gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
" association context (%s) at %L",
sym->name, context, &e->where);
- return FAILURE;
+ return false;
}
if (!pointer && !is_pointer && !sym->attr.pointer)
{
if (context)
- gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
+ gfc_error ("Dummy argument %qs 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)
{
if (context)
- gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
+ gfc_error ("Variable %qs 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)
{
if (context)
- gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
+ gfc_error ("Variable %qs 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"
+ gfc_error ("Variable %qs 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 && context && gfc_implicit_pure (NULL)
if (context)
{
if (assoc->target->expr_type == EXPR_VARIABLE)
- gfc_error ("'%s' at %L associated to vector-indexed target can"
+ gfc_error ("%qs at %L associated to vector-indexed target can"
" not be used in a variable definition context (%s)",
name, &e->where, context);
else
- gfc_error ("'%s' at %L associated to expression can"
+ gfc_error ("%qs at %L associated to expression can"
" 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"
+ gfc_error ("Associate-name %qs can not appear in a variable"
" definition context (%s) at %L because its target"
" at %L can not, either",
name, context, &e->where,
&assoc->target->where);
- return FAILURE;
+ return 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 ("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 / thirdparty / gcc.git / blobdiff