t = gfc_convert_type (cons->expr, &comp->ts, 1);
}
+ /* For strings, the length of the constructor should be the same as
+ the one of the structure, ensure this if the lengths are known at
+ compile time and when we are dealing with PARAMETER or structure
+ constructors. */
+ if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
+ && comp->ts.u.cl->length
+ && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
+ && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
+ && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
+ && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
+ comp->ts.u.cl->length->value.integer) != 0)
+ {
+ if (cons->expr->expr_type == EXPR_VARIABLE
+ && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
+ {
+ /* Wrap the parameter in an array constructor (EXPR_ARRAY)
+ to make use of the gfc_resolve_character_array_constructor
+ machinery. The expression is later simplified away to
+ an array of string literals. */
+ gfc_expr *para = cons->expr;
+ cons->expr = gfc_get_expr ();
+ cons->expr->ts = para->ts;
+ cons->expr->where = para->where;
+ cons->expr->expr_type = EXPR_ARRAY;
+ cons->expr->rank = para->rank;
+ cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
+ gfc_constructor_append_expr (&cons->expr->value.constructor,
+ para, &cons->expr->where);
+ }
+ if (cons->expr->expr_type == EXPR_ARRAY)
+ {
+ gfc_constructor *p;
+ p = gfc_constructor_first (cons->expr->value.constructor);
+ if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
+ {
+ gfc_charlen *cl, *cl2;
+
+ cl2 = NULL;
+ for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
+ {
+ if (cl == cons->expr->ts.u.cl)
+ break;
+ cl2 = cl;
+ }
+
+ gcc_assert (cl);
+
+ if (cl2)
+ cl2->next = cl->next;
+
+ gfc_free_expr (cl->length);
+ gfc_free (cl);
+ }
+
+ cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ cons->expr->ts.u.cl->length_from_typespec = true;
+ cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
+ gfc_resolve_character_array_constructor (cons->expr);
+ }
+ }
+
if (cons->expr->expr_type == EXPR_NULL
&& !(comp->attr.pointer || comp->attr.allocatable
|| comp->attr.proc_pointer
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);
}
{
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)
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_symtree *st;
const char *name;
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);
gfc_symtree *st;
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;
+ }
if (resolve_typebound_call (code, &name) == FAILURE)
return FAILURE;
target_name = target->specific_st->name;
/* Defined for this type directly. */
- if (target->specific_st->n.tb)
+ if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
{
target->specific = target->specific_st->n.tb;
goto specific_found;
{
gfc_symbol* super_type;
gfc_component *c;
- int i;
super_type = gfc_get_derived_super_type (sym);
&& sym != c->ts.u.derived)
add_dt_to_dt_list (c->ts.u.derived);
- if (c->attr.pointer || c->attr.proc_pointer || c->attr.allocatable
- || c->as == NULL)
- continue;
-
- for (i = 0; i < c->as->rank; i++)
- {
- if (c->as->lower[i] == NULL
- || (resolve_index_expr (c->as->lower[i]) == FAILURE)
- || !gfc_is_constant_expr (c->as->lower[i])
- || c->as->upper[i] == NULL
- || (resolve_index_expr (c->as->upper[i]) == FAILURE)
- || !gfc_is_constant_expr (c->as->upper[i]))
- {
- gfc_error ("Component '%s' of '%s' at %L must have "
- "constant array bounds",
- c->name, sym->name, &c->loc);
- return FAILURE;
- }
- }
+ if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
+ || c->attr.proc_pointer
+ || c->attr.allocatable)) == FAILURE)
+ return FAILURE;
}
/* Resolve the type-bound procedures. */
{
this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
sym->name);
- sym->refs--;
- if (!sym->refs)
- gfc_free_symbol (sym);
+ gfc_release_symbol (sym);
symtree->n.sym->refs++;
this_symtree->n.sym = symtree->n.sym;
return;
gfc_current_ns = old_ns;
cs_base = old_cs_base;
ns->resolved = 1;
+
+ gfc_run_passes (ns);
}
OSDN Git Service
