&& !(comp->attr.pointer || comp->attr.allocatable
|| comp->attr.proc_pointer
|| (comp->ts.type == BT_CLASS
- && (CLASS_DATA (comp)->attr.pointer
+ && (CLASS_DATA (comp)->attr.class_pointer
|| CLASS_DATA (comp)->attr.allocatable))))
{
t = FAILURE;
gfc_global_used (gsym, where);
if (gfc_option.flag_whole_file
- && sym->attr.if_source == IFSRC_UNKNOWN
+ && (sym->attr.if_source == IFSRC_UNKNOWN
+ || sym->attr.if_source == IFSRC_IFBODY)
&& gsym->type != GSYM_UNKNOWN
&& gsym->ns
&& gsym->ns->resolved != -1
&& not_in_recursive (sym, gsym->ns)
&& not_entry_self_reference (sym, gsym->ns))
{
+ gfc_symbol *def_sym;
+
/* Resolve the gsymbol namespace if needed. */
if (!gsym->ns->resolved)
{
}
}
+ def_sym = gsym->ns->proc_name;
+ if (def_sym->attr.entry_master)
+ {
+ gfc_entry_list *entry;
+ for (entry = gsym->ns->entries; entry; entry = entry->next)
+ if (strcmp (entry->sym->name, sym->name) == 0)
+ {
+ def_sym = entry->sym;
+ break;
+ }
+ }
+
/* Differences in constant character lengths. */
if (sym->attr.function && sym->ts.type == BT_CHARACTER)
{
long int l1 = 0, l2 = 0;
gfc_charlen *cl1 = sym->ts.u.cl;
- gfc_charlen *cl2 = gsym->ns->proc_name->ts.u.cl;
+ gfc_charlen *cl2 = def_sym->ts.u.cl;
if (cl1 != NULL
&& cl1->length != NULL
/* Type mismatch of function return type and expected type. */
if (sym->attr.function
- && !gfc_compare_types (&sym->ts, &gsym->ns->proc_name->ts))
+ && !gfc_compare_types (&sym->ts, &def_sym->ts))
gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
sym->name, &sym->declared_at, gfc_typename (&sym->ts),
- gfc_typename (&gsym->ns->proc_name->ts));
+ gfc_typename (&def_sym->ts));
- if (gsym->ns->proc_name->formal)
+ if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
{
- gfc_formal_arglist *arg = gsym->ns->proc_name->formal;
+ gfc_formal_arglist *arg = def_sym->formal;
for ( ; arg; arg = arg->next)
if (!arg->sym)
continue;
}
}
- if (gsym->ns->proc_name->attr.function)
+ if (def_sym->attr.function)
{
/* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
- if (gsym->ns->proc_name->as
- && gsym->ns->proc_name->as->rank
- && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank))
+ if (def_sym->as && def_sym->as->rank
+ && (!sym->as || sym->as->rank != def_sym->as->rank))
gfc_error ("The reference to function '%s' at %L either needs an "
"explicit INTERFACE or the rank is incorrect", sym->name,
where);
/* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
- if (gsym->ns->proc_name->result->attr.pointer
- || gsym->ns->proc_name->result->attr.allocatable)
+ if ((def_sym->result->attr.pointer
+ || def_sym->result->attr.allocatable)
+ && (sym->attr.if_source != IFSRC_IFBODY
+ || def_sym->result->attr.pointer
+ != sym->result->attr.pointer
+ || def_sym->result->attr.allocatable
+ != sym->result->attr.allocatable))
gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
"result must have an explicit interface", sym->name,
where);
/* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
- if (sym->ts.type == BT_CHARACTER
- && gsym->ns->proc_name->ts.u.cl->length != NULL)
+ if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
+ && def_sym->ts.u.cl->length != NULL)
{
gfc_charlen *cl = sym->ts.u.cl;
}
/* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
- if (gsym->ns->proc_name->attr.elemental)
+ if (def_sym->attr.elemental && !sym->attr.elemental)
{
gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
"interface", sym->name, &sym->declared_at);
}
/* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
- if (gsym->ns->proc_name->attr.is_bind_c)
+ if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
{
gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
"an explicit interface", sym->name, &sym->declared_at);
&& !(gfc_option.warn_std & GFC_STD_GNU)))
gfc_errors_to_warnings (1);
- gfc_procedure_use (gsym->ns->proc_name, actual, where);
+ if (sym->attr.if_source != IFSRC_IFBODY)
+ gfc_procedure_use (def_sym, actual, where);
gfc_errors_to_warnings (0);
}
&& !(sym->attr.intrinsic
|| gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
&& sym->attr.proc != PROC_ST_FUNCTION
+ && !sym->attr.proc_pointer
&& !sym->attr.use_assoc
&& sym->name)
return true;
{
char name[GFC_MAX_SYMBOL_LEN + 1];
char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
- int optional_arg = 0, is_pointer = 0;
+ int optional_arg = 0;
gfc_try retval = SUCCESS;
gfc_symbol *args_sym;
gfc_typespec *arg_ts;
+ symbol_attribute arg_attr;
if (args->expr->expr_type == EXPR_CONSTANT
|| args->expr->expr_type == EXPR_OP
and not necessarily that of the expr symbol (args_sym), because
the actual expression could be a part-ref of the expr symbol. */
arg_ts = &(args->expr->ts);
-
- is_pointer = gfc_is_data_pointer (args->expr);
+ arg_attr = gfc_expr_attr (args->expr);
if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
else if (sym->intmod_sym_id == ISOCBINDING_LOC)
{
/* Make sure we have either the target or pointer attribute. */
- if (!args_sym->attr.target && !is_pointer)
+ if (!arg_attr.target && !arg_attr.pointer)
{
gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
"a TARGET or an associated pointer",
}
}
}
- else if (is_pointer
+ else if (arg_attr.pointer
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
{
/* Case 1c, section 15.1.2.5, J3/04-007: an associated
&(args->expr->where));
retval = FAILURE;
}
+ else if (arg_ts->type == BT_CLASS)
+ {
+ gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
+ "polymorphic", args_sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
}
}
else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
sym->entry_id = current_entry_id + 1;
}
+ /* If a symbol has been host_associated mark it. This is used latter,
+ to identify if aliasing is possible via host association. */
+ if (sym->attr.flavor == FL_VARIABLE
+ && gfc_current_ns->parent
+ && (gfc_current_ns->parent == sym->ns
+ || (gfc_current_ns->parent->parent
+ && gfc_current_ns->parent->parent == sym->ns)))
+ sym->attr.host_assoc = 1;
+
resolve_procedure:
if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
t = FAILURE;
if (matches)
{
e->value.compcall.tbp = g->specific;
+ genname = g->specific_st->name;
/* Pass along the name for CLASS methods, where the vtab
procedure pointer component has to be referenced. */
if (name)
- *name = g->specific_st->name;
+ *name = genname;
goto success;
}
}
success:
/* Make sure that we have the right specific instance for the name. */
- genname = e->value.compcall.tbp->u.specific->name;
-
- /* Is the symtree name a "unique name". */
- if (*genname == '@')
- genname = e->value.compcall.tbp->u.specific->n.sym->name;
-
derived = get_declared_from_expr (NULL, NULL, e);
st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
gfc_ref *class_ref;
gfc_symtree *st;
const char *name;
- const char *genname;
gfc_typespec ts;
+ gfc_expr *expr;
st = e->symtree;
+
+ /* Deal with typebound operators for CLASS objects. */
+ expr = e->value.compcall.base_object;
+ if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
+ && e->value.compcall.name)
+ {
+ /* Since the typebound operators are generic, we have to ensure
+ that any delays in resolution are corrected and that the vtab
+ is present. */
+ ts = expr->symtree->n.sym->ts;
+ declared = ts.u.derived;
+ c = gfc_find_component (declared, "$vptr", true, true);
+ if (c->ts.u.derived == NULL)
+ c->ts.u.derived = gfc_find_derived_vtab (declared);
+
+ if (resolve_compcall (e, &name) == FAILURE)
+ return FAILURE;
+
+ /* Use the generic name if it is there. */
+ name = name ? name : e->value.function.esym->name;
+ e->symtree = expr->symtree;
+ expr->symtree->n.sym->ts.u.derived = declared;
+ gfc_add_component_ref (e, "$vptr");
+ gfc_add_component_ref (e, name);
+ e->value.function.esym = NULL;
+ return SUCCESS;
+ }
+
if (st == NULL)
return resolve_compcall (e, NULL);
c = gfc_find_component (declared, "$data", true, true);
declared = c->ts.u.derived;
- /* Keep the generic name so that the vtab reference can be made. */
- genname = NULL;
- if (e->value.compcall.tbp->is_generic)
- genname = e->value.compcall.name;
-
/* Treat the call as if it is a typebound procedure, in order to roll
out the correct name for the specific function. */
- resolve_compcall (e, &name);
+ if (resolve_compcall (e, &name) == FAILURE)
+ return FAILURE;
ts = e->ts;
/* Then convert the expression to a procedure pointer component call. */
/* '$vptr' points to the vtab, which contains the procedure pointers. */
gfc_add_component_ref (e, "$vptr");
- if (genname)
- {
- /* A generic procedure needs the subsidiary vtabs and vtypes for
- the specific procedures to have been build. */
- gfc_symbol *vtab;
- vtab = gfc_find_derived_vtab (declared, true);
- gcc_assert (vtab);
- gfc_add_component_ref (e, genname);
- }
gfc_add_component_ref (e, name);
/* Recover the typespec for the expression. This is really only
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
- const char *genname;
const char *name;
gfc_typespec ts;
+ gfc_expr *expr;
st = code->expr1->symtree;
+
+ /* Deal with typebound operators for CLASS objects. */
+ expr = code->expr1->value.compcall.base_object;
+ if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
+ && code->expr1->value.compcall.name)
+ {
+ /* Since the typebound operators are generic, we have to ensure
+ that any delays in resolution are corrected and that the vtab
+ is present. */
+ ts = expr->symtree->n.sym->ts;
+ declared = ts.u.derived;
+ c = gfc_find_component (declared, "$vptr", true, true);
+ if (c->ts.u.derived == NULL)
+ c->ts.u.derived = gfc_find_derived_vtab (declared);
+
+ if (resolve_typebound_call (code, &name) == FAILURE)
+ return FAILURE;
+
+ /* Use the generic name if it is there. */
+ name = name ? name : code->expr1->value.function.esym->name;
+ code->expr1->symtree = expr->symtree;
+ expr->symtree->n.sym->ts.u.derived = declared;
+ gfc_add_component_ref (code->expr1, "$vptr");
+ gfc_add_component_ref (code->expr1, name);
+ code->expr1->value.function.esym = NULL;
+ return SUCCESS;
+ }
+
if (st == NULL)
return resolve_typebound_call (code, NULL);
return FAILURE;
/* Get the CLASS declared type. */
- declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
+ get_declared_from_expr (&class_ref, &new_ref, code->expr1);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
{
gfc_free_ref_list (new_ref);
return resolve_typebound_call (code, NULL);
- }
-
- c = gfc_find_component (declared, "$data", true, true);
- declared = c->ts.u.derived;
-
- /* Keep the generic name so that the vtab reference can be made. */
- genname = NULL;
- if (code->expr1->value.compcall.tbp->is_generic)
- genname = code->expr1->value.compcall.name;
+ }
- resolve_typebound_call (code, &name);
+ if (resolve_typebound_call (code, &name) == FAILURE)
+ return FAILURE;
ts = code->expr1->ts;
/* Then convert the expression to a procedure pointer component call. */
/* '$vptr' points to the vtab, which contains the procedure pointers. */
gfc_add_component_ref (code->expr1, "$vptr");
- if (genname)
- {
- /* A generic procedure needs the subsidiary vtabs and vtypes for
- the specific procedures to have been build. */
- gfc_symbol *vtab;
- vtab = gfc_find_derived_vtab (declared, true);
- gcc_assert (vtab);
- gfc_add_component_ref (code->expr1, genname);
- }
gfc_add_component_ref (code->expr1, name);
/* Recover the typespec for the expression. This is really only
{
expression_rank (e);
if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
- gfc_expand_constructor (e);
+ gfc_expand_constructor (e, false);
}
/* This provides the opportunity for the length of constructors with
{
/* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
here rather then add a duplicate test for it above. */
- gfc_expand_constructor (e);
+ gfc_expand_constructor (e, false);
t = gfc_resolve_character_array_constructor (e);
}
if (sym->ts.type == BT_CLASS)
{
allocatable = CLASS_DATA (sym)->attr.allocatable;
- pointer = CLASS_DATA (sym)->attr.pointer;
+ pointer = CLASS_DATA (sym)->attr.class_pointer;
}
else
{
if (c->ts.type == BT_CLASS)
{
allocatable = CLASS_DATA (c)->attr.allocatable;
- pointer = CLASS_DATA (c)->attr.pointer;
+ pointer = CLASS_DATA (c)->attr.class_pointer;
}
else
{
if (sym->ts.type == BT_CLASS)
{
allocatable = CLASS_DATA (sym)->attr.allocatable;
- pointer = CLASS_DATA (sym)->attr.pointer;
+ pointer = CLASS_DATA (sym)->attr.class_pointer;
dimension = CLASS_DATA (sym)->attr.dimension;
codimension = CLASS_DATA (sym)->attr.codimension;
is_abstract = CLASS_DATA (sym)->attr.abstract;
if (c->ts.type == BT_CLASS)
{
allocatable = CLASS_DATA (c)->attr.allocatable;
- pointer = CLASS_DATA (c)->attr.pointer;
+ pointer = CLASS_DATA (c)->attr.class_pointer;
dimension = CLASS_DATA (c)->attr.dimension;
codimension = CLASS_DATA (c)->attr.codimension;
is_abstract = CLASS_DATA (c)->attr.abstract;
for (p = code->ext.alloc.list; p; p = p->next)
if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
- gfc_error ("Stat-variable at %L shall not be %sd within "
- "the same %s statement", &stat->where, fcn, fcn);
+ {
+ gfc_ref *ref1, *ref2;
+ bool found = true;
+
+ for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
+ ref1 = ref1->next, ref2 = ref2->next)
+ {
+ if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
+ continue;
+ if (ref1->u.c.component->name != ref2->u.c.component->name)
+ {
+ found = false;
+ break;
+ }
+ }
+
+ if (found)
+ {
+ gfc_error ("Stat-variable at %L shall not be %sd within "
+ "the same %s statement", &stat->where, fcn, fcn);
+ break;
+ }
+ }
}
/* Check the errmsg variable. */
for (p = code->ext.alloc.list; p; p = p->next)
if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
- gfc_error ("Errmsg-variable at %L shall not be %sd within "
- "the same %s statement", &errmsg->where, fcn, fcn);
+ {
+ gfc_ref *ref1, *ref2;
+ bool found = true;
+
+ for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
+ ref1 = ref1->next, ref2 = ref2->next)
+ {
+ if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
+ continue;
+ if (ref1->u.c.component->name != ref2->u.c.component->name)
+ {
+ found = false;
+ break;
+ }
+ }
+
+ if (found)
+ {
+ gfc_error ("Errmsg-variable at %L shall not be %sd within "
+ "the same %s statement", &errmsg->where, fcn, fcn);
+ break;
+ }
+ }
}
/* Check that an allocate-object appears only once in the statement.
new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
- vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived, true);
+ vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
{
case BT_INTEGER:
if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
- mpz_init_set_si (init_expr->value.integer,
+ mpz_set_si (init_expr->value.integer,
gfc_option.flag_init_integer_value);
else
{
break;
case BT_REAL:
- mpfr_init (init_expr->value.real);
switch (gfc_option.flag_init_real)
{
case GFC_INIT_REAL_SNAN:
break;
case BT_COMPLEX:
- mpc_init2 (init_expr->value.complex, mpfr_get_default_prec());
switch (gfc_option.flag_init_real)
{
case GFC_INIT_REAL_SNAN:
if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
{
/* F03:C502. */
- if (!gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
+ if (sym->attr.class_ok
+ && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
{
gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
CLASS_DATA (sym)->ts.u.derived->name, sym->name,
gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true);
if (vptr->ts.u.derived == NULL)
{
- gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived, false);
+ gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
gcc_assert (vtab);
vptr->ts.u.derived = vtab->ts.u.derived;
}
return FAILURE;
}
+ /* F2008, C448. */
+ if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
+ {
+ gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
+ "is not an array pointer", c->name, &c->loc);
+ return FAILURE;
+ }
+
if (c->attr.proc_pointer && c->ts.interface)
{
if (c->ts.interface->attr.procedure && !sym->attr.vtype)
c->ts.u.cl = cl;
}
}
- else if (c->ts.interface->name[0] != '\0' && !sym->attr.vtype)
+ else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
{
gfc_error ("Interface '%s' of procedure pointer component "
"'%s' at %L must be explicit", c->ts.interface->name,
return FAILURE;
}
- if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.pointer
+ if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
&& CLASS_DATA (c)->ts.u.derived->components == NULL
&& !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
{
/* C437. */
if (c->ts.type == BT_CLASS
- && !(CLASS_DATA (c)->attr.pointer || CLASS_DATA (c)->attr.allocatable))
+ && !(CLASS_DATA (c)->attr.class_pointer
+ || CLASS_DATA (c)->attr.allocatable))
{
gfc_error ("Component '%s' with CLASS at %L must be allocatable "
"or pointer", c->name, &c->loc);
/* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
all DEFERRED bindings are overridden. */
if (super_type && super_type->attr.abstract && !sym->attr.abstract
+ && !sym->attr.is_class
&& ensure_not_abstract (sym, super_type) == FAILURE)
return FAILURE;
sym->attr.pure = ifc->attr.pure;
sym->attr.elemental = ifc->attr.elemental;
sym->attr.dimension = ifc->attr.dimension;
+ sym->attr.contiguous = ifc->attr.contiguous;
sym->attr.recursive = ifc->attr.recursive;
sym->attr.always_explicit = ifc->attr.always_explicit;
sym->attr.ext_attr |= ifc->attr.ext_attr;
return;
}
+
+ /* F2008, C530. */
+ if (sym->attr.contiguous
+ && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
+ && !sym->attr.pointer)))
+ {
+ gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
+ "array pointer or an assumed-shape array", sym->name,
+ &sym->declared_at);
+ return;
+ }
+
if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
return;
sym->attr.dimension = sym->result->attr.dimension;
sym->attr.pointer = sym->result->attr.pointer;
sym->attr.allocatable = sym->result->attr.allocatable;
+ sym->attr.contiguous = sym->result->attr.contiguous;
}
}
}
gfc_current_ns = old_ns;
cs_base = old_cs_base;
ns->resolved = 1;
+
+ gfc_run_passes (ns);
}
OSDN Git Service
