/* Routines for manipulation of expression nodes.
- Copyright (C) 2000-2013 Free Software Foundation, Inc.
+ Copyright (C) 2000-2014 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "config.h"
#include "system.h"
#include "coretypes.h"
+#include "flags.h"
#include "gfortran.h"
#include "arith.h"
#include "match.h"
goto depart;
}
- e = gfc_copy_expr (ar->start[i]);
+ e = ar->start[i];
if (e->expr_type != EXPR_CONSTANT)
{
cons = NULL;
mpz_clear (offset);
mpz_clear (span);
mpz_clear (tmp);
- if (e)
- gfc_free_expr (e);
*rval = cons;
return t;
}
case EXPR_COMPCALL:
case EXPR_PPC:
- gcc_unreachable ();
break;
}
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);
{
gfc_intrinsic_sym* isym;
- gfc_symbol* sym;
+ gfc_symbol* sym = e->symtree->n.sym;
+
+ /* Special case for IEEE_SELECTED_REAL_KIND from the intrinsic
+ module IEEE_ARITHMETIC, which is allowed in initialization
+ expressions. */
+ if (!strcmp(sym->name, "ieee_selected_real_kind")
+ && sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
+ {
+ gfc_expr *new_expr = gfc_simplify_ieee_selected_real_kind (e);
+ if (new_expr)
+ {
+ gfc_replace_expr (e, new_expr);
+ t = true;
+ break;
+ }
+ }
- sym = e->symtree->n.sym;
if (!gfc_is_intrinsic (sym, 0, e->where)
|| (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
{
}
/* 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 "
"assignment at %L", &rvalue->where);
if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
{
int rc;
- if (gfc_option.warn_surprising)
+ if (warn_surprising)
gfc_warning ("BOZ literal at %L is bitwise transferred "
"non-integer symbol '%s'", &rvalue->where,
lvalue->symtree->n.sym->name);
if (rvalue->expr_type == EXPR_CONSTANT && lvalue->ts.type == rvalue->ts.type
&& (lvalue->ts.type == BT_REAL || lvalue->ts.type == BT_COMPLEX))
{
- if (lvalue->ts.kind < rvalue->ts.kind && gfc_option.gfc_warn_conversion)
+ if (lvalue->ts.kind < rvalue->ts.kind && warn_conversion)
{
/* As a special bonus, don't warn about REAL rvalues which are not
changed by the conversion if -Wconversion is specified. */
gfc_typename (&lvalue->ts), &rvalue->where);
}
- else if (gfc_option.warn_conversion_extra
- && lvalue->ts.kind > rvalue->ts.kind)
+ else if (warn_conversion_extra && lvalue->ts.kind > rvalue->ts.kind)
{
gfc_warning ("Conversion from %s to %s at %L",
gfc_typename (&rvalue->ts),
}
else if (rvalue->expr_type == EXPR_FUNCTION)
{
- s2 = rvalue->symtree->n.sym->result;
+ if (rvalue->value.function.esym)
+ s2 = rvalue->value.function.esym->result;
+ else
+ s2 = rvalue->symtree->n.sym->result;
+
name = s2->name;
}
else
return false;
}
- if (!gfc_compare_interfaces (s2, s1, name, 0, 1,
- err, sizeof(err), NULL, NULL))
+ /* Check F2008Cor2, C729. */
+ if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN
+ && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function)
{
- gfc_error ("Interface mismatch in procedure pointer assignment "
- "at %L: %s", &rvalue->where, err);
+ gfc_error ("Procedure pointer target '%s' at %L must be either an "
+ "intrinsic, host or use associated, referenced or have "
+ "the EXTERNAL attribute", s2->name, &rvalue->where);
return false;
}
return 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 (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))
{
}
/* 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
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 "
r = gfc_check_assign (&lvalue, rvalue, 1);
free (lvalue.symtree);
+ free (lvalue.ref);
if (!r)
return r;
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;
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;
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)
{
/* 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)"
}
}
+ /* Check for same value in vector expression subscript. */
+
+ if (e->rank > 0)
+ for (ref = e->ref; ref != NULL; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
+ for (i = 0; i < GFC_MAX_DIMENSIONS
+ && ref->u.ar.dimen_type[i] != 0; i++)
+ if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+ {
+ gfc_expr *arr = ref->u.ar.start[i];
+ if (arr->expr_type == EXPR_ARRAY)
+ {
+ gfc_constructor *c, *n;
+ gfc_expr *ec, *en;
+
+ for (c = gfc_constructor_first (arr->value.constructor);
+ c != NULL; c = gfc_constructor_next (c))
+ {
+ if (c == NULL || c->iterator != NULL)
+ continue;
+
+ ec = c->expr;
+
+ for (n = gfc_constructor_next (c); n != NULL;
+ n = gfc_constructor_next (n))
+ {
+ if (n->iterator != NULL)
+ continue;
+
+ en = n->expr;
+ if (gfc_dep_compare_expr (ec, en) == 0)
+ {
+ if (context)
+ gfc_error_now_1 ("Elements with the same value "
+ "at %L and %L in vector "
+ "subscript in a variable "
+ "definition context (%s)",
+ &(ec->where), &(en->where),
+ context);
+ return false;
+ }
+ }
+ }
+ }
+ }
+
return true;
}
projects / gcc.git / blobdiff