/* Routines for manipulation of expression nodes.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Andy Vaught
static try
simplify_constructor (gfc_constructor *c, int type)
{
+ gfc_expr *p;
+
for (; c; c = c->next)
{
if (c->iterator
|| gfc_simplify_expr (c->iterator->step, type) == FAILURE))
return FAILURE;
- if (c->expr && gfc_simplify_expr (c->expr, type) == FAILURE)
- return FAILURE;
+ if (c->expr)
+ {
+ /* Try and simplify a copy. Replace the original if successful
+ but keep going through the constructor at all costs. Not
+ doing so can make a dog's dinner of complicated things. */
+ p = gfc_copy_expr (c->expr);
+
+ if (gfc_simplify_expr (p, type) == FAILURE)
+ {
+ gfc_free_expr (p);
+ continue;
+ }
+
+ gfc_replace_expr (c->expr, p);
+ }
}
return SUCCESS;
cons = NULL;
goto depart;
}
-
- /* Check the bounds. */
- if (ar->as->upper[i]
- && (mpz_cmp (e->value.integer, ar->as->upper[i]->value.integer) > 0
- || mpz_cmp (e->value.integer,
- ar->as->lower[i]->value.integer) < 0))
+ /* Check the bounds. */
+ if ((ar->as->upper[i]
+ && ar->as->upper[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp (e->value.integer,
+ ar->as->upper[i]->value.integer) > 0)
+ ||
+ (ar->as->lower[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp (e->value.integer,
+ ar->as->lower[i]->value.integer) < 0))
{
- gfc_error ("index in dimension %d is out of bounds "
+ gfc_error ("Index in dimension %d is out of bounds "
"at %L", i + 1, &ar->c_where[i]);
cons = NULL;
t = FAILURE;
mpz_mul (span, span, tmp);
}
- if (cons)
- {
- for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
- {
- if (cons->iterator)
- {
- cons = NULL;
- goto depart;
- }
- cons = cons->next;
- }
- }
+ for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
+ {
+ if (cons)
+ {
+ if (cons->iterator)
+ {
+ cons = NULL;
+
+ goto depart;
+ }
+ cons = cons->next;
+ }
+ }
depart:
mpz_clear (delta);
cons = base;
}
- while (mpz_cmp (ptr, index) > 0)
+ while (cons && cons->next && mpz_cmp (ptr, index) > 0)
{
mpz_add_ui (index, index, one);
cons = cons->next;
|| !e->value.function.isym->elemental)
return MATCH_NO;
- if ((e->ts.type != BT_INTEGER || e->ts.type != BT_CHARACTER)
+ 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)
if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
{
- t = simplify_parameter_variable (e, 0);
+ /* A PARAMETER shall not be used to define itself, i.e.
+ REAL, PARAMETER :: x = transfer(0, x)
+ 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;
+ }
+ else
+ t = simplify_parameter_variable (e, 0);
+
break;
}
e->symtree->n.sym->name, &e->where);
break;
+ case AS_EXPLICIT:
+ gfc_error ("Array '%s' at %L is a variable, which does "
+ "not reduce to a constant expression",
+ e->symtree->n.sym->name, &e->where);
+ break;
+
default:
gcc_unreachable();
}
if (sym->attr.in_common
|| sym->attr.use_assoc
|| sym->attr.dummy
+ || sym->attr.implied_index
|| sym->ns != gfc_current_ns
|| (sym->ns->proc_name != NULL
&& sym->ns->proc_name->attr.flavor == FL_MODULE)
bad_proc = true;
}
+ /* (iv) Host associated and not the function symbol or the
+ parent result. This picks up sibling references, which
+ cannot be entries. */
+ if (!sym->attr.entry
+ && sym->ns == gfc_current_ns->parent
+ && sym != gfc_current_ns->proc_name
+ && sym != gfc_current_ns->parent->proc_name->result)
+ bad_proc = true;
+
if (bad_proc)
{
gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
/* 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);
- gfc_convert_boz (rvalue, &lvalue->ts);
+ if (!gfc_convert_boz (rvalue, &lvalue->ts))
+ return FAILURE;
+ 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);
+ 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);
+ 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;
+ }
}
if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
return SUCCESS;
- gfc_error ("Incompatible types in assignment at %L, %s to %s",
- &rvalue->where, gfc_typename (&rvalue->ts),
+ gfc_error ("Incompatible types in assignment at %L; attempted assignment "
+ "of %s to %s", &rvalue->where, gfc_typename (&rvalue->ts),
gfc_typename (&lvalue->ts));
return FAILURE;
if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
{
- gfc_error ("Different types in pointer assignment at %L",
- &lvalue->where);
+ 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;
}
projects / gcc.git / blobdiff