/* Perform type resolution on the various structures.
Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
- 2010, 2011
+ 2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Andy Vaught
}
else if (!sym->attr.pointer)
{
- if (proc->attr.function && sym->attr.intent != INTENT_IN)
+ if (proc->attr.function && sym->attr.intent != INTENT_IN
+ && !sym->value)
proc->attr.implicit_pure = 0;
- if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
+ if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
+ && !sym->value)
proc->attr.implicit_pure = 0;
}
}
if (gfc_elemental (proc))
{
/* F08:C1289. */
- if (sym->attr.codimension)
+ if (sym->attr.codimension
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.codimension))
{
gfc_error ("Coarray dummy argument '%s' at %L to elemental "
"procedure", sym->name, &sym->declared_at);
continue;
}
- if (sym->as != NULL)
+ if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->as))
{
gfc_error ("Argument '%s' of elemental procedure at %L must "
"be scalar", sym->name, &sym->declared_at);
continue;
}
- if (sym->attr.allocatable)
+ if (sym->attr.allocatable
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.allocatable))
{
gfc_error ("Argument '%s' of elemental procedure at %L cannot "
"have the ALLOCATABLE attribute", sym->name,
continue;
}
- if (sym->attr.pointer)
+ if (sym->attr.pointer
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.class_pointer))
{
gfc_error ("Argument '%s' of elemental procedure at %L cannot "
"have the POINTER attribute", sym->name,
&& 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
+ && cons->expr->rank != 0
&& mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
comp->ts.u.cl->length->value.integer) != 0)
{
if (sym->intmod_sym_id)
isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
- else
+ else if (!sym->attr.subroutine)
isym = gfc_find_function (sym->name);
if (isym)
got_variable:
e->expr_type = EXPR_VARIABLE;
e->ts = sym->ts;
- if (sym->as != NULL)
+ if ((sym->as != NULL && sym->ts.type != BT_CLASS)
+ || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as))
{
- e->rank = sym->as->rank;
+ e->rank = sym->ts.type == BT_CLASS
+ ? CLASS_DATA (sym)->as->rank : sym->as->rank;
e->ref = gfc_get_ref ();
e->ref->type = REF_ARRAY;
e->ref->u.ar.type = AR_FULL;
- e->ref->u.ar.as = sym->as;
+ e->ref->u.ar.as = sym->ts.type == BT_CLASS
+ ? CLASS_DATA (sym)->as : sym->as;
}
/* Expressions are assigned a default ts.type of BT_PROCEDURE in
gfc_symbol **new_sym)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
- char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
int optional_arg = 0;
gfc_try retval = SUCCESS;
gfc_symbol *args_sym;
{
/* two args. */
sprintf (name, "%s_2", sym->name);
- sprintf (binding_label, "%s_2", sym->binding_label);
optional_arg = 1;
}
else
{
/* one arg. */
sprintf (name, "%s_1", sym->name);
- sprintf (binding_label, "%s_1", sym->binding_label);
optional_arg = 0;
}
/* Get a new symbol for the version of c_associated that
will get called. */
- *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
+ *new_sym = get_iso_c_sym (sym, name, NULL, optional_arg);
}
else if (sym->intmod_sym_id == ISOCBINDING_LOC
|| sym->intmod_sym_id == ISOCBINDING_FUNLOC)
{
sprintf (name, "%s", sym->name);
- sprintf (binding_label, "%s", sym->binding_label);
/* Error check the call. */
if (args->next != NULL)
static void
set_name_and_label (gfc_code *c, gfc_symbol *sym,
- char *name, char *binding_label)
+ char *name, const char **binding_label)
{
gfc_expr *arg = NULL;
char type;
sprintf (name, "%s_%c%d", sym->name, type, kind);
/* Set up the binding label as the given symbol's label plus
the type and kind. */
- sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
+ *binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type,
+ kind);
}
else
{
was, cause it should at least be found, and the missing
arg error will be caught by compare_parameters(). */
sprintf (name, "%s", sym->name);
- sprintf (binding_label, "%s", sym->binding_label);
+ *binding_label = sym->binding_label;
}
return;
gfc_symbol *new_sym;
/* this is fine, since we know the names won't use the max */
char name[GFC_MAX_SYMBOL_LEN + 1];
- char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+ const char* binding_label;
/* default to success; will override if find error */
match m = MATCH_YES;
if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
(sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
{
- set_name_and_label (c, sym, name, binding_label);
+ set_name_and_label (c, sym, name, &binding_label);
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
{
if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
{
gfc_symtree *st;
- gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
+ gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
sym = st ? st->n.sym : NULL;
if (sym && csym != sym
&& sym->ns == gfc_current_ns
goto cleanup;
}
- /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */
- if (base->rank > 0)
- {
- gfc_error ("Non-scalar base object at %L currently not implemented",
- &e->where);
- goto cleanup;
- }
-
return_value = SUCCESS;
cleanup:
e->ref = NULL;
e->value.compcall.actual = NULL;
+ /* If we find a deferred typebound procedure, check for derived types
+ that an overriding typebound procedure has not been missed. */
+ if (e->value.compcall.name
+ && !e->value.compcall.tbp->non_overridable
+ && e->value.compcall.base_object
+ && e->value.compcall.base_object->ts.type == BT_DERIVED)
+ {
+ gfc_symtree *st;
+ gfc_symbol *derived;
+
+ /* Use the derived type of the base_object. */
+ derived = e->value.compcall.base_object->ts.u.derived;
+ st = NULL;
+
+ /* If necessary, go throught the inheritance chain. */
+ while (!st && derived)
+ {
+ /* Look for the typebound procedure 'name'. */
+ if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
+ st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
+ e->value.compcall.name);
+ if (!st)
+ derived = gfc_get_derived_super_type (derived);
+ }
+
+ /* Now find the specific name in the derived type namespace. */
+ if (st && st->n.tb && st->n.tb->u.specific)
+ gfc_find_sym_tree (st->n.tb->u.specific->name,
+ derived->ns, 1, &st);
+ if (st)
+ *target = st;
+ }
return SUCCESS;
}
/* Get the ultimate declared type from an expression. In addition,
return the last class/derived type reference and the copy of the
- reference list. */
+ reference list. If check_types is set true, derived types are
+ identified as well as class references. */
static gfc_symbol*
get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
- gfc_expr *e)
+ gfc_expr *e, bool check_types)
{
gfc_symbol *declared;
gfc_ref *ref;
if (ref->type != REF_COMPONENT)
continue;
- if (ref->u.c.component->ts.type == BT_CLASS
- || ref->u.c.component->ts.type == BT_DERIVED)
+ if ((ref->u.c.component->ts.type == BT_CLASS
+ || (check_types && ref->u.c.component->ts.type == BT_DERIVED))
+ && ref->u.c.component->attr.flavor != FL_PROCEDURE)
{
declared = ref->u.c.component->ts.u.derived;
if (class_ref)
success:
/* Make sure that we have the right specific instance for the name. */
- derived = get_declared_from_expr (NULL, NULL, e);
+ derived = get_declared_from_expr (NULL, NULL, e, true);
st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
if (st)
overridable = !e->value.compcall.tbp->non_overridable;
if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
{
+ /* If the base_object is not a variable, the corresponding actual
+ argument expression must be stored in e->base_expression so
+ that the corresponding tree temporary can be used as the base
+ object in gfc_conv_procedure_call. */
+ if (expr->expr_type != EXPR_VARIABLE)
+ {
+ gfc_actual_arglist *args;
+
+ for (args= e->value.function.actual; args; args = args->next)
+ {
+ if (expr == args->expr)
+ expr = args->expr;
+ }
+ }
+
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
name = name ? name : e->value.function.esym->name;
e->symtree = expr->symtree;
e->ref = gfc_copy_ref (expr->ref);
+ get_declared_from_expr (&class_ref, NULL, e, false);
+
+ /* Trim away the extraneous references that emerge from nested
+ use of interface.c (extend_expr). */
+ if (class_ref && class_ref->next)
+ {
+ gfc_free_ref_list (class_ref->next);
+ class_ref->next = NULL;
+ }
+ else if (e->ref && !class_ref)
+ {
+ gfc_free_ref_list (e->ref);
+ e->ref = NULL;
+ }
+
gfc_add_vptr_component (e);
gfc_add_component_ref (e, name);
e->value.function.esym = NULL;
+ if (expr->expr_type != EXPR_VARIABLE)
+ e->base_expr = expr;
return SUCCESS;
}
return FAILURE;
/* Get the CLASS declared type. */
- declared = get_declared_from_expr (&class_ref, &new_ref, e);
+ declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
overridable = !code->expr1->value.compcall.tbp->non_overridable;
if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
{
+ /* If the base_object is not a variable, the corresponding actual
+ argument expression must be stored in e->base_expression so
+ that the corresponding tree temporary can be used as the base
+ object in gfc_conv_procedure_call. */
+ if (expr->expr_type != EXPR_VARIABLE)
+ {
+ gfc_actual_arglist *args;
+
+ args= code->expr1->value.function.actual;
+ for (; args; args = args->next)
+ if (expr == args->expr)
+ expr = args->expr;
+ }
+
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
name = name ? name : code->expr1->value.function.esym->name;
code->expr1->symtree = expr->symtree;
code->expr1->ref = gfc_copy_ref (expr->ref);
+
+ /* Trim away the extraneous references that emerge from nested
+ use of interface.c (extend_expr). */
+ get_declared_from_expr (&class_ref, NULL, code->expr1, false);
+ if (class_ref && class_ref->next)
+ {
+ gfc_free_ref_list (class_ref->next);
+ class_ref->next = NULL;
+ }
+ else if (code->expr1->ref && !class_ref)
+ {
+ gfc_free_ref_list (code->expr1->ref);
+ code->expr1->ref = NULL;
+ }
+
+ /* Now use the procedure in the vtable. */
gfc_add_vptr_component (code->expr1);
gfc_add_component_ref (code->expr1, name);
code->expr1->value.function.esym = NULL;
+ if (expr->expr_type != EXPR_VARIABLE)
+ code->expr1->base_expr = expr;
return SUCCESS;
}
return FAILURE;
/* Get the CLASS declared type. */
- get_declared_from_expr (&class_ref, &new_ref, code->expr1);
+ get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
}
else
{
- if (sym->ts.type == BT_CLASS)
+ if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
{
allocatable = CLASS_DATA (sym)->attr.allocatable;
pointer = CLASS_DATA (sym)->attr.class_pointer;
goto failure;
}
+ if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred)
+ {
+ int cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
+ code->ext.alloc.ts.u.cl->length);
+ if (cmp == 1 || cmp == -1 || cmp == -3)
+ {
+ gfc_error ("Allocating %s at %L with type-spec requires the same "
+ "character-length parameter as in the declaration",
+ sym->name, &e->where);
+ goto failure;
+ }
+ }
+
/* In the variable definition context checks, gfc_expr_attr is used
on the expression. This is fooled by the array specification
present in e, thus we have to eliminate that one temporarily. */
if (t == FAILURE)
goto failure;
- if (!code->expr3)
+ if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
+ && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
+ {
+ /* For class arrays, the initialization with SOURCE is done
+ using _copy and trans_call. It is convenient to exploit that
+ when the allocated type is different from the declared type but
+ no SOURCE exists by setting expr3. */
+ code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
+ }
+ else if (!code->expr3)
{
/* Set up default initializer if needed. */
gfc_typespec ts;
else if (code->ext.alloc.ts.type == BT_DERIVED)
ts = code->ext.alloc.ts;
gfc_find_derived_vtab (ts.u.derived);
+ if (dimension)
+ e = gfc_expr_to_initialize (e);
}
if (dimension == 0 && codimension == 0)
}
}
- /* Check that an allocate-object appears only once in the statement.
- FIXME: Checking derived types is disabled. */
+ /* Check that an allocate-object appears only once in the statement. */
+
for (p = code->ext.alloc.list; p; p = p->next)
{
pe = p->expr;
if (pr->next && qr->next)
{
+ int i;
gfc_array_ref *par = &(pr->u.ar);
gfc_array_ref *qar = &(qr->u.ar);
- if (gfc_dep_compare_expr (par->start[0],
- qar->start[0]) != 0)
- break;
+
+ for (i=0; i<par->dimen; i++)
+ {
+ if ((par->start[i] != NULL
+ || qar->start[i] != NULL)
+ && gfc_dep_compare_expr (par->start[i],
+ qar->start[i]) != 0)
+ goto break_label;
+ }
}
}
else
pr = pr->next;
qr = qr->next;
}
+ break_label:
+ ;
}
}
}
return;
}
- if (case_expr->rank != 0)
- {
- gfc_error ("Argument of SELECT statement at %L must be a scalar "
- "expression", &case_expr->where);
-
- /* Punt. */
- return;
- }
-
-
/* Raise a warning if an INTEGER case value exceeds the range of
the case-expr. Later, all expressions will be promoted to the
largest kind of all case-labels. */
sym->attr.asynchronous = tsym->attr.asynchronous;
sym->attr.volatile_ = tsym->attr.volatile_;
- sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
+ sym->attr.target = tsym->attr.target
+ || gfc_expr_attr (target).pointer;
}
/* Get type if this was not already set. Note that it can be
return;
}
+ if (!code->expr1->symtree->n.sym->attr.class_ok)
+ return;
+
if (code->expr2)
{
if (code->expr1->symtree->n.sym->attr.untyped)
assoc = gfc_get_association_list ();
assoc->st = code->expr1->symtree;
assoc->target = gfc_copy_expr (code->expr2);
+ assoc->target->where = code->expr2->where;
/* assoc->variable will be set by resolve_assoc_var. */
code->ext.block.assoc = assoc;
st = gfc_find_symtree (ns->sym_root, name);
gcc_assert (st->n.sym->assoc);
st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
+ st->n.sym->assoc->target->where = code->expr1->where;
if (c->ts.type == BT_DERIVED)
gfc_add_data_component (st->n.sym->assoc->target);
and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
if (lhs->ts.type == BT_CLASS)
{
- gfc_error ("Variable must not be polymorphic in assignment at %L",
- &lhs->where);
+ gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
+ "%L - check that there is a matching specific subroutine "
+ "for '=' operator", &lhs->where);
return false;
}
{
gfc_try t;
- if (sym->value == NULL || sym->attr.use_assoc)
+ if (sym->value == NULL)
return;
if (sym->value->expr_type == EXPR_STRUCTURE)
{
gfc_gsymbol *binding_label_gsym;
gfc_gsymbol *comm_name_gsym;
+ const char * bind_label = comm_block_tree->n.common->binding_label
+ ? comm_block_tree->n.common->binding_label : "";
/* See if a global symbol exists by the common block's name. It may
be NULL if the common block is use-associated. */
if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
gfc_error ("Binding label '%s' for common block '%s' at %L collides "
"with the global entity '%s' at %L",
- comm_block_tree->n.common->binding_label,
+ bind_label,
comm_block_tree->n.common->name,
&(comm_block_tree->n.common->where),
comm_name_gsym->name, &(comm_name_gsym->where));
as expected. */
if (comm_name_gsym->binding_label == NULL)
/* No binding label for common block stored yet; save this one. */
- comm_name_gsym->binding_label =
- comm_block_tree->n.common->binding_label;
- else
- if (strcmp (comm_name_gsym->binding_label,
- comm_block_tree->n.common->binding_label) != 0)
+ comm_name_gsym->binding_label = bind_label;
+ else if (strcmp (comm_name_gsym->binding_label, bind_label) != 0)
{
/* Common block names match but binding labels do not. */
gfc_error ("Binding label '%s' for common block '%s' at %L "
"does not match the binding label '%s' for common "
"block '%s' at %L",
- comm_block_tree->n.common->binding_label,
+ bind_label,
comm_block_tree->n.common->name,
&(comm_block_tree->n.common->where),
comm_name_gsym->binding_label,
/* There is no binding label (NAME="") so we have nothing further to
check and nothing to add as a global symbol for the label. */
- if (comm_block_tree->n.common->binding_label[0] == '\0' )
+ if (!comm_block_tree->n.common->binding_label)
return;
binding_label_gsym =
int has_error = 0;
if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
- && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
+ && sym->attr.flavor != FL_DERIVED && sym->binding_label)
{
gfc_gsymbol *bind_c_sym;
}
if (has_error != 0)
- /* Clear the binding label to prevent checking multiple times. */
- sym->binding_label[0] = '\0';
+ /* Clear the binding label to prevent checking multiple times. */
+ sym->binding_label = NULL;
}
else if (bind_c_sym == NULL)
{
int i;
/* These symbols should never have a default initialization. */
- if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
+ if (sym->attr.allocatable
|| sym->attr.external
|| sym->attr.dummy
|| sym->attr.pointer
|| sym->attr.data
|| sym->module
|| sym->attr.cray_pointee
- || sym->attr.cray_pointer)
+ || sym->attr.cray_pointer
+ || sym->assoc)
return NULL;
/* Now we'll try to build an initializer expression. */
gfc_free_expr (init_expr);
init_expr = NULL;
}
+ if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
+ && sym->ts.u.cl->length)
+ {
+ gfc_actual_arglist *arg;
+ init_expr = gfc_get_expr ();
+ init_expr->where = sym->declared_at;
+ init_expr->ts = sym->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 (sym->ts.kind, &sym->declared_at,
+ 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 (sym->ts.u.cl->length);
+ init_expr->value.function.actual = arg;
+ }
break;
default:
if (init == NULL)
return;
- /* For saved variables, we don't want to add an initializer at
- function entry, so we just add a static initializer. */
+ /* For saved variables, we don't want to add an initializer at function
+ entry, so we just add a static initializer. Note that automatic variables
+ are stack allocated even with -fno-automatic. */
if (sym->attr.save || sym->ns->save_all
- || gfc_option.flag_max_stack_var_size == 0)
+ || (gfc_option.flag_max_stack_var_size == 0
+ && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))
{
/* Don't clobber an existing initializer! */
gcc_assert (sym->value == NULL);
static gfc_try
resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
{
+ gfc_array_spec *as;
+
/* Avoid double diagnostics for function result symbols. */
if ((sym->result || sym->attr.result) && !sym->attr.dummy
&& (sym->ns != gfc_current_ns))
return SUCCESS;
+ if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+ as = CLASS_DATA (sym)->as;
+ else
+ as = sym->as;
+
/* Constraints on deferred shape variable. */
- if (sym->as == NULL || sym->as->type != AS_DEFERRED)
+ if (as == NULL || as->type != AS_DEFERRED)
{
- if (sym->attr.allocatable)
+ bool pointer, allocatable, dimension;
+
+ if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
{
- if (sym->attr.dimension)
+ pointer = CLASS_DATA (sym)->attr.class_pointer;
+ allocatable = CLASS_DATA (sym)->attr.allocatable;
+ dimension = CLASS_DATA (sym)->attr.dimension;
+ }
+ else
+ {
+ pointer = sym->attr.pointer;
+ allocatable = sym->attr.allocatable;
+ dimension = sym->attr.dimension;
+ }
+
+ if (allocatable)
+ {
+ if (dimension)
{
gfc_error ("Allocatable array '%s' at %L must have "
"a deferred shape", sym->name, &sym->declared_at);
return FAILURE;
}
- if (sym->attr.pointer && sym->attr.dimension)
+ if (pointer && dimension)
{
gfc_error ("Array pointer '%s' at %L must have a deferred shape",
sym->name, &sym->declared_at);
gcc_assert (t1->specific && t2->specific);
gcc_assert (!t1->specific->is_generic);
gcc_assert (!t2->specific->is_generic);
+ gcc_assert (t1->is_operator == t2->is_operator);
sym1 = t1->specific->u.specific->n.sym;
sym2 = t2->specific->u.specific->n.sym;
}
/* Compare the interfaces. */
- if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
+ if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
+ NULL, 0))
{
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
sym1->name, sym2->name, generic_name, &where);
return FAILURE;
}
- for (c = sym->components; c != NULL; c = c->next)
+ c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
+ : sym->components;
+
+ for ( ; c != NULL; c = c->next)
{
+ /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
+ if (c->ts.type == BT_CHARACTER && c->ts.deferred)
+ {
+ gfc_error ("Deferred-length character component '%s' at %L is not "
+ "yet supported", c->name, &c->loc);
+ return FAILURE;
+ }
+
/* F2008, C442. */
- if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
+ if ((!sym->attr.is_class || c != sym->components)
+ && c->attr.codimension
&& (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
{
gfc_error ("Coarray component '%s' at %L must be allocatable with "
}
/* Check type-spec if this is not the parent-type component. */
- if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
+ if (((sym->attr.is_class
+ && (!sym->components->ts.u.derived->attr.extension
+ || c != sym->components->ts.u.derived->components))
+ || (!sym->attr.is_class
+ && (!sym->attr.extension || c != sym->components)))
+ && !sym->attr.vtype
&& resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
return FAILURE;
/* If this type is an extension, set the accessibility of the parent
component. */
- if (super_type && c == sym->components
+ if (super_type
+ && ((sym->attr.is_class
+ && c == sym->components->ts.u.derived->components)
+ || (!sym->attr.is_class && c == sym->components))
&& strcmp (super_type->name, c->name) == 0)
c->attr.access = super_type->attr.access;
if (!sym->attr.is_class)
gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
if (gen_dt && gen_dt->generic && gen_dt->generic->next
+ && (!gen_dt->generic->sym->attr.use_assoc
+ || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of "
"function '%s' at %L being the same name as derived "
"type at %L", sym->name,
/* Make sure the types of derived parameters are consistent. This
type checking is deferred until resolution because the type may
refer to a derived type from the host. */
- if (sym->ts.type == BT_DERIVED && sym->value
+ if (sym->ts.type == BT_DERIVED
&& !gfc_compare_types (&sym->ts, &sym->value->ts))
{
gfc_error ("Incompatible derived type in PARAMETER at %L",
gfc_symtree *this_symtree;
gfc_namespace *ns;
gfc_component *c;
+ symbol_attribute class_attr;
+ gfc_array_spec *as;
if (sym->attr.flavor == FL_UNKNOWN)
{
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;
if (sym->ts.type == BT_UNKNOWN)
{
if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
- gfc_set_default_type (sym, 1, NULL);
+ {
+ gfc_set_default_type (sym, 1, NULL);
+ }
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
&& !sym->attr.function && !sym->attr.subroutine
else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
gfc_resolve_array_spec (sym->result->as, false);
+ if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+ {
+ as = CLASS_DATA (sym)->as;
+ class_attr = CLASS_DATA (sym)->attr;
+ class_attr.pointer = class_attr.class_pointer;
+ }
+ else
+ {
+ class_attr = sym->attr;
+ as = sym->as;
+ }
+
+ /* F2008, C530. */
+ if (sym->attr.contiguous
+ && (!class_attr.dimension
+ || (as->type != AS_ASSUMED_SHAPE && !class_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;
+ }
+
/* Assumed size arrays and assumed shape arrays must be dummy
arguments. Array-spec's of implied-shape should have been resolved to
AS_EXPLICIT already. */
- if (sym->as)
+ if (as)
{
- gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
- if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
- || sym->as->type == AS_ASSUMED_SHAPE)
+ gcc_assert (as->type != AS_IMPLIED_SHAPE);
+ if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
+ || as->type == AS_ASSUMED_SHAPE)
&& sym->attr.dummy == 0)
{
- if (sym->as->type == AS_ASSUMED_SIZE)
+ if (as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array at %L must be a dummy argument",
&sym->declared_at);
else
}
/* F2008, C525. */
- if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
- || sym->attr.codimension)
+ if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+ || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->attr.coarray_comp))
+ || class_attr.codimension)
&& (sym->attr.result || sym->result == sym))
{
gfc_error ("Function result '%s' at %L shall not be a coarray or have "
}
/* F2008, C525. */
- if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
- && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
- || sym->attr.allocatable))
+ if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+ || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->attr.coarray_comp))
+ && (class_attr.codimension || class_attr.pointer || class_attr.dimension
+ || class_attr.allocatable))
{
gfc_error ("Variable '%s' at %L with coarray component "
"shall be a nonpointer, nonallocatable scalar",
}
/* F2008, C526. The function-result case was handled above. */
- if (sym->attr.codimension
- && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
+ if (class_attr.codimension
+ && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
+ || sym->attr.select_type_temporary
|| sym->ns->save_all
|| sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program
"nor a dummy argument", sym->name, &sym->declared_at);
return;
}
- /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
- else if (sym->attr.codimension && !sym->attr.allocatable
- && sym->as && sym->as->cotype == AS_DEFERRED)
+ /* F2008, C528. */
+ else if (class_attr.codimension && !sym->attr.select_type_temporary
+ && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
{
gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
"deferred shape", sym->name, &sym->declared_at);
return;
}
- else if (sym->attr.codimension && sym->attr.allocatable
- && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
+ else if (class_attr.codimension && class_attr.allocatable && as
+ && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
{
gfc_error ("Allocatable coarray variable '%s' at %L must have "
"deferred shape", sym->name, &sym->declared_at);
}
/* F2008, C541. */
- if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
- || (sym->attr.codimension && sym->attr.allocatable))
+ if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+ || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->attr.coarray_comp))
+ || (class_attr.codimension && class_attr.allocatable))
&& sym->attr.dummy && sym->attr.intent == INTENT_OUT)
{
gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
return;
}
- if (sym->attr.codimension && sym->attr.dummy
+ if (class_attr.codimension && sym->attr.dummy
&& sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
{
gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
}
proc = sym->ns->proc_name;
- if (sym->attr.dummy && gfc_pure (proc)
- && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
- ||
- proc->attr.function))
+ if (sym->attr.dummy
+ && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
+ || proc->attr.function))
return 1;
/* TODO: Sort out what can be storage associated, if anything, and include
int
gfc_implicit_pure (gfc_symbol *sym)
{
- symbol_attribute attr;
+ gfc_namespace *ns;
if (sym == NULL)
{
- /* Check if the current namespace is implicit_pure. */
- sym = gfc_current_ns->proc_name;
- if (sym == NULL)
- return 0;
- attr = sym->attr;
- if (attr.flavor == FL_PROCEDURE
- && attr.implicit_pure && !attr.pure)
- return 1;
- return 0;
+ /* Check if the current procedure is implicit_pure. Walk up
+ the procedure list until we find a procedure. */
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ {
+ sym = ns->proc_name;
+ if (sym == NULL)
+ return 0;
+
+ if (sym->attr.flavor == FL_PROCEDURE)
+ break;
+ }
}
-
- attr = sym->attr;
-
- return attr.flavor == FL_PROCEDURE && attr.implicit_pure && !attr.pure;
+
+ return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
+ && !sym->attr.pure;
}
OSDN Git Service
