/* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
type, lists the only ways a character length value of * can be used:
dummy arguments of procedures, named constants, and function results
- in external functions. Internal function results are not on that list;
- ergo, not permitted. */
+ in external functions. Internal function results and results of module
+ procedures are not on this list, ergo, not permitted. */
if (sym->result->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->result->ts.u.cl;
if (!cl || !cl->length)
- gfc_error ("Character-valued internal function '%s' at %L must "
- "not be assumed length", sym->name, &sym->declared_at);
+ {
+ /* See if this is a module-procedure and adapt error message
+ accordingly. */
+ bool module_proc;
+ gcc_assert (ns->parent && ns->parent->proc_name);
+ module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
+
+ gfc_error ("Character-valued %s '%s' at %L must not be"
+ " assumed length",
+ module_proc ? _("module procedure")
+ : _("internal function"),
+ sym->name, &sym->declared_at);
+ }
}
}
gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
sym->name, &common_root->n.common->where);
else if (sym->attr.result
- ||(sym->attr.function && gfc_current_ns->proc_name == sym))
+ || gfc_is_function_return_value (sym, gfc_current_ns))
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
"that is also a function result", sym->name,
&common_root->n.common->where);
if (cons->expr->expr_type == EXPR_NULL
&& !(comp->attr.pointer || comp->attr.allocatable
- || comp->attr.proc_pointer))
+ || comp->attr.proc_pointer
+ || (comp->ts.type == BT_CLASS
+ && (comp->ts.u.derived->components->attr.pointer
+ || comp->ts.u.derived->components->attr.allocatable))))
{
t = FAILURE;
gfc_error ("The NULL in the derived type constructor at %L is "
if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
|| a.optional || a.pointer || a.save || a.target || a.volatile_
- || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
+ || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
+ || a.asynchronous)
return 1;
return 0;
{
gfc_symbol* proc_sym;
gfc_symbol* context_proc;
+ gfc_namespace* real_context;
+
+ if (sym->attr.flavor == FL_PROGRAM)
+ return false;
gcc_assert (sym->attr.flavor == FL_PROCEDURE);
if (proc_sym->attr.recursive || gfc_option.flag_recursive)
return false;
- /* Find the context procdure's "real" symbol if it has entries. */
- context_proc = (context->entries ? context->entries->sym
- : context->proc_name);
- if (!context_proc)
- return true;
+ /* Find the context procedure's "real" symbol if it has entries.
+ We look for a procedure symbol, so recurse on the parents if we don't
+ find one (like in case of a BLOCK construct). */
+ for (real_context = context; ; real_context = real_context->parent)
+ {
+ /* We should find something, eventually! */
+ gcc_assert (real_context);
+
+ context_proc = (real_context->entries ? real_context->entries->sym
+ : real_context->proc_name);
+
+ /* In some special cases, there may not be a proc_name, like for this
+ invalid code:
+ real(bad_kind()) function foo () ...
+ when checking the call to bad_kind ().
+ In these cases, we simply return here and assume that the
+ call is ok. */
+ if (!context_proc)
+ return false;
+
+ if (context_proc->attr.flavor != FL_LABEL)
+ break;
+ }
/* A call from sym's body to itself is recursion, of course. */
if (context_proc == proc_sym)
if (gfc_is_proc_ptr_comp (e, &comp))
{
e->ts = comp->ts;
- if (e->value.compcall.actual == NULL)
- e->expr_type = EXPR_VARIABLE;
- else
+ if (e->expr_type == EXPR_PPC)
{
if (comp->as != NULL)
e->rank = comp->as->rank;
e->expr_type = EXPR_FUNCTION;
}
+ if (gfc_resolve_expr (e) == FAILURE)
+ return FAILURE;
goto argument_list;
}
/* If the symbol is the function that names the current (or
parent) scope, then we really have a variable reference. */
- if (sym->attr.function && sym->result == sym
- && (sym->ns->proc_name == sym
- || (sym->ns->parent != NULL
- && sym->ns->parent->proc_name == sym)))
+ if (gfc_is_function_return_value (sym, sym->ns))
goto got_variable;
/* If all else fails, see if we have a specific intrinsic. */
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->length != NULL)
+ {
+ 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);
+ }
+ }
if (gfc_option.flag_whole_file == 1
|| ((gfc_option.warn_std & GFC_STD_LEGACY)
if (expr->symtree)
sym = expr->symtree->n.sym;
+ /* If this is a procedure pointer component, it has already been resolved. */
+ if (gfc_is_proc_ptr_comp (expr, NULL))
+ return SUCCESS;
+
if (sym && sym->attr.intrinsic
&& resolve_intrinsic (sym, &expr->where) == FAILURE)
return FAILURE;
return FAILURE;
}
- if (sym && sym->attr.abstract)
+ /* If this ia a deferred TBP with an abstract interface (which may
+ of course be referenced), expr->value.function.name will be set. */
+ if (sym && sym->attr.abstract && !expr->value.function.name)
{
gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
sym->name, &expr->where);
}
}
+ /* If this ia a deferred TBP with an abstract interface
+ (which may of course be referenced), c->expr1 will be set. */
+ if (csym && csym->attr.abstract && !c->expr1)
+ {
+ gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
+ csym->name, &c->loc);
+ return FAILURE;
+ }
+
/* Subroutines without the RECURSIVE attribution are not allowed to
* call themselves. */
if (csym && is_illegal_recursion (csym, gfc_current_ns))
case INTRINSIC_POWER:
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
{
- gfc_type_convert_binary (e);
+ gfc_type_convert_binary (e, 1);
break;
}
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
{
- gfc_type_convert_binary (e);
+ gfc_type_convert_binary (e, 1);
e->ts.type = BT_LOGICAL;
e->ts.kind = gfc_default_logical_kind;
bad_op:
- if (gfc_extend_expr (e) == SUCCESS)
- return SUCCESS;
+ {
+ bool real_error;
+ if (gfc_extend_expr (e, &real_error) == SUCCESS)
+ return SUCCESS;
+
+ if (real_error)
+ return FAILURE;
+ }
if (dual_locus_error)
gfc_error (msg, &op1->where, &op2->where);
gfc_symbol *derived;
gfc_ref *ref;
- as = e->symtree->n.sym->as;
+ if (e->symtree->n.sym->ts.type == BT_CLASS)
+ as = e->symtree->n.sym->ts.u.derived->components->as;
+ else
+ as = e->symtree->n.sym->as;
derived = NULL;
for (ref = e->ref; ref; ref = ref->next)
e->ts.kind = gfc_default_character_kind;
if (!e->ts.u.cl)
- e->ts.u.cl = gfc_new_charlen (gfc_current_ns);
+ e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
if (char_ref->u.ss.start)
start = gfc_copy_expr (char_ref->u.ss.start);
case REF_COMPONENT:
if (current_part_dimension || seen_part_dimension)
{
- if (ref->u.c.component->attr.pointer)
+ /* F03:C614. */
+ if (ref->u.c.component->attr.pointer
+ || ref->u.c.component->attr.proc_pointer)
{
gfc_error ("Component to the right of a part reference "
"with nonzero rank must not have the POINTER "
else if (op2->expr_type == EXPR_CONSTANT)
e2 = gfc_int_expr (op2->value.character.length);
- e->ts.u.cl = gfc_new_charlen (gfc_current_ns);
+ e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
if (!e1 || !e2)
return;
default:
if (!e->ts.u.cl)
- e->ts.u.cl = gfc_new_charlen (gfc_current_ns);
+ e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
break;
}
gcc_assert (e->expr_type == EXPR_COMPCALL);
- po = gfc_get_expr ();
- po->expr_type = EXPR_VARIABLE;
- po->symtree = e->symtree;
- po->ref = gfc_copy_ref (e->ref);
+ if (e->value.compcall.base_object)
+ po = gfc_copy_expr (e->value.compcall.base_object);
+ else
+ {
+ po = gfc_get_expr ();
+ po->expr_type = EXPR_VARIABLE;
+ po->symtree = e->symtree;
+ po->ref = gfc_copy_ref (e->ref);
+ }
if (gfc_resolve_expr (po) == FAILURE)
return NULL;
if (!po)
return FAILURE;
- if (po->rank > 0)
- {
- gfc_error ("Passed-object at %L must be scalar", &e->where);
- return FAILURE;
- }
-
- if (tbp->nopass)
+ if (tbp->nopass || e->value.compcall.ignore_pass)
{
gfc_free_expr (po);
return SUCCESS;
if (!base)
return FAILURE;
- gcc_assert (base->ts.type == BT_DERIVED);
- if (base->ts.u.derived->attr.abstract)
+ gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
+
+ if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
{
gfc_error ("Base object for type-bound procedure call at %L is of"
" ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
return FAILURE;
}
+ /* If the procedure called is NOPASS, the base object must be scalar. */
+ if (e->value.compcall.tbp->nopass && base->rank > 0)
+ {
+ gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
+ " be scalar", &e->where);
+ return FAILURE;
+ }
+
+ /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
+ if (base->rank > 0)
+ {
+ gfc_error ("Non-scalar base object at %L currently not implemented",
+ &e->where);
+ return FAILURE;
+ }
+
return SUCCESS;
}
c->ext.actual = newactual;
c->symtree = target;
- c->op = EXEC_CALL;
+ c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
+
gfc_free_expr (c->expr1);
- c->expr1 = NULL;
+ c->expr1 = gfc_get_expr ();
+ c->expr1->expr_type = EXPR_FUNCTION;
+ c->expr1->symtree = target;
+ c->expr1->where = c->loc;
return resolve_call (c);
}
-/* Resolve a component-call expression. */
-
+/* 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. */
static gfc_try
-resolve_compcall (gfc_expr* e)
+resolve_compcall (gfc_expr* e, bool fcn)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
/* Check that's really a FUNCTION. */
- if (!e->value.compcall.tbp->function)
+ if (fcn && !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;
e->value.function.actual = newactual;
e->value.function.name = e->value.compcall.name;
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;
- return gfc_resolve_expr (e);
+ /* 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 fcn ? 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 void check_class_members (gfc_symbol *);
+static gfc_try class_try;
+static bool fcn_flag;
+static gfc_symbol *class_object;
+
+
+static void
+check_members (gfc_symbol *derived)
+{
+ if (derived->attr.flavor == FL_DERIVED)
+ check_class_members (derived);
+}
+
+
+static void
+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;
+ }
+
+ if (tbp->n.tb->is_generic)
+ {
+ /* 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);
+
+ 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) == 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);
+}
+
+
+/* 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 CLASS typebound function, or 'method'. */
+static gfc_try
+resolve_class_compcall (gfc_expr* e)
+{
+ gfc_symbol *derived, *declared;
+ gfc_ref *new_ref;
+ gfc_ref *class_ref;
+ gfc_symtree *st;
+
+ st = e->symtree;
+ class_object = st->n.sym;
+
+ /* 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)
+ {
+ gfc_free_ref_list (new_ref);
+ return resolve_compcall (e, true);
+ }
+
+ /* Resolve the argument expressions, */
+ resolve_arg_exprs (e->value.function.actual);
+
+ /* 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);
+ check_class_members (derived);
+
+ class_try = (resolve_compcall (e, true) == 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);
+
+ resolve_class_esym (e);
+
+ /* 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);
+
+ return class_try;
+}
+
+/* Resolve a CLASS typebound subroutine, or 'method'. */
+static gfc_try
+resolve_class_typebound_call (gfc_code *code)
+{
+ gfc_symbol *derived, *declared;
+ gfc_ref *new_ref;
+ gfc_ref *class_ref;
+ gfc_symtree *st;
+
+ st = code->expr1->symtree;
+ class_object = st->n.sym;
+
+ /* Get the CLASS declared type. */
+ declared = 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);
+ }
+
+ /* 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);
+ check_class_members (derived);
+
+ class_try = (resolve_typebound_call (code) == 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. */
+ code->expr1->value.function.class_esym
+ = list_e->value.function.class_esym;
+ list_e->value.function.class_esym = NULL;
+ gfc_free_expr (list_e);
+
+ 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);
+
+ return class_try;
}
resolve_ppc_call (gfc_code* c)
{
gfc_component *comp;
- gcc_assert (gfc_is_proc_ptr_comp (c->expr1, &comp));
+ bool b;
+
+ b = gfc_is_proc_ptr_comp (c->expr1, &comp);
+ gcc_assert (b);
c->resolved_sym = c->expr1->symtree->n.sym;
c->expr1->expr_type = EXPR_VARIABLE;
resolve_expr_ppc (gfc_expr* e)
{
gfc_component *comp;
- gcc_assert (gfc_is_proc_ptr_comp (e, &comp));
+ bool b;
+
+ b = gfc_is_proc_ptr_comp (e, &comp);
+ gcc_assert (b);
/* Convert to EXPR_FUNCTION. */
e->expr_type = EXPR_FUNCTION;
break;
case EXPR_COMPCALL:
- t = resolve_compcall (e);
+ if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
+ t = resolve_class_compcall (e);
+ else
+ t = resolve_compcall (e, true);
break;
case EXPR_SUBSTRING:
symbol_attribute attr;
int allocatable, pointer, check_intent_in;
gfc_ref *ref;
+ gfc_symbol *sym;
+ gfc_component *c;
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
check_intent_in = 1;
if (e->expr_type != EXPR_VARIABLE)
goto bad;
- allocatable = e->symtree->n.sym->attr.allocatable;
- pointer = e->symtree->n.sym->attr.pointer;
+ sym = e->symtree->n.sym;
+
+ if (sym->ts.type == BT_CLASS)
+ {
+ allocatable = sym->ts.u.derived->components->attr.allocatable;
+ pointer = sym->ts.u.derived->components->attr.pointer;
+ }
+ else
+ {
+ allocatable = sym->attr.allocatable;
+ pointer = sym->attr.pointer;
+ }
for (ref = e->ref; ref; ref = ref->next)
{
if (pointer)
break;
case REF_COMPONENT:
- allocatable = (ref->u.c.component->as != NULL
- && ref->u.c.component->as->type == AS_DEFERRED);
- pointer = ref->u.c.component->attr.pointer;
+ 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;
+ }
+ else
+ {
+ allocatable = c->attr.allocatable;
+ pointer = c->attr.pointer;
+ }
break;
case REF_SUBSTRING:
&e->where);
}
- if (check_intent_in
- && e->symtree->n.sym->attr.intent == INTENT_IN)
+ if (check_intent_in && sym->attr.intent == INTENT_IN)
{
gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
- e->symtree->n.sym->name, &e->where);
+ sym->name, &e->where);
return FAILURE;
}
+ if (e->ts.type == BT_CLASS)
+ {
+ /* Only deallocate the DATA component. */
+ gfc_add_component_ref (e, "$data");
+ }
+
return SUCCESS;
}
derived types with default initializers, and derived types with allocatable
components that need nullification.) */
-static gfc_expr *
-expr_to_initialize (gfc_expr *e)
+gfc_expr *
+gfc_expr_to_initialize (gfc_expr *e)
{
gfc_expr *result;
gfc_ref *ref;
}
+/* Used in resolve_allocate_expr to check that a allocation-object and
+ a source-expr are conformable. This does not catch all possible
+ cases; in particular a runtime checking is needed. */
+
+static gfc_try
+conformable_arrays (gfc_expr *e1, gfc_expr *e2)
+{
+ /* First compare rank. */
+ if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
+ {
+ gfc_error ("Source-expr at %L must be scalar or have the "
+ "same rank as the allocate-object at %L",
+ &e1->where, &e2->where);
+ return FAILURE;
+ }
+
+ if (e1->shape)
+ {
+ int i;
+ mpz_t s;
+
+ mpz_init (s);
+
+ for (i = 0; i < e1->rank; i++)
+ {
+ if (e2->ref->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_add_ui (s, s, 1);
+ }
+ else
+ {
+ mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
+ }
+
+ if (mpz_cmp (e1->shape[i], s) != 0)
+ {
+ gfc_error ("Source-expr at %L and allocate-object at %L must "
+ "have the same shape", &e1->where, &e2->where);
+ mpz_clear (s);
+ return FAILURE;
+ }
+ }
+
+ mpz_clear (s);
+ }
+
+ return SUCCESS;
+}
+
+
/* Resolve the expression in an ALLOCATE statement, doing the additional
checks to see whether the expression is OK or not. The expression must
have a trailing array reference that gives the size of the array. */
static gfc_try
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
- int i, pointer, allocatable, dimension, check_intent_in;
+ int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
- gfc_code *init_st;
- gfc_expr *init_e;
gfc_symbol *sym;
gfc_alloc *a;
+ gfc_component *c;
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
check_intent_in = 1;
pointer, the next-to-last reference must be a pointer. */
ref2 = NULL;
+ if (e->symtree)
+ sym = e->symtree->n.sym;
+
+ /* Check whether ultimate component is abstract and CLASS. */
+ is_abstract = 0;
if (e->expr_type != EXPR_VARIABLE)
{
}
else
{
- allocatable = e->symtree->n.sym->attr.allocatable;
- pointer = e->symtree->n.sym->attr.pointer;
- dimension = e->symtree->n.sym->attr.dimension;
+ 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;
+ is_abstract = sym->ts.u.derived->components->attr.abstract;
+ }
+ else
+ {
+ allocatable = sym->attr.allocatable;
+ pointer = sym->attr.pointer;
+ dimension = sym->attr.dimension;
+ }
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
{
break;
case REF_COMPONENT:
- allocatable = (ref->u.c.component->as != NULL
- && ref->u.c.component->as->type == AS_DEFERRED);
-
- pointer = ref->u.c.component->attr.pointer;
- dimension = ref->u.c.component->attr.dimension;
+ 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;
+ is_abstract = c->ts.u.derived->components->attr.abstract;
+ }
+ else
+ {
+ allocatable = c->attr.allocatable;
+ pointer = c->attr.pointer;
+ dimension = c->attr.dimension;
+ is_abstract = c->attr.abstract;
+ }
break;
case REF_SUBSTRING:
return FAILURE;
}
- if (check_intent_in
- && e->symtree->n.sym->attr.intent == INTENT_IN)
+ /* Some checks for the SOURCE tag. */
+ if (code->expr3)
{
- gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
- e->symtree->n.sym->name, &e->where);
+ /* Check F03:C631. */
+ if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
+ {
+ gfc_error ("Type of entity at %L is type incompatible with "
+ "source-expr at %L", &e->where, &code->expr3->where);
+ return FAILURE;
+ }
+
+ /* Check F03:C632 and restriction following Note 6.18. */
+ if (code->expr3->rank > 0
+ && conformable_arrays (code->expr3, e) == FAILURE)
+ return FAILURE;
+
+ /* Check F03:C633. */
+ if (code->expr3->ts.kind != e->ts.kind)
+ {
+ gfc_error ("The allocate-object at %L and the source-expr at %L "
+ "shall have the same kind type parameter",
+ &e->where, &code->expr3->where);
+ return FAILURE;
+ }
+ }
+ else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN)
+ {
+ 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);
return FAILURE;
}
- /* Add default initializer for those derived types that need them. */
- if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
+ if (check_intent_in && sym->attr.intent == INTENT_IN)
{
- init_st = gfc_get_code ();
- init_st->loc = code->loc;
- init_st->op = EXEC_INIT_ASSIGN;
- init_st->expr1 = expr_to_initialize (e);
- init_st->expr2 = init_e;
- init_st->next = code->next;
- code->next = init_st;
+ gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
+ sym->name, &e->where);
+ return FAILURE;
}
- if (pointer && dimension == 0)
+ if (pointer || dimension == 0)
return SUCCESS;
/* Make sure the next-to-last reference node is an array specification. */
check_symbols:
- for (a = code->ext.alloc_list; a; a = a->next)
+ for (a = code->ext.alloc.list; a; a = a->next)
{
sym = a->expr->symtree->n.sym;
/* TODO - check derived type components. */
- if (sym->ts.type == BT_DERIVED)
+ if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
continue;
if ((ar->start[i] != NULL
gfc_error ("Illegal stat-variable at %L for a PURE procedure",
&stat->where);
- if (stat->ts.type != BT_INTEGER
- && !(stat->ref && (stat->ref->type == REF_ARRAY
- || stat->ref->type == REF_COMPONENT)))
+ if ((stat->ts.type != BT_INTEGER
+ && !(stat->ref && (stat->ref->type == REF_ARRAY
+ || stat->ref->type == REF_COMPONENT)))
+ || stat->rank > 0)
gfc_error ("Stat-variable at %L must be a scalar INTEGER "
"variable", &stat->where);
- for (p = code->ext.alloc_list; p; p = p->next)
+ 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_error ("Illegal errmsg-variable at %L for a PURE procedure",
&errmsg->where);
- if (errmsg->ts.type != BT_CHARACTER
- && !(errmsg->ref
- && (errmsg->ref->type == REF_ARRAY
- || errmsg->ref->type == REF_COMPONENT)))
+ if ((errmsg->ts.type != BT_CHARACTER
+ && !(errmsg->ref
+ && (errmsg->ref->type == REF_ARRAY
+ || errmsg->ref->type == REF_COMPONENT)))
+ || errmsg->rank > 0 )
gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
"variable", &errmsg->where);
- for (p = code->ext.alloc_list; p; p = p->next)
+ 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);
/* Check that an allocate-object appears only once in the statement.
FIXME: Checking derived types is disabled. */
- for (p = code->ext.alloc_list; p; p = p->next)
+ for (p = code->ext.alloc.list; p; p = p->next)
{
pe = p->expr;
if ((pe->ref && pe->ref->type != REF_COMPONENT)
if (strcmp (fcn, "ALLOCATE") == 0)
{
- for (a = code->ext.alloc_list; a; a = a->next)
+ for (a = code->ext.alloc.list; a; a = a->next)
resolve_allocate_expr (a->expr, code);
}
else
{
- for (a = code->ext.alloc_list; a; a = a->next)
+ for (a = code->ext.alloc.list; a; a = a->next)
resolve_deallocate_expr (a->expr);
}
}
}
+/* Check if a derived type is extensible. */
+
+bool
+gfc_type_is_extensible (gfc_symbol *sym)
+{
+ return !(sym->attr.is_bind_c || sym->attr.sequence);
+}
+
+
+/* Resolve a SELECT TYPE statement. */
+
+static void
+resolve_select_type (gfc_code *code)
+{
+ gfc_symbol *selector_type;
+ gfc_code *body, *new_st, *if_st, *tail;
+ gfc_code *class_is = NULL, *default_case = NULL;
+ gfc_case *c;
+ gfc_symtree *st;
+ char name[GFC_MAX_SYMBOL_LEN];
+ gfc_namespace *ns;
+ int error = 0;
+
+ ns = code->ext.ns;
+ gfc_resolve (ns);
+
+ if (code->expr2)
+ selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
+ else
+ selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
+
+ /* Loop over TYPE IS / CLASS IS cases. */
+ for (body = code->block; body; body = body->block)
+ {
+ c = body->ext.case_list;
+
+ /* Check F03:C815. */
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && !gfc_type_is_extensible (c->ts.u.derived))
+ {
+ gfc_error ("Derived type '%s' at %L must be extensible",
+ c->ts.u.derived->name, &c->where);
+ error++;
+ continue;
+ }
+
+ /* Check F03:C816. */
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
+ {
+ gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
+ c->ts.u.derived->name, &c->where, selector_type->name);
+ error++;
+ continue;
+ }
+
+ /* Intercept the DEFAULT case. */
+ if (c->ts.type == BT_UNKNOWN)
+ {
+ /* Check F03:C818. */
+ if (default_case)
+ {
+ gfc_error ("The DEFAULT CASE at %L cannot be followed "
+ "by a second DEFAULT CASE at %L",
+ &default_case->ext.case_list->where, &c->where);
+ error++;
+ continue;
+ }
+ else
+ default_case = body;
+ }
+ }
+
+ if (error>0)
+ return;
+
+ if (code->expr2)
+ {
+ /* Insert assignment for selector variable. */
+ new_st = gfc_get_code ();
+ new_st->op = EXEC_ASSIGN;
+ new_st->expr1 = gfc_copy_expr (code->expr1);
+ new_st->expr2 = gfc_copy_expr (code->expr2);
+ ns->code = new_st;
+ }
+
+ /* Put SELECT TYPE statement inside a BLOCK. */
+ new_st = gfc_get_code ();
+ new_st->op = code->op;
+ new_st->expr1 = code->expr1;
+ new_st->expr2 = code->expr2;
+ new_st->block = code->block;
+ if (!ns->code)
+ ns->code = new_st;
+ else
+ ns->code->next = new_st;
+ code->op = EXEC_BLOCK;
+ code->expr1 = code->expr2 = NULL;
+ code->block = NULL;
+
+ code = new_st;
+
+ /* Transform to EXEC_SELECT. */
+ code->op = EXEC_SELECT;
+ gfc_add_component_ref (code->expr1, "$vptr");
+ gfc_add_component_ref (code->expr1, "$hash");
+
+ /* Loop over TYPE IS / CLASS IS cases. */
+ for (body = code->block; body; body = body->block)
+ {
+ c = body->ext.case_list;
+
+ if (c->ts.type == BT_DERIVED)
+ c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value);
+ else if (c->ts.type == BT_UNKNOWN)
+ continue;
+
+ /* Assign temporary to selector. */
+ if (c->ts.type == BT_CLASS)
+ sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
+ else
+ sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
+ st = gfc_find_symtree (ns->sym_root, name);
+ new_st = gfc_get_code ();
+ new_st->expr1 = gfc_get_variable_expr (st);
+ new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
+ if (c->ts.type == BT_DERIVED)
+ {
+ new_st->op = EXEC_POINTER_ASSIGN;
+ gfc_add_component_ref (new_st->expr2, "$data");
+ }
+ else
+ new_st->op = EXEC_POINTER_ASSIGN;
+ new_st->next = body->next;
+ body->next = new_st;
+ }
+
+ /* Take out CLASS IS cases for separate treatment. */
+ body = code;
+ while (body && body->block)
+ {
+ if (body->block->ext.case_list->ts.type == BT_CLASS)
+ {
+ /* Add to class_is list. */
+ if (class_is == NULL)
+ {
+ class_is = body->block;
+ tail = class_is;
+ }
+ else
+ {
+ for (tail = class_is; tail->block; tail = tail->block) ;
+ tail->block = body->block;
+ tail = tail->block;
+ }
+ /* Remove from EXEC_SELECT list. */
+ body->block = body->block->block;
+ tail->block = NULL;
+ }
+ else
+ body = body->block;
+ }
+
+ if (class_is)
+ {
+ gfc_symbol *vtab;
+
+ if (!default_case)
+ {
+ /* Add a default case to hold the CLASS IS cases. */
+ for (tail = code; tail->block; tail = tail->block) ;
+ tail->block = gfc_get_code ();
+ tail = tail->block;
+ tail->op = EXEC_SELECT_TYPE;
+ tail->ext.case_list = gfc_get_case ();
+ tail->ext.case_list->ts.type = BT_UNKNOWN;
+ tail->next = NULL;
+ default_case = tail;
+ }
+
+ /* More than one CLASS IS block? */
+ if (class_is->block)
+ {
+ gfc_code **c1,*c2;
+ bool swapped;
+ /* Sort CLASS IS blocks by extension level. */
+ do
+ {
+ swapped = false;
+ for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
+ {
+ c2 = (*c1)->block;
+ /* F03:C817 (check for doubles). */
+ if ((*c1)->ext.case_list->ts.u.derived->hash_value
+ == c2->ext.case_list->ts.u.derived->hash_value)
+ {
+ gfc_error ("Double CLASS IS block in SELECT TYPE "
+ "statement at %L", &c2->ext.case_list->where);
+ return;
+ }
+ if ((*c1)->ext.case_list->ts.u.derived->attr.extension
+ < c2->ext.case_list->ts.u.derived->attr.extension)
+ {
+ /* Swap. */
+ (*c1)->block = c2->block;
+ c2->block = *c1;
+ *c1 = c2;
+ swapped = true;
+ }
+ }
+ }
+ while (swapped);
+ }
+
+ /* Generate IF chain. */
+ if_st = gfc_get_code ();
+ if_st->op = EXEC_IF;
+ new_st = if_st;
+ for (body = class_is; body; body = body->block)
+ {
+ new_st->block = gfc_get_code ();
+ new_st = new_st->block;
+ new_st->op = EXEC_IF;
+ /* Set up IF condition: Call _gfortran_is_extension_of. */
+ new_st->expr1 = gfc_get_expr ();
+ new_st->expr1->expr_type = EXPR_FUNCTION;
+ new_st->expr1->ts.type = BT_LOGICAL;
+ new_st->expr1->ts.kind = 4;
+ new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
+ new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
+ new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
+ /* Set up arguments. */
+ new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
+ new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
+ gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
+ vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
+ st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+ new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
+ new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
+ new_st->next = body->next;
+ }
+ if (default_case->next)
+ {
+ new_st->block = gfc_get_code ();
+ new_st = new_st->block;
+ new_st->op = EXEC_IF;
+ new_st->next = default_case->next;
+ }
+
+ /* Replace CLASS DEFAULT code by the IF chain. */
+ default_case->next = if_st;
+ }
+
+ resolve_select (code);
+
+}
+
+
/* Resolve a transfer statement. This is making sure that:
-- a derived type being transferred has only non-pointer components
-- a derived type being transferred doesn't have private components, unless
}
-/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
+/* Resolve a BLOCK construct statement. */
+
+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. */
+
+ gfc_resolve (code->ext.ns);
+}
+
+
+/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
DO code nodes. */
static void resolve_code (gfc_code *, gfc_namespace *);
resolve_branch (b->label1, b);
break;
+ case EXEC_BLOCK:
+ resolve_block_construct (b);
+ break;
+
case EXEC_SELECT:
+ case EXEC_SELECT_TYPE:
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
break;
default:
- gfc_internal_error ("resolve_block(): Bad block type");
+ gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
}
resolve_code (b->next, ns);
if (gfc_extend_assign (code, ns) == SUCCESS)
{
- lhs = code->ext.actual->expr;
- rhs = code->ext.actual->next->expr;
- if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
+ gfc_expr** rhsptr;
+
+ if (code->op == EXEC_ASSIGN_CALL)
{
- gfc_error ("Subroutine '%s' called instead of assignment at "
- "%L must be PURE", code->symtree->n.sym->name,
- &code->loc);
- return rval;
+ lhs = code->ext.actual->expr;
+ rhsptr = &code->ext.actual->next->expr;
+ }
+ else
+ {
+ gfc_actual_arglist* args;
+ gfc_typebound_proc* tbp;
+
+ gcc_assert (code->op == EXEC_COMPCALL);
+
+ args = code->expr1->value.compcall.actual;
+ lhs = args->expr;
+ rhsptr = &args->next->expr;
+
+ tbp = code->expr1->value.compcall.tbp;
+ gcc_assert (!tbp->is_generic);
}
/* Make a temporary rhs when there is a default initializer
and rhs is the same symbol as the lhs. */
- if (rhs->expr_type == EXPR_VARIABLE
- && rhs->symtree->n.sym->ts.type == BT_DERIVED
- && has_default_initializer (rhs->symtree->n.sym->ts.u.derived)
- && (lhs->symtree->n.sym == rhs->symtree->n.sym))
- code->ext.actual->next->expr = gfc_get_parentheses (rhs);
+ if ((*rhsptr)->expr_type == EXPR_VARIABLE
+ && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
+ && has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
+ && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
+ *rhsptr = gfc_get_parentheses (*rhsptr);
return true;
}
if (rhs->is_boz
&& gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
- "a DATA statement and outside INT/REAL/DBLE/CMPLX",
- &code->loc) == FAILURE)
+ "a DATA statement and outside INT/REAL/DBLE/CMPLX",
+ &code->loc) == FAILURE)
return false;
/* Handle the case of a BOZ literal on the RHS. */
rlen = rhs->value.character.length;
else if (rhs->ts.u.cl != NULL
- && rhs->ts.u.cl->length != NULL
+ && rhs->ts.u.cl->length != NULL
&& rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
}
}
+ /* F03:7.4.1.2. */
+ if (lhs->ts.type == BT_CLASS)
+ {
+ gfc_error ("Variable must not be polymorphic in assignment at %L",
+ &lhs->where);
+ return false;
+ }
+
gfc_check_assign (lhs, rhs, 1);
return false;
}
+
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
if (gfc_resolve_expr (code->expr2) == FAILURE)
t = FAILURE;
+ if (code->op == EXEC_ALLOCATE
+ && gfc_resolve_expr (code->expr3) == FAILURE)
+ t = FAILURE;
+
switch (code->op)
{
case EXEC_NOP:
case EXEC_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:
+ case EXEC_ASSIGN_CALL:
break;
case EXEC_ENTRY:
break;
if (resolve_ordinary_assign (code, ns))
- goto call;
-
+ {
+ if (code->op == EXEC_COMPCALL)
+ goto compcall;
+ else
+ goto call;
+ }
break;
case EXEC_LABEL_ASSIGN:
break;
case EXEC_COMPCALL:
- resolve_typebound_call (code);
+ compcall:
+ if (code->expr1->symtree
+ && code->expr1->symtree->n.sym->ts.type == BT_CLASS)
+ resolve_class_typebound_call (code);
+ else
+ resolve_typebound_call (code);
break;
case EXEC_CALL_PPC:
- resolve_ppc_call (code);
+ resolve_ppc_call (code);
break;
case EXEC_SELECT:
resolve_select (code);
break;
+ case EXEC_SELECT_TYPE:
+ resolve_select_type (code);
+ break;
+
+ case EXEC_BLOCK:
+ gfc_resolve (code->ext.ns);
+ break;
+
case EXEC_DO:
if (code->ext.iterator != NULL)
{
break;
case BT_COMPLEX:
-#ifdef HAVE_mpc
mpc_init2 (init_expr->value.complex, mpfr_get_default_prec());
-#else
- mpfr_init (init_expr->value.complex.r);
- mpfr_init (init_expr->value.complex.i);
-#endif
switch (gfc_option.flag_init_real)
{
case GFC_INIT_REAL_SNAN:
break;
case GFC_INIT_REAL_ZERO:
-#ifdef HAVE_mpc
mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
-#else
- mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
- mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
-#endif
break;
default:
/* For saved variables, we don't want to add an initializer at
function entry, so we just add a static initializer. */
- if (sym->attr.save || sym->ns->save_all)
+ if (sym->attr.save || sym->ns->save_all
+ || gfc_option.flag_max_stack_var_size == 0)
{
/* Don't clobber an existing initializer! */
gcc_assert (sym->value == NULL);
if (sym->attr.allocatable)
{
if (sym->attr.dimension)
- gfc_error ("Allocatable array '%s' at %L must have "
- "a deferred shape", sym->name, &sym->declared_at);
- else
- gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
- sym->name, &sym->declared_at);
+ {
+ gfc_error ("Allocatable array '%s' at %L must have "
+ "a deferred shape", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+ else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
+ "may not be ALLOCATABLE", sym->name,
+ &sym->declared_at) == FAILURE)
return FAILURE;
}
}
else
{
- if (!mp_flag && !sym->attr.allocatable
- && !sym->attr.pointer && !sym->attr.dummy)
+ if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
+ && !sym->attr.dummy && sym->ts.type != BT_CLASS)
{
gfc_error ("Array '%s' at %L cannot have a deferred shape",
sym->name, &sym->declared_at);
}
-/* Check if a derived type is extensible. */
-
-static bool
-type_is_extensible (gfc_symbol *sym)
-{
- return !(sym->attr.is_bind_c || sym->attr.sequence);
-}
-
-
/* Additional checks for symbols with flavor variable and derived
type. To be called from resolve_fl_variable. */
static gfc_try
resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
{
- gcc_assert (sym->ts.type == BT_DERIVED);
+ gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
/* Check to see if a derived type is blocked from being host
associated by the presence of another class I symbol in the same
return FAILURE;
}
- if (sym->ts.is_class)
+ if (sym->ts.type == BT_CLASS)
{
/* C502. */
- if (!type_is_extensible (sym->ts.u.derived))
+ 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->name, sym->name, &sym->declared_at);
+ sym->ts.u.derived->components->ts.u.derived->name,
+ sym->name, &sym->declared_at);
return FAILURE;
}
/* C509. */
- if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer))
+ /* 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);
}
no_init_error:
- if (sym->ts.type == BT_DERIVED)
+ if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
return resolve_fl_variable_derived (sym, no_init_flag);
return SUCCESS;
&& resolve_charlen (cl) == FAILURE)
return FAILURE;
- if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
+ if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
+ && sym->attr.proc == PROC_ST_FUNCTION)
{
- if (sym->attr.proc == PROC_ST_FUNCTION)
- {
- gfc_error ("Character-valued statement function '%s' at %L must "
- "have constant length", sym->name, &sym->declared_at);
- return FAILURE;
- }
-
- if (sym->attr.external && sym->formal == NULL
- && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
- {
- gfc_error ("Automatic character length function '%s' at %L must "
- "have an explicit interface", sym->name,
- &sym->declared_at);
- return FAILURE;
- }
+ gfc_error ("Character-valued statement function '%s' at %L must "
+ "have constant length", sym->name, &sym->declared_at);
+ return FAILURE;
}
}
if (proc_pass_arg != argpos && old_pass_arg != argpos
&& !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
{
- gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in"
- " in respect to the overridden procedure",
+ gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
+ "in respect to the overridden procedure",
proc_formal->sym->name, proc->name, &where);
return FAILURE;
}
sym1 = t1->specific->u.specific->n.sym;
sym2 = t2->specific->u.specific->n.sym;
+ if (sym1 == sym2)
+ return SUCCESS;
+
/* Both must be SUBROUTINEs or both must be FUNCTIONs. */
if (sym1->attr.subroutine != sym2->attr.subroutine
|| sym1->attr.function != sym2->attr.function)
}
/* Compare the interfaces. */
- if (gfc_compare_interfaces (sym1, sym2, 1, 0, NULL, 0))
+ if (gfc_compare_interfaces (sym1, sym2, NULL, 1, 0, NULL, 0))
{
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
sym1->name, sym2->name, generic_name, &where);
/* Look for an inherited specific binding. */
if (super_type)
{
- inherited = gfc_find_typebound_proc (super_type, NULL,
- target_name, true);
+ inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
+ true, NULL);
if (inherited)
{
if (super_type)
{
gfc_symtree* overridden;
- overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
+ overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
+ true, NULL);
if (overridden && overridden->n.tb)
st->n.tb->overridden = overridden->n.tb;
}
+/* Retrieve the target-procedure of an operator binding and do some checks in
+ common for intrinsic and user-defined type-bound operators. */
+
+static gfc_symbol*
+get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
+{
+ gfc_symbol* target_proc;
+
+ gcc_assert (target->specific && !target->specific->is_generic);
+ target_proc = target->specific->u.specific->n.sym;
+ gcc_assert (target_proc);
+
+ /* All operator bindings must have a passed-object dummy argument. */
+ if (target->specific->nopass)
+ {
+ gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
+ return NULL;
+ }
+
+ return target_proc;
+}
+
+
/* Resolve a type-bound intrinsic operator. */
static gfc_try
super_type = gfc_get_derived_super_type (derived);
if (super_type && super_type->f2k_derived)
p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
- op, true);
+ op, true, NULL);
else
p->overridden = NULL;
{
gfc_symbol* target_proc;
- gcc_assert (target->specific && !target->specific->is_generic);
- target_proc = target->specific->u.specific->n.sym;
- gcc_assert (target_proc);
+ target_proc = get_checked_tb_operator_target (target, p->where);
+ if (!target_proc)
+ goto error;
if (!gfc_check_operator_interface (target_proc, op, p->where))
- return FAILURE;
+ goto error;
}
return SUCCESS;
{
gfc_symtree* overridden;
overridden = gfc_find_typebound_user_op (super_type, NULL,
- stree->name, true);
+ stree->name, true, NULL);
if (overridden && overridden->n.tb)
stree->n.tb->overridden = overridden->n.tb;
{
gfc_symbol* target_proc;
- gcc_assert (target->specific && !target->specific->is_generic);
- target_proc = target->specific->u.specific->n.sym;
- gcc_assert (target_proc);
+ target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
+ if (!target_proc)
+ goto error;
if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
goto error;
me_arg = proc->formal->sym;
}
- /* Now check that the argument-type matches. */
+ /* Now check that the argument-type matches and the passed-object
+ dummy argument is generally fine. */
+
gcc_assert (me_arg);
- if (me_arg->ts.type != BT_DERIVED
- || me_arg->ts.u.derived != resolve_bindings_derived)
+
+ if (me_arg->ts.type != BT_CLASS)
+ {
+ gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
+ " at %L", proc->name, &where);
+ goto error;
+ }
+
+ if (me_arg->ts.u.derived->components->ts.u.derived
+ != resolve_bindings_derived)
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
" the derived-type '%s'", me_arg->name, proc->name,
me_arg->name, &where, resolve_bindings_derived->name);
goto error;
}
-
- if (!me_arg->ts.is_class)
+
+ 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)
{
- gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
- " at %L", proc->name, &where);
+ 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)
+ {
+ 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)
+ {
+ gfc_error ("Passed-object dummy argument of '%s' at %L must not"
+ " be POINTER", proc->name, &where);
goto error;
}
}
{
gfc_symtree* overridden;
overridden = gfc_find_typebound_proc (super_type, NULL,
- stree->name, true);
+ stree->name, true, NULL);
if (overridden && overridden->n.tb)
stree->n.tb->overridden = overridden->n.tb;
resolve_typebound_procedures (gfc_symbol* derived)
{
int op;
- bool found_op;
if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
return SUCCESS;
gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
&resolve_typebound_procedure);
- found_op = (derived->f2k_derived->tb_uop_root != NULL);
if (derived->f2k_derived->tb_uop_root)
gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
&resolve_typebound_user_op);
if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
p) == FAILURE)
resolve_bindings_result = FAILURE;
- if (p)
- found_op = true;
- }
-
- /* FIXME: Remove this (and found_op) once calls are fully implemented. */
- if (found_op)
- {
- gfc_error ("Derived type '%s' at %L contains type-bound OPERATOR's,"
- " they are not yet implemented.",
- derived->name, &derived->declared_at);
- resolve_bindings_result = FAILURE;
}
return resolve_bindings_result;
if (st->n.tb && st->n.tb->deferred)
{
gfc_symtree* overriding;
- overriding = gfc_find_typebound_proc (sub, NULL, st->name, true);
+ overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
gcc_assert (overriding && overriding->n.tb);
if (overriding->n.tb->deferred)
{
return FAILURE;
/* An ABSTRACT type must be extensible. */
- if (sym->attr.abstract && !type_is_extensible (sym))
+ if (sym->attr.abstract && !gfc_type_is_extensible (sym))
{
gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
sym->name, &sym->declared_at);
/* Copy char length. */
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
- c->ts.u.cl = gfc_new_charlen (sym->ns);
- c->ts.u.cl->resolved = ifc->ts.u.cl->resolved;
- c->ts.u.cl->length = gfc_copy_expr (ifc->ts.u.cl->length);
- /* TODO: gfc_expr_replace_symbols (c->ts.u.cl->length, c);*/
+ c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
+ gfc_expr_replace_comp (c->ts.u.cl->length, c);
}
}
else if (c->ts.interface->name[0] != '\0')
}
else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
{
- c->ts = *gfc_get_default_type (c->name, NULL);
- c->attr.implicit_type = 1;
+ /* Since PPCs are not implicitly typed, a PPC without an explicit
+ interface must be a subroutine. */
+ gfc_add_subroutine (&c->attr, c->name, &c->loc);
}
/* Procedure pointer components: Check PASS arg. */
/* Now check that the argument-type matches. */
gcc_assert (me_arg);
- if (me_arg->ts.type != BT_DERIVED
- || me_arg->ts.u.derived != sym)
+ 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))
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
" the derived type '%s'", me_arg->name, c->name,
return FAILURE;
}
- if (type_is_extensible (sym) && !me_arg->ts.is_class)
+ if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
- " at %L", c->name, &c->loc);
+ " at %L", c->name, &c->loc);
}
/* If this type is an extension, see if this component has the same name
as an inherited type-bound procedure. */
if (super_type
- && gfc_find_typebound_proc (super_type, NULL, c->name, true))
+ && 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"
" inherited type-bound procedure",
return FAILURE;
}
- if (c->ts.type == BT_CHARACTER)
+ if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
{
if (c->ts.u.cl->length == NULL
|| (resolve_charlen (c->ts.u.cl) == FAILURE)
}
/* C437. */
- if (c->ts.type == BT_DERIVED && c->ts.is_class
- && !(c->attr.pointer || c->attr.allocatable))
+ if (c->ts.type == BT_CLASS
+ && !(c->ts.u.derived->components->attr.pointer
+ || c->ts.u.derived->components->attr.allocatable))
{
gfc_error ("Component '%s' with CLASS at %L must be allocatable "
"or pointer", c->name, &c->loc);
/* Copy char length. */
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
- sym->ts.u.cl = gfc_new_charlen (sym->ns);
- sym->ts.u.cl->resolved = ifc->ts.u.cl->resolved;
- sym->ts.u.cl->length = gfc_copy_expr (ifc->ts.u.cl->length);
+ sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
}
}
/* Resolve formal namespaces. */
if (sym->formal_ns && sym->formal_ns != gfc_current_ns
- && !sym->attr.contained)
+ && !sym->attr.contained && !sym->attr.intrinsic)
gfc_resolve (sym->formal_ns);
/* Make sure the formal namespace is present. */
{
while (mpz_cmp_ui (values.left, 0) == 0)
{
- if (!gfc_is_constant_expr (values.vnode->expr))
- gfc_error ("non-constant DATA value at %L",
- &values.vnode->expr->where);
if (values.vnode->next == NULL)
return FAILURE;
seq_type eq_type, last_eq_type;
gfc_typespec *last_ts;
int object, cnt_protected;
- const char *value_name;
const char *msg;
- value_name = NULL;
last_ts = &eq->expr->symtree->n.sym->ts;
first_sym = eq->expr->symtree->n.sym;
resolve_codes (n);
gfc_current_ns = ns;
- cs_base = NULL;
+
+ /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
+ if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
+ cs_base = NULL;
+
/* Set to an out of range value. */
current_entry_id = -1;
OSDN Git Service
