}
-static bool
-has_default_initializer (gfc_symbol *der)
-{
- gfc_component *c;
-
- gcc_assert (der->attr.flavor == FL_DERIVED);
- for (c = der->components; c; c = c->next)
- if ((c->ts.type != BT_DERIVED && c->initializer)
- || (c->ts.type == BT_DERIVED
- && (!c->attr.pointer && has_default_initializer (c->ts.u.derived))))
- break;
-
- return c != NULL;
-}
-
/* Resolve common variables. */
static void
resolve_common_vars (gfc_symbol *sym, bool named_common)
gfc_error_now ("Derived type variable '%s' in COMMON at %L "
"has an ultimate component that is "
"allocatable", csym->name, &csym->declared_at);
- if (has_default_initializer (csym->ts.u.derived))
+ if (gfc_has_default_initializer (csym->ts.u.derived))
gfc_error_now ("Derived type variable '%s' in COMMON at %L "
"may not have default initializer", csym->name,
&csym->declared_at);
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
- if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
+ if (strcmp (comp->name, "$extends") == 0)
+ {
+ /* Can afford to be brutal with the $extends initializer.
+ The derived type can get lost because it is PRIVATE
+ but it is not usage constrained by the standard. */
+ cons->expr->ts = comp->ts;
+ t = SUCCESS;
+ }
+ else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
gfc_error ("The element in the derived type constructor at %L, "
"for pointer component '%s', is %s but should be %s",
&cons->expr->where, comp->name,
&& !(comp->attr.pointer || comp->attr.allocatable
|| comp->attr.proc_pointer
|| (comp->ts.type == BT_CLASS
- && (comp->ts.u.derived->components->attr.pointer
- || comp->ts.u.derived->components->attr.allocatable))))
+ && (CLASS_DATA (comp)->attr.class_pointer
+ || CLASS_DATA (comp)->attr.allocatable))))
{
t = FAILURE;
gfc_error ("The NULL in the derived type constructor at %L is "
&& not_in_recursive (sym, gsym->ns)
&& not_entry_self_reference (sym, gsym->ns))
{
+ /* Resolve the gsymbol namespace if needed. */
+ if (!gsym->ns->resolved)
+ {
+ gfc_dt_list *old_dt_list;
+
+ /* Stash away derived types so that the backend_decls do not
+ get mixed up. */
+ old_dt_list = gfc_derived_types;
+ gfc_derived_types = NULL;
+
+ gfc_resolve (gsym->ns);
+
+ /* Store the new derived types with the global namespace. */
+ if (gfc_derived_types)
+ gsym->ns->derived_types = gfc_derived_types;
+
+ /* Restore the derived types of this namespace. */
+ gfc_derived_types = old_dt_list;
+ }
+
/* Make sure that translation for the gsymbol occurs before
the procedure currently being resolved. */
- ns = gsym->ns->resolved ? NULL : gfc_global_ns_list;
+ ns = gfc_global_ns_list;
for (; ns && ns != gsym->ns; ns = ns->sibling)
{
if (ns->sibling == gsym->ns)
}
}
- if (!gsym->ns->resolved)
+ /* Differences in constant character lengths. */
+ if (sym->attr.function && sym->ts.type == BT_CHARACTER)
{
- gfc_dt_list *old_dt_list;
+ long int l1 = 0, l2 = 0;
+ gfc_charlen *cl1 = sym->ts.u.cl;
+ gfc_charlen *cl2 = gsym->ns->proc_name->ts.u.cl;
- /* Stash away derived types so that the backend_decls do not
- get mixed up. */
- old_dt_list = gfc_derived_types;
- gfc_derived_types = NULL;
+ if (cl1 != NULL
+ && cl1->length != NULL
+ && cl1->length->expr_type == EXPR_CONSTANT)
+ l1 = mpz_get_si (cl1->length->value.integer);
- gfc_resolve (gsym->ns);
+ if (cl2 != NULL
+ && cl2->length != NULL
+ && cl2->length->expr_type == EXPR_CONSTANT)
+ l2 = mpz_get_si (cl2->length->value.integer);
- /* Store the new derived types with the global namespace. */
- if (gfc_derived_types)
- gsym->ns->derived_types = gfc_derived_types;
+ if (l1 && l2 && l1 != l2)
+ gfc_error ("Character length mismatch in return type of "
+ "function '%s' at %L (%ld/%ld)", sym->name,
+ &sym->declared_at, l1, l2);
+ }
- /* Restore the derived types of this namespace. */
- gfc_derived_types = old_dt_list;
+ /* Type mismatch of function return type and expected type. */
+ if (sym->attr.function
+ && !gfc_compare_types (&sym->ts, &gsym->ns->proc_name->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));
+
+ if (gsym->ns->proc_name->formal)
+ {
+ gfc_formal_arglist *arg = gsym->ns->proc_name->formal;
+ for ( ; arg; arg = arg->next)
+ if (!arg->sym)
+ continue;
+ /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
+ else if (arg->sym->attr.allocatable
+ || arg->sym->attr.asynchronous
+ || arg->sym->attr.optional
+ || arg->sym->attr.pointer
+ || arg->sym->attr.target
+ || arg->sym->attr.value
+ || arg->sym->attr.volatile_)
+ {
+ gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
+ "has an attribute that requires an explicit "
+ "interface for this procedure", arg->sym->name,
+ sym->name, &sym->declared_at);
+ break;
+ }
+ /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
+ else if (arg->sym && arg->sym->as
+ && arg->sym->as->type == AS_ASSUMED_SHAPE)
+ {
+ gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
+ /* F2008, 12.4.2.2 (2c) */
+ else if (arg->sym->attr.codimension)
+ {
+ gfc_error ("Procedure '%s' at %L with coarray dummy argument "
+ "'%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
+ /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
+ else if (false) /* TODO: is a parametrized derived type */
+ {
+ gfc_error ("Procedure '%s' at %L with parametrized derived "
+ "type argument '%s' must have an explicit "
+ "interface", sym->name, &sym->declared_at,
+ arg->sym->name);
+ break;
+ }
+ /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
+ else if (arg->sym->ts.type == BT_CLASS)
+ {
+ gfc_error ("Procedure '%s' at %L with polymorphic dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
}
- if (gsym->ns->proc_name->attr.function
- && gsym->ns->proc_name->as
- && gsym->ns->proc_name->as->rank
- && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank))
- gfc_error ("The reference to function '%s' at %L either needs an "
- "explicit INTERFACE or the rank is incorrect", sym->name,
- where);
-
- /* Non-assumed length character functions. */
- if (sym->attr.function && sym->ts.type == BT_CHARACTER
- && gsym->ns->proc_name->ts.u.cl != NULL
- && gsym->ns->proc_name->ts.u.cl->length != NULL)
+ if (gsym->ns->proc_name->attr.function)
{
- gfc_charlen *cl = sym->ts.u.cl;
+ /* 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))
+ 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)
+ gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
+ "result must have an explicit interface", sym->name,
+ where);
- if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
- && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
+ /* 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)
{
- gfc_error ("Nonconstant character-length function '%s' at %L "
- "must have an explicit interface", sym->name,
- &sym->declared_at);
+ gfc_charlen *cl = sym->ts.u.cl;
+
+ if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
+ && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Nonconstant character-length function '%s' at %L "
+ "must have an explicit interface", sym->name,
+ &sym->declared_at);
+ }
}
}
+ /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
+ if (gsym->ns->proc_name->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)
+ {
+ gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
+ "an explicit interface", sym->name, &sym->declared_at);
+ }
+
if (gfc_option.flag_whole_file == 1
- || ((gfc_option.warn_std & GFC_STD_LEGACY)
- &&
- !(gfc_option.warn_std & GFC_STD_GNU)))
+ || ((gfc_option.warn_std & GFC_STD_LEGACY)
+ && !(gfc_option.warn_std & GFC_STD_GNU)))
gfc_errors_to_warnings (1);
gfc_procedure_use (gsym->ns->proc_name, actual, where);
&& !(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)
e->rank = op1->rank;
if (e->shape == NULL)
{
- t = compare_shapes(op1, op2);
+ t = compare_shapes (op1, op2);
if (t == FAILURE)
e->shape = NULL;
else
- e->shape = gfc_copy_shape (op1->shape, op1->rank);
+ e->shape = gfc_copy_shape (op1->shape, op1->rank);
}
}
else
/* Resolve one part of an array index. */
-gfc_try
-gfc_resolve_index (gfc_expr *index, int check_scalar)
+static gfc_try
+gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
+ int force_index_integer_kind)
{
gfc_typespec ts;
&index->where) == FAILURE)
return FAILURE;
- if (index->ts.kind != gfc_index_integer_kind
+ if ((index->ts.kind != gfc_index_integer_kind
+ && force_index_integer_kind)
|| index->ts.type != BT_INTEGER)
{
gfc_clear_ts (&ts);
return SUCCESS;
}
+/* Resolve one part of an array index. */
+
+gfc_try
+gfc_resolve_index (gfc_expr *index, int check_scalar)
+{
+ return gfc_resolve_index_1 (index, check_scalar, 1);
+}
+
/* Resolve a dim argument to an intrinsic function. */
gfc_try
gfc_ref *ref;
if (e->symtree->n.sym->ts.type == BT_CLASS)
- as = e->symtree->n.sym->ts.u.derived->components->as;
+ as = CLASS_DATA (e->symtree->n.sym)->as;
else
as = e->symtree->n.sym->as;
derived = NULL;
{
check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
- if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
+ /* Do not force gfc_index_integer_kind for the start. We can
+ do fine with any integer kind. This avoids temporary arrays
+ created for indexing with a vector. */
+ if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
return FAILURE;
if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
return FAILURE;
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;
}
+/* Get the ultimate declared type from an expression. In addition,
+ return the last class/derived type reference and the copy of the
+ reference list. */
+static gfc_symbol*
+get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
+ gfc_expr *e)
+{
+ gfc_symbol *declared;
+ gfc_ref *ref;
+
+ declared = NULL;
+ if (class_ref)
+ *class_ref = NULL;
+ if (new_ref)
+ *new_ref = gfc_copy_ref (e->ref);
+
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type != REF_COMPONENT)
+ continue;
+
+ if (ref->u.c.component->ts.type == BT_CLASS
+ || ref->u.c.component->ts.type == BT_DERIVED)
+ {
+ declared = ref->u.c.component->ts.u.derived;
+ if (class_ref)
+ *class_ref = ref;
+ }
+ }
+
+ if (declared == NULL)
+ declared = e->symtree->n.sym->ts.u.derived;
+
+ return declared;
+}
+
+
/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
which of the specific bindings (if any) matches the arglist and transform
the expression into a call of that binding. */
static gfc_try
-resolve_typebound_generic_call (gfc_expr* e)
+resolve_typebound_generic_call (gfc_expr* e, const char **name)
{
gfc_typebound_proc* genproc;
const char* genname;
+ gfc_symtree *st;
+ gfc_symbol *derived;
gcc_assert (e->expr_type == EXPR_COMPCALL);
genname = e->value.compcall.name;
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 = genname;
goto success;
}
}
return FAILURE;
success:
+ /* Make sure that we have the right specific instance for the name. */
+ derived = get_declared_from_expr (NULL, NULL, e);
+
+ st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
+ if (st)
+ e->value.compcall.tbp = st->n.tb;
+
return SUCCESS;
}
/* Resolve a call to a type-bound subroutine. */
static gfc_try
-resolve_typebound_call (gfc_code* c)
+resolve_typebound_call (gfc_code* c, const char **name)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
if (check_typebound_baseobject (c->expr1) == FAILURE)
return FAILURE;
- if (resolve_typebound_generic_call (c->expr1) == FAILURE)
+ /* Pass along the name for CLASS methods, where the vtab
+ procedure pointer component has to be referenced. */
+ if (name)
+ *name = c->expr1->value.compcall.name;
+
+ if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
return FAILURE;
/* Transform into an ordinary EXEC_CALL for now. */
}
-/* Resolve a component-call expression. This originally was intended
- only to see functions. However, it is convenient to use it in
- resolving subroutine class methods, since we do not have to add a
- gfc_code each time. */
+/* Resolve a component-call expression. */
static gfc_try
-resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
+resolve_compcall (gfc_expr* e, const char **name)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
/* Check that's really a FUNCTION. */
- if (fcn && !e->value.compcall.tbp->function)
+ if (!e->value.compcall.tbp->function)
{
gfc_error ("'%s' at %L should be a FUNCTION",
e->value.compcall.name, &e->where);
return FAILURE;
}
- else if (!fcn && !e->value.compcall.tbp->subroutine)
- {
- /* To resolve class member calls, we borrow this bit
- of code to select the specific procedures. */
- gfc_error ("'%s' at %L should be a SUBROUTINE",
- e->value.compcall.name, &e->where);
- return FAILURE;
- }
/* These must not be assign-calls! */
gcc_assert (!e->value.compcall.assign);
if (check_typebound_baseobject (e) == FAILURE)
return FAILURE;
- if (resolve_typebound_generic_call (e) == FAILURE)
+ /* Pass along the name for CLASS methods, where the vtab
+ procedure pointer component has to be referenced. */
+ if (name)
+ *name = e->value.compcall.name;
+
+ if (resolve_typebound_generic_call (e, name) == FAILURE)
return FAILURE;
gcc_assert (!e->value.compcall.tbp->is_generic);
e->value.function.actual = newactual;
e->value.function.name = NULL;
e->value.function.esym = target->n.sym;
- e->value.function.class_esym = NULL;
e->value.function.isym = NULL;
e->symtree = target;
e->ts = target->n.sym->ts;
e->expr_type = EXPR_FUNCTION;
- /* Resolution is not necessary when constructing component calls
- for class members, since this must only be done for the
- declared type, which is done afterwards. */
- return !class_members ? gfc_resolve_expr (e) : SUCCESS;
-}
-
-
-/* Resolve a typebound call for the members in a class. This group of
- functions implements dynamic dispatch in the provisional version
- of f03 OOP. As soon as vtables are in place and contain pointers
- to methods, this will no longer be necessary. */
-static gfc_expr *list_e;
-static gfc_try check_class_members (gfc_symbol *);
-static gfc_try class_try;
-static bool fcn_flag;
-
-
-static void
-check_members (gfc_symbol *derived)
-{
- if (derived->attr.flavor == FL_DERIVED)
- (void) check_class_members (derived);
+ /* Resolution is not necessary if this is a class subroutine; this
+ function only has to identify the specific proc. Resolution of
+ the call will be done next in resolve_typebound_call. */
+ return gfc_resolve_expr (e);
}
-static gfc_try
-check_class_members (gfc_symbol *derived)
-{
- gfc_expr *e;
- gfc_symtree *tbp;
- gfc_class_esym_list *etmp;
-
- e = gfc_copy_expr (list_e);
-
- tbp = gfc_find_typebound_proc (derived, &class_try,
- e->value.compcall.name,
- false, &e->where);
- if (tbp == NULL)
- {
- gfc_error ("no typebound available procedure named '%s' at %L",
- e->value.compcall.name, &e->where);
- return FAILURE;
- }
-
- /* If we have to match a passed class member, force the actual
- expression to have the correct type. */
- if (!tbp->n.tb->nopass)
- {
- if (e->value.compcall.base_object == NULL)
- e->value.compcall.base_object = extract_compcall_passed_object (e);
-
- if (e->value.compcall.base_object == NULL)
- return FAILURE;
-
- if (!derived->attr.abstract)
- {
- e->value.compcall.base_object->ts.type = BT_DERIVED;
- e->value.compcall.base_object->ts.u.derived = derived;
- }
- }
-
- e->value.compcall.tbp = tbp->n.tb;
- e->value.compcall.name = tbp->name;
-
- /* Let the original expresssion catch the assertion in
- resolve_compcall, since this flag does not appear to be reset or
- copied in some systems. */
- e->value.compcall.assign = 0;
-
- /* Do the renaming, PASSing, generic => specific and other
- good things for each class member. */
- class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS)
- ? class_try : FAILURE;
-
- /* Now transfer the found symbol to the esym list. */
- if (class_try == SUCCESS)
- {
- etmp = list_e->value.function.class_esym;
- list_e->value.function.class_esym
- = gfc_get_class_esym_list();
- list_e->value.function.class_esym->next = etmp;
- list_e->value.function.class_esym->derived = derived;
- list_e->value.function.class_esym->esym
- = e->value.function.esym;
- }
-
- gfc_free_expr (e);
-
- /* Burrow down into grandchildren types. */
- if (derived->f2k_derived)
- gfc_traverse_ns (derived->f2k_derived, check_members);
-
- return SUCCESS;
-}
-
-
-/* Eliminate esym_lists where all the members point to the
- typebound procedure of the declared type; ie. one where
- type selection has no effect.. */
-static void
-resolve_class_esym (gfc_expr *e)
-{
- gfc_class_esym_list *p, *q;
- bool empty = true;
-
- gcc_assert (e && e->expr_type == EXPR_FUNCTION);
-
- p = e->value.function.class_esym;
- if (p == NULL)
- return;
-
- for (; p; p = p->next)
- empty = empty && (e->value.function.esym == p->esym);
-
- if (empty)
- {
- p = e->value.function.class_esym;
- for (; p; p = q)
- {
- q = p->next;
- gfc_free (p);
- }
- e->value.function.class_esym = NULL;
- }
-}
-
-
-/* Generate an expression for the hash value, given the reference to
- the class of the final expression (class_ref), the base of the
- full reference list (new_ref), the declared type and the class
- object (st). */
-static gfc_expr*
-hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st)
-{
- gfc_expr *hash_value;
-
- /* Build an expression for the correct hash_value; ie. that of the last
- CLASS reference. */
- if (class_ref)
- {
- class_ref->next = NULL;
- }
- else
- {
- gfc_free_ref_list (new_ref);
- new_ref = NULL;
- }
- hash_value = gfc_get_expr ();
- hash_value->expr_type = EXPR_VARIABLE;
- hash_value->symtree = st;
- hash_value->symtree->n.sym->refs++;
- hash_value->ref = new_ref;
- gfc_add_component_ref (hash_value, "$vptr");
- gfc_add_component_ref (hash_value, "$hash");
-
- return hash_value;
-}
-
-
-/* Get the ultimate declared type from an expression. In addition,
- return the last class/derived type reference and the copy of the
- reference list. */
-static gfc_symbol*
-get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
- gfc_expr *e)
-{
- gfc_symbol *declared;
- gfc_ref *ref;
-
- declared = NULL;
- *class_ref = NULL;
- *new_ref = gfc_copy_ref (e->ref);
- for (ref = *new_ref; ref; ref = ref->next)
- {
- if (ref->type != REF_COMPONENT)
- continue;
-
- if (ref->u.c.component->ts.type == BT_CLASS
- || ref->u.c.component->ts.type == BT_DERIVED)
- {
- declared = ref->u.c.component->ts.u.derived;
- *class_ref = ref;
- }
- }
-
- if (declared == NULL)
- declared = e->symtree->n.sym->ts.u.derived;
-
- return declared;
-}
-
-
-/* Resolve the argument expressions so that any arguments expressions
- that include class methods are resolved before the current call.
- This is necessary because of the static variables used in CLASS
- method resolution. */
-static void
-resolve_arg_exprs (gfc_actual_arglist *arg)
-{
- /* Resolve the actual arglist expressions. */
- for (; arg; arg = arg->next)
- {
- if (arg->expr)
- gfc_resolve_expr (arg->expr);
- }
-}
-
-
-/* Resolve a typebound function, or 'method'. First separate all
- the non-CLASS references by calling resolve_compcall directly.
- Then treat the CLASS references by resolving for each of the class
- members in turn. */
+/* Resolve a typebound function, or 'method'. First separate all
+ the non-CLASS references by calling resolve_compcall directly. */
static gfc_try
resolve_typebound_function (gfc_expr* e)
{
- gfc_symbol *derived, *declared;
+ gfc_symbol *declared;
+ gfc_component *c;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
+ const char *name;
+ gfc_typespec ts;
st = e->symtree;
if (st == NULL)
- return resolve_compcall (e, true, false);
+ return resolve_compcall (e, NULL);
+
+ if (resolve_ref (e) == FAILURE)
+ return FAILURE;
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, e);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
- || (!class_ref && st->n.sym->ts.type != BT_CLASS))
+ || (!class_ref && st->n.sym->ts.type != BT_CLASS))
{
gfc_free_ref_list (new_ref);
- return resolve_compcall (e, true, false);
+ return resolve_compcall (e, NULL);
}
- /* Resolve the argument expressions, */
- resolve_arg_exprs (e->value.function.actual);
+ c = gfc_find_component (declared, "$data", true, true);
+ declared = c->ts.u.derived;
- /* Get the data component, which is of the declared type. */
- derived = declared->components->ts.u.derived;
-
- /* Resolve the function call for each member of the class. */
- class_try = SUCCESS;
- fcn_flag = true;
- list_e = gfc_copy_expr (e);
-
- if (check_class_members (derived) == FAILURE)
+ /* Treat the call as if it is a typebound procedure, in order to roll
+ out the correct name for the specific function. */
+ if (resolve_compcall (e, &name) == FAILURE)
return FAILURE;
+ ts = e->ts;
- class_try = (resolve_compcall (e, true, false) == SUCCESS)
- ? class_try : FAILURE;
-
- /* Transfer the class list to the original expression. Note that
- the class_esym list is cleaned up in trans-expr.c, as the calls
- are translated. */
- e->value.function.class_esym = list_e->value.function.class_esym;
- list_e->value.function.class_esym = NULL;
- gfc_free_expr (list_e);
+ /* Then convert the expression to a procedure pointer component call. */
+ e->value.function.esym = NULL;
+ e->symtree = st;
- resolve_class_esym (e);
+ if (new_ref)
+ e->ref = new_ref;
- /* More than one typebound procedure so transmit an expression for
- the hash_value as the selector. */
- if (e->value.function.class_esym != NULL)
- e->value.function.class_esym->hash_value
- = hash_value_expr (class_ref, new_ref, st);
+ /* '$vptr' points to the vtab, which contains the procedure pointers. */
+ gfc_add_component_ref (e, "$vptr");
+ gfc_add_component_ref (e, name);
- return class_try;
+ /* Recover the typespec for the expression. This is really only
+ necessary for generic procedures, where the additional call
+ to gfc_add_component_ref seems to throw the collection of the
+ correct typespec. */
+ e->ts = ts;
+ return SUCCESS;
}
-/* Resolve a typebound subroutine, or 'method'. First separate all
- the non-CLASS references by calling resolve_typebound_call directly.
- Then treat the CLASS references by resolving for each of the class
- members in turn. */
+/* Resolve a typebound subroutine, or 'method'. First separate all
+ the non-CLASS references by calling resolve_typebound_call
+ directly. */
static gfc_try
resolve_typebound_subroutine (gfc_code *code)
{
- gfc_symbol *derived, *declared;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
+ const char *name;
+ gfc_typespec ts;
st = code->expr1->symtree;
if (st == NULL)
- return resolve_typebound_call (code);
+ return resolve_typebound_call (code, NULL);
+
+ if (resolve_ref (code->expr1) == FAILURE)
+ 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)
- || (!class_ref && st->n.sym->ts.type != BT_CLASS))
+ || (!class_ref && st->n.sym->ts.type != BT_CLASS))
{
gfc_free_ref_list (new_ref);
- return resolve_typebound_call (code);
- }
-
- /* Resolve the argument expressions, */
- resolve_arg_exprs (code->expr1->value.compcall.actual);
-
- /* Get the data component, which is of the declared type. */
- derived = declared->components->ts.u.derived;
-
- class_try = SUCCESS;
- fcn_flag = false;
- list_e = gfc_copy_expr (code->expr1);
+ return resolve_typebound_call (code, NULL);
+ }
- if (check_class_members (derived) == FAILURE)
+ if (resolve_typebound_call (code, &name) == FAILURE)
return FAILURE;
+ ts = code->expr1->ts;
- class_try = (resolve_typebound_call (code) == SUCCESS)
- ? class_try : FAILURE;
+ /* Then convert the expression to a procedure pointer component call. */
+ code->expr1->value.function.esym = NULL;
+ code->expr1->symtree = st;
- /* Transfer the class list to the original expression. Note that
- the class_esym list is cleaned up in trans-expr.c, as the calls
- are translated. */
- code->expr1->value.function.class_esym
- = list_e->value.function.class_esym;
- list_e->value.function.class_esym = NULL;
- gfc_free_expr (list_e);
+ if (new_ref)
+ code->expr1->ref = new_ref;
- resolve_class_esym (code->expr1);
-
- /* More than one typebound procedure so transmit an expression for
- the hash_value as the selector. */
- if (code->expr1->value.function.class_esym != NULL)
- code->expr1->value.function.class_esym->hash_value
- = hash_value_expr (class_ref, new_ref, st);
+ /* '$vptr' points to the vtab, which contains the procedure pointers. */
+ gfc_add_component_ref (code->expr1, "$vptr");
+ gfc_add_component_ref (code->expr1, name);
- return class_try;
+ /* Recover the typespec for the expression. This is really only
+ necessary for generic procedures, where the additional call
+ to gfc_add_component_ref seems to throw the collection of the
+ correct typespec. */
+ code->expr1->ts = ts;
+ return SUCCESS;
}
{
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 = sym->ts.u.derived->components->attr.allocatable;
- pointer = sym->ts.u.derived->components->attr.pointer;
+ allocatable = CLASS_DATA (sym)->attr.allocatable;
+ pointer = CLASS_DATA (sym)->attr.class_pointer;
}
else
{
c = ref->u.c.component;
if (c->ts.type == BT_CLASS)
{
- allocatable = c->ts.u.derived->components->attr.allocatable;
- pointer = c->ts.u.derived->components->attr.pointer;
+ allocatable = CLASS_DATA (c)->attr.allocatable;
+ pointer = CLASS_DATA (c)->attr.class_pointer;
}
else
{
bad:
gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
&e->where);
+ return FAILURE;
}
if (check_intent_in && sym->attr.intent == INTENT_IN)
static gfc_try
conformable_arrays (gfc_expr *e1, gfc_expr *e2)
{
+ gfc_ref *tail;
+ for (tail = e2->ref; tail && tail->next; tail = tail->next);
+
/* First compare rank. */
- if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
+ if (tail && e1->rank != tail->u.ar.as->rank)
{
gfc_error ("Source-expr at %L must be scalar or have the "
"same rank as the allocate-object at %L",
for (i = 0; i < e1->rank; i++)
{
- if (e2->ref->u.ar.end[i])
+ if (tail->u.ar.end[i])
{
- mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
- mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
+ mpz_set (s, tail->u.ar.end[i]->value.integer);
+ mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
mpz_add_ui (s, s, 1);
}
else
{
- mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
+ mpz_set (s, tail->u.ar.start[i]->value.integer);
}
if (mpz_cmp (e1->shape[i], s) != 0)
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
- gfc_symbol *sym;
+ gfc_symbol *sym = NULL;
gfc_alloc *a;
gfc_component *c;
- gfc_expr *init_e;
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
check_intent_in = 1;
{
if (sym->ts.type == BT_CLASS)
{
- allocatable = sym->ts.u.derived->components->attr.allocatable;
- pointer = sym->ts.u.derived->components->attr.pointer;
- dimension = sym->ts.u.derived->components->attr.dimension;
- codimension = sym->ts.u.derived->components->attr.codimension;
- is_abstract = sym->ts.u.derived->components->attr.abstract;
+ allocatable = CLASS_DATA (sym)->attr.allocatable;
+ 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;
}
else
{
c = ref->u.c.component;
if (c->ts.type == BT_CLASS)
{
- allocatable = c->ts.u.derived->components->attr.allocatable;
- pointer = c->ts.u.derived->components->attr.pointer;
- dimension = c->ts.u.derived->components->attr.dimension;
- codimension = c->ts.u.derived->components->attr.codimension;
- is_abstract = c->ts.u.derived->components->attr.abstract;
+ allocatable = CLASS_DATA (c)->attr.allocatable;
+ 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;
}
else
{
goto failure;
}
}
- else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN)
+
+ /* Check F08:C629. */
+ if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
+ && !code->expr3)
{
gcc_assert (e->ts.type == BT_CLASS);
gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
- "type-spec or SOURCE=", sym->name, &e->where);
+ "type-spec or source-expr", sym->name, &e->where);
goto failure;
}
goto failure;
}
- if (!code->expr3)
+ if (!code->expr3 || code->expr3->mold)
{
/* Add default initializer for those derived types that need them. */
- if (e->ts.type == BT_DERIVED
- && (init_e = gfc_default_initializer (&e->ts)))
- {
- gfc_code *init_st = gfc_get_code ();
- init_st->loc = code->loc;
- init_st->op = EXEC_INIT_ASSIGN;
- init_st->expr1 = gfc_expr_to_initialize (e);
- init_st->expr2 = init_e;
- init_st->next = code->next;
- code->next = init_st;
- }
- else if (e->ts.type == BT_CLASS
- && ((code->ext.alloc.ts.type == BT_UNKNOWN
- && (init_e = gfc_default_initializer (&e->ts.u.derived->components->ts)))
- || (code->ext.alloc.ts.type == BT_DERIVED
- && (init_e = gfc_default_initializer (&code->ext.alloc.ts)))))
+ gfc_expr *init_e = NULL;
+ gfc_typespec ts;
+
+ if (code->ext.alloc.ts.type == BT_DERIVED)
+ ts = code->ext.alloc.ts;
+ else if (code->expr3)
+ ts = code->expr3->ts;
+ else
+ ts = e->ts;
+
+ if (ts.type == BT_DERIVED)
+ init_e = gfc_default_initializer (&ts);
+ /* FIXME: Use default init of dynamic type (cf. PR 44541). */
+ else if (e->ts.type == BT_CLASS)
+ init_e = gfc_default_initializer (&ts.u.derived->components->ts);
+
+ if (init_e)
{
gfc_code *init_st = gfc_get_code ();
init_st->loc = code->loc;
goto failure;
}
- if (codimension)
+ if (codimension && ar->as->rank == 0)
{
- gfc_error ("Sorry, allocatable coarrays are no yet supported coarray "
+ gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
"at %L", &e->where);
goto failure;
}
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.
return FAILURE;
}
- /* Convert the case value kind to that of case expression kind, if needed.
- FIXME: Should a warning be issued? */
+ /* Convert the case value kind to that of case expression kind,
+ if needed */
+
if (e->ts.kind != case_expr->ts.kind)
gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
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. */
+
+ if (type == BT_INTEGER)
+ for (body = code->block; body; body = body->block)
+ for (cp = body->ext.case_list; cp; cp = cp->next)
+ {
+ if (cp->low
+ && gfc_check_integer_range (cp->low->value.integer,
+ case_expr->ts.kind) != ARITH_OK)
+ gfc_warning ("Expression in CASE statement at %L is "
+ "not in the range of %s", &cp->low->where,
+ gfc_typename (&case_expr->ts));
+
+ if (cp->high
+ && cp->low != cp->high
+ && gfc_check_integer_range (cp->high->value.integer,
+ case_expr->ts.kind) != ARITH_OK)
+ gfc_warning ("Expression in CASE statement at %L is "
+ "not in the range of %s", &cp->high->where,
+ gfc_typename (&case_expr->ts));
+ }
+
/* PR 19168 has a long discussion concerning a mismatch of the kinds
of the SELECT CASE expression and its CASE values. Walk the lists
of case values, and if we find a mismatch, promote case_expr to
&& gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
continue;
- /* FIXME: Should a warning be issued? */
if (cp->low != NULL
&& case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
/* Deal with single value cases and case ranges. Errors are
issued from the validation function. */
- if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
- || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
+ if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
+ || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
{
t = FAILURE;
break;
value = cp->low->value.logical == 0 ? 2 : 1;
if (value & seen_logical)
{
- gfc_error ("constant logical value in CASE statement "
+ gfc_error ("Constant logical value in CASE statement "
"is repeated at %L",
&cp->low->where);
t = FAILURE;
gfc_namespace *ns;
int error = 0;
- ns = code->ext.ns;
+ ns = code->ext.block.ns;
gfc_resolve (ns);
+ /* Check for F03:C813. */
+ if (code->expr1->ts.type != BT_CLASS
+ && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
+ {
+ gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
+ "at %L", &code->loc);
+ return;
+ }
+
if (code->expr2)
- selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
+ {
+ if (code->expr1->symtree->n.sym->attr.untyped)
+ code->expr1->symtree->n.sym->ts = code->expr2->ts;
+ selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
+ }
else
- selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
+ selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
else
ns->code->next = new_st;
code->op = EXEC_BLOCK;
+ code->ext.block.assoc = NULL;
code->expr1 = code->expr2 = NULL;
code->block = NULL;
tail->next = NULL;
default_case = tail;
}
-
+
/* More than one CLASS IS block? */
if (class_is->block)
{
static void
resolve_block_construct (gfc_code* code)
{
- /* Eventually, we may want to do some checks here or handle special stuff.
- But so far the only thing we can do is resolving the local namespace. */
+ /* For an ASSOCIATE block, the associations (and their targets) are already
+ resolved during gfc_resolve_symbol. */
- gfc_resolve (code->ext.ns);
+ /* Resolve the BLOCK's namespace. */
+ gfc_resolve (code->ext.block.ns);
}
and rhs is the same symbol as the lhs. */
if ((*rhsptr)->expr_type == EXPR_VARIABLE
&& (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
- && has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
+ && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
&& (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
*rhsptr = gfc_get_parentheses (*rhsptr);
gfc_resolve_omp_do_blocks (code, ns);
break;
case EXEC_SELECT_TYPE:
- gfc_current_ns = code->ext.ns;
+ gfc_current_ns = code->ext.block.ns;
gfc_resolve_blocks (code->block, gfc_current_ns);
gfc_current_ns = ns;
break;
break;
case EXEC_BLOCK:
- gfc_resolve (code->ext.ns);
+ gfc_resolve (code->ext.block.ns);
break;
case EXEC_DO:
{
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:
return FAILURE;
}
}
+
+ /* Constraints on polymorphic variables. */
+ if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
+ {
+ /* F03:C502. */
+ 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,
+ &sym->declared_at);
+ return FAILURE;
+ }
+
+ /* F03:C509. */
+ /* Assume that use associated symbols were checked in the module ns. */
+ if (!sym->attr.class_ok && !sym->attr.use_assoc)
+ {
+ gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
+ "or pointer", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+ }
+
return SUCCESS;
}
or POINTER attribute, the object shall have the SAVE attribute."
The check for initializers is performed with
- has_default_initializer because gfc_default_initializer generates
+ gfc_has_default_initializer because gfc_default_initializer generates
a hidden default for allocatable components. */
if (!(sym->value || no_init_flag) && sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& !sym->ns->save_all && !sym->attr.save
&& !sym->attr.pointer && !sym->attr.allocatable
- && has_default_initializer (sym->ts.u.derived)
+ && gfc_has_default_initializer (sym->ts.u.derived)
&& gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
"module variable '%s' at %L, needed due to "
"the default initialization", sym->name,
&sym->declared_at) == FAILURE)
return FAILURE;
- if (sym->ts.type == BT_CLASS)
- {
- /* C502. */
- if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
- {
- gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
- sym->ts.u.derived->components->ts.u.derived->name,
- sym->name, &sym->declared_at);
- return FAILURE;
- }
-
- /* C509. */
- /* Assume that use associated symbols were checked in the module ns. */
- if (!sym->attr.class_ok && !sym->attr.use_assoc)
- {
- gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
- "or pointer", sym->name, &sym->declared_at);
- return FAILURE;
- }
- }
-
/* Assign default initializer. */
if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
&& (!no_init_flag || sym->attr.intent == INTENT_OUT))
goto error;
}
- if (me_arg->ts.u.derived->components->ts.u.derived
+ if (CLASS_DATA (me_arg)->ts.u.derived
!= resolve_bindings_derived)
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
}
gcc_assert (me_arg->ts.type == BT_CLASS);
- if (me_arg->ts.u.derived->components->as
- && me_arg->ts.u.derived->components->as->rank > 0)
+ if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
{
gfc_error ("Passed-object dummy argument of '%s' at %L must be"
" scalar", proc->name, &where);
goto error;
}
- if (me_arg->ts.u.derived->components->attr.allocatable)
+ if (CLASS_DATA (me_arg)->attr.allocatable)
{
gfc_error ("Passed-object dummy argument of '%s' at %L must not"
" be ALLOCATABLE", proc->name, &where);
goto error;
}
- if (me_arg->ts.u.derived->components->attr.class_pointer)
+ if (CLASS_DATA (me_arg)->attr.class_pointer)
{
gfc_error ("Passed-object dummy argument of '%s' at %L must not"
" be POINTER", proc->name, &where);
This is not the most efficient way to do this, but it should be ok and is
clearer than something sophisticated. */
- gcc_assert (ancestor && ancestor->attr.abstract && !sub->attr.abstract);
+ gcc_assert (ancestor && !sub->attr.abstract);
+
+ if (!ancestor->attr.abstract)
+ return SUCCESS;
/* Walk bindings of this ancestor. */
if (ancestor->f2k_derived)
int i;
super_type = gfc_get_derived_super_type (sym);
+
+ if (sym->attr.is_class && sym->ts.u.derived == NULL)
+ {
+ /* Fix up incomplete CLASS symbols. */
+ gfc_component *data = gfc_find_component (sym, "$data", true, true);
+ 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);
+ gcc_assert (vtab);
+ vptr->ts.u.derived = vtab->ts.u.derived;
+ }
+ }
/* F2008, C432. */
if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
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)
+ if (c->ts.interface->attr.procedure && !sym->attr.vtype)
gfc_error ("Interface '%s', used by procedure pointer component "
"'%s' at %L, is declared in a later PROCEDURE statement",
c->ts.interface->name, c->name, &c->loc);
c->ts.u.cl = cl;
}
}
- else if (c->ts.interface->name[0] != '\0')
+ 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,
}
/* Procedure pointer components: Check PASS arg. */
- if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0)
+ if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
+ && !sym->attr.vtype)
{
gfc_symbol* me_arg;
if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
|| (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
|| (me_arg->ts.type == BT_CLASS
- && me_arg->ts.u.derived->components->ts.u.derived != sym))
+ && CLASS_DATA (me_arg)->ts.u.derived != sym))
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
" the derived type '%s'", me_arg->name, c->name,
/* If this type is an extension, see if this component has the same name
as an inherited type-bound procedure. */
- if (super_type
+ if (super_type && !sym->attr.is_class
&& gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
{
gfc_error ("Component '%s' of '%s' at %L has the same name as an"
}
}
- if (c->ts.type == BT_DERIVED && c->attr.pointer
+ if (!sym->attr.is_class && c->ts.type == BT_DERIVED && c->attr.pointer
&& c->ts.u.derived->components == NULL
&& !c->ts.u.derived->attr.zero_comp)
{
return FAILURE;
}
+ 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)
+ {
+ gfc_error ("The pointer component '%s' of '%s' at %L is a type "
+ "that has not been declared", c->name, sym->name,
+ &c->loc);
+ return FAILURE;
+ }
+
/* C437. */
if (c->ts.type == BT_CLASS
- && !(c->ts.u.derived->components->attr.pointer
- || c->ts.u.derived->components->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;
gfc_namespace *ns;
gfc_component *c;
+ /* Avoid double resolution of function result symbols. */
+ if ((sym->result || sym->attr.result) && (sym->ns != gfc_current_ns))
+ return;
+
if (sym->attr.flavor == FL_UNKNOWN)
{
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;
}
}
+ if (sym->attr.is_protected && !sym->attr.proc_pointer
+ && (sym->attr.procedure || sym->attr.external))
+ {
+ if (sym->attr.external)
+ gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
+ "at %L", &sym->declared_at);
+ else
+ gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
+ "at %L", &sym->declared_at);
+
+ 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;
can. */
mp_flag = (sym->result != NULL && sym->result != sym);
-
/* Make sure that the intrinsic is consistent with its internal
representation. This needs to be done before assigning a default
type to avoid spurious warnings. */
&& resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
return;
+ /* For associate names, resolve corresponding expression and make sure
+ they get their type-spec set this way. */
+ if (sym->assoc)
+ {
+ gcc_assert (sym->attr.flavor == FL_VARIABLE);
+ if (gfc_resolve_expr (sym->assoc->target) != SUCCESS)
+ return;
+
+ sym->ts = sym->assoc->target->ts;
+ gcc_assert (sym->ts.type != BT_UNKNOWN);
+ }
+
/* Assign default type to symbols that need one and don't have one. */
if (sym->ts.type == BT_UNKNOWN)
{
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;
}
}
}
mpz_set_ui (size, 0);
}
- gfc_assign_data_value_range (var->expr, values.vnode->expr,
- offset, range);
+ t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
+ offset, range);
mpz_add (offset, offset, range);
mpz_clear (range);
+
+ if (t == FAILURE)
+ break;
}
/* Assign initial value to symbol. */
gfc_try retval = SUCCESS;
mpz_init (frame.value);
+ mpz_init (trip);
start = gfc_copy_expr (var->iter.start);
end = gfc_copy_expr (var->iter.end);
if (gfc_simplify_expr (start, 1) == FAILURE
|| start->expr_type != EXPR_CONSTANT)
{
- gfc_error ("iterator start at %L does not simplify", &start->where);
+ gfc_error ("start of implied-do loop at %L could not be "
+ "simplified to a constant value", &start->where);
retval = FAILURE;
goto cleanup;
}
if (gfc_simplify_expr (end, 1) == FAILURE
|| end->expr_type != EXPR_CONSTANT)
{
- gfc_error ("iterator end at %L does not simplify", &end->where);
+ gfc_error ("end of implied-do loop at %L could not be "
+ "simplified to a constant value", &start->where);
retval = FAILURE;
goto cleanup;
}
if (gfc_simplify_expr (step, 1) == FAILURE
|| step->expr_type != EXPR_CONSTANT)
{
- gfc_error ("iterator step at %L does not simplify", &step->where);
+ gfc_error ("step of implied-do loop at %L could not be "
+ "simplified to a constant value", &start->where);
retval = FAILURE;
goto cleanup;
}
- mpz_init_set (trip, end->value.integer);
+ mpz_set (trip, end->value.integer);
mpz_sub (trip, trip, start->value.integer);
mpz_add (trip, trip, step->value.integer);
{
if (traverse_data_var (var->list, where) == FAILURE)
{
- mpz_clear (trip);
retval = FAILURE;
goto cleanup;
}
if (gfc_simplify_expr (e, 1) == FAILURE)
{
gfc_free_expr (e);
- mpz_clear (trip);
retval = FAILURE;
goto cleanup;
}
mpz_sub_ui (trip, trip, 1);
}
- mpz_clear (trip);
cleanup:
mpz_clear (frame.value);
+ mpz_clear (trip);
gfc_free_expr (start);
gfc_free_expr (end);
return FAILURE;
}
- if (sym->attr.in_common && has_default_initializer (sym->ts.u.derived))
+ if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
{
gfc_error ("Derived type variable '%s' at %L with default "
"initialization cannot be in EQUIVALENCE with a variable "
OSDN Git Service
