/* 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 *
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;
}
{
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;
}
}
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;
/* Scalarize an expression for an elemental intrinsic call. */
-static gfc_try
+static bool
scalarize_intrinsic_call (gfc_expr *e)
{
gfc_actual_arglist *a, *b;
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 && gfc_check_init_expr (a->expr) == FAILURE)
+ if (a->expr && !gfc_check_init_expr (a->expr))
goto cleanup;
rank[n] = 0;
/* 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 (gfc_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 && gfc_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
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, "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. */
-gfc_try
+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, gfc_check_init_expr);
- if (t == SUCCESS)
+ 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;
+ }
+ }
+
+ /* 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);
- sym = e->symtree->n.sym;
- if (!gfc_is_intrinsic (sym, 0, e->where)
- || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
+ 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 = gfc_check_init_expr (e->ref->u.ss.start);
- if (t == FAILURE)
- break;
-
- t = gfc_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, gfc_check_init_expr);
- if (t == FAILURE)
+ if (!t)
break;
break;
case EXPR_ARRAY:
t = gfc_check_constructor (e, gfc_check_init_expr);
- if (t == FAILURE)
+ 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)
+ 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);
&& !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)
+ 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
+ if (warn_surprising
&& rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer)
- gfc_warning ("POINTER-valued function appears on right-hand side of "
+ 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, "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, "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,"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)
{
attr = gfc_expr_attr (rvalue);
}
/* Check for result of embracing function. */
- if (sym == gfc_current_ns->proc_name
- && sym->attr.function && sym->result == sym)
+ if (sym->attr.function && sym->result == sym)
{
- gfc_error ("Function result '%s' is invalid as proc-target "
- "in procedure pointer assignment at %L",
- sym->name, &rvalue->where);
- return FAILURE;
+ 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 '%s' at %L is invalid in procedure pointer "
+ gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
"assignment", rvalue->symtree->name, &rvalue->where);
- return FAILURE;
+ return false;
}
}
/* Check for F08:C730. */
if (attr.elemental && !attr.intrinsic)
{
- gfc_error ("Nonintrinsic elemental procedure '%s' is invalid "
+ 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;
}
}
- comp = gfc_get_proc_ptr_comp (lvalue);
- if (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;
+ }
- comp = gfc_get_proc_ptr_comp (rvalue);
- if (comp)
+ comp2 = gfc_get_proc_ptr_comp (rvalue);
+ if (comp2)
{
if (rvalue->expr_type == EXPR_FUNCTION)
{
- s2 = comp->ts.interface->result;
- name = comp->ts.interface->result->name;
+ s2 = comp2->ts.interface->result;
+ name = s2->name;
}
else
{
- s2 = comp->ts.interface;
- name = comp->name;
+ 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), NULL, NULL))
+ 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))
|| (lvalue->ts.type == BT_DERIVED
&& (lvalue->ts.u.derived->attr.is_bind_c
|| lvalue->ts.u.derived->attr.sequence))))
- gfc_error ("Data-pointer-object &L must be unlimited "
- "polymorphic, a sequence derived type or of a "
- "type with the BIND attribute assignment at %L "
- "to be compatible with an unlimited polymorphic "
- "target", &lvalue->where);
+ 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 FAILURE;
+ 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;
}
- /* Make sure the vtab is present. */
- if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
- gfc_find_derived_vtab (rvalue->ts.u.derived);
- else if (UNLIMITED_POLY (lvalue) && !UNLIMITED_POLY (rvalue))
- gfc_find_intrinsic_vtab (&rvalue->ts);
+ /* 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, "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 (gfc_option.warn_target_lifetime
+ 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->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->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE;
+ ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE;
ns = ns->parent)
if (ns->parent == lvalue->symtree->n.sym->ns)
- warn = true;
+ {
+ warn = true;
+ break;
+ }
if (warn)
- gfc_warning ("Pointer at %L in pointer assignment might outlive the "
+ 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;
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)
- gfc_add_full_array_ref (lval, 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 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;
+}
+
+
/* Walk an expression tree and check each variable encountered for being typed.
If strict is not set, a top-level variable is tolerated untyped in -std=gnu
mode as is a basic arithmetic expression using those; this is for things in
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)
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;
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;
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,
bool own_scope, const char* context)
{
bool is_pointer;
bool check_intentin;
bool ptr_component;
- bool unlimited;
symbol_attribute attr;
gfc_ref* ref;
+ int i;
if (e->expr_type == EXPR_VARIABLE)
{
sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym;
}
- unlimited = e->ts.type == BT_CLASS && UNLIMITED_POLY (sym);
-
attr = gfc_expr_attr (e);
if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer)
{
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
component references to the last one. */
is_pointer = (attr.pointer || attr.proc_pointer);
- if (pointer && !is_pointer && !unlimited)
+ if (pointer && !is_pointer)
{
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
component. Note that (normal) assignment to procedure pointers is not
possible. */
check_intentin = !own_scope;
- ptr_component = (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+ 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;
}
}
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;
}
}
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, 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