"for pointer component '%s' should be a POINTER or "
"a TARGET", &cons->expr->where, comp->name);
}
+
+ /* F2003, C1272 (3). */
+ if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
+ && gfc_impure_variable (cons->expr->symtree->n.sym))
+ {
+ t = FAILURE;
+ gfc_error ("Invalid expression in the derived type constructor for pointer "
+ "component '%s' at %L in PURE procedure", comp->name,
+ &cons->expr->where);
+ }
}
return t;
}
/* 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)
+ of course be referenced), expr->value.function.esym will be set. */
+ if (sym && sym->attr.abstract && !expr->value.function.esym)
{
gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
sym->name, &expr->where);
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
ts.kind = gfc_index_integer_kind;
if (derived == NULL)
derived = e->symtree->n.sym->ts.u.derived;
+ if (derived->attr.is_class)
+ derived = derived->components->ts.u.derived;
+
c = derived->components;
for (; c; c = c->next)
po->expr_type = EXPR_VARIABLE;
po->symtree = e->symtree;
po->ref = gfc_copy_ref (e->ref);
+ po->where = e->where;
}
if (gfc_resolve_expr (po) == FAILURE)
po->expr_type = EXPR_VARIABLE;
po->symtree = e->symtree;
po->ref = gfc_copy_ref (e->ref);
+ po->where = e->where;
/* Remove PPC reference. */
ref = &po->ref;
while ((*ref)->next)
- (*ref) = (*ref)->next;
+ ref = &(*ref)->next;
gfc_free_ref_list (*ref);
*ref = NULL;
resolving subroutine class methods, since we do not have to add a
gfc_code each time. */
static gfc_try
-resolve_compcall (gfc_expr* e, bool fcn)
+resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
return FAILURE;
e->value.function.actual = newactual;
- e->value.function.name = e->value.compcall.name;
+ e->value.function.name = NULL;
e->value.function.esym = target->n.sym;
e->value.function.class_esym = NULL;
e->value.function.isym = NULL;
e->ts = target->n.sym->ts;
e->expr_type = EXPR_FUNCTION;
- /* 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;
+ /* 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;
}
static void check_class_members (gfc_symbol *);
static gfc_try class_try;
static bool fcn_flag;
-static gfc_symbol *class_object;
static void
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 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)
+ 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;
+ if (!derived->attr.abstract)
+ {
+ e->value.compcall.base_object->ts.type = BT_DERIVED;
+ e->value.compcall.base_object->ts.u.derived = derived;
}
}
/* Do the renaming, PASSing, generic => specific and other
good things for each class member. */
- class_try = (resolve_compcall (e, fcn_flag) == SUCCESS)
+ class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS)
? class_try : FAILURE;
/* Now transfer the found symbol to the esym list. */
}
-/* Resolve a CLASS typebound function, or 'method'. */
+/* 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. */
+
static gfc_try
-resolve_class_compcall (gfc_expr* e)
+resolve_typebound_function (gfc_expr* e)
{
gfc_symbol *derived, *declared;
gfc_ref *new_ref;
gfc_symtree *st;
st = e->symtree;
- class_object = st->n.sym;
+ if (st == NULL)
+ return resolve_compcall (e, true, false);
/* 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)
+ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+ || (!class_ref && st->n.sym->ts.type != BT_CLASS))
{
gfc_free_ref_list (new_ref);
- return resolve_compcall (e, true);
+ return resolve_compcall (e, true, false);
}
/* Resolve the argument expressions, */
list_e = gfc_copy_expr (e);
check_class_members (derived);
- class_try = (resolve_compcall (e, true) == SUCCESS)
+ class_try = (resolve_compcall (e, true, false) == SUCCESS)
? class_try : FAILURE;
/* Transfer the class list to the original expression. Note that
return class_try;
}
-/* Resolve a CLASS typebound subroutine, or 'method'. */
+/* 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. */
+
static gfc_try
-resolve_class_typebound_call (gfc_code *code)
+resolve_typebound_subroutine (gfc_code *code)
{
gfc_symbol *derived, *declared;
gfc_ref *new_ref;
gfc_symtree *st;
st = code->expr1->symtree;
- class_object = st->n.sym;
+ if (st == NULL)
+ return resolve_typebound_call (code);
/* 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)
+ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+ || (!class_ref && st->n.sym->ts.type != BT_CLASS))
{
gfc_free_ref_list (new_ref);
return resolve_typebound_call (code);
break;
case EXPR_COMPCALL:
- if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
- t = resolve_class_compcall (e);
- else
- t = resolve_compcall (e, true);
+ t = resolve_typebound_function (e);
break;
case EXPR_SUBSTRING:
gfc_symbol *sym;
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;
sym->name, &e->where);
return FAILURE;
}
+
+ if (!code->expr3)
+ {
+ /* 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_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;
+ }
+ }
if (pointer || dimension == 0)
return SUCCESS;
if (lhs->ts.type == BT_DERIVED
&& lhs->expr_type == EXPR_VARIABLE
&& lhs->ts.u.derived->attr.pointer_comp
+ && rhs->expr_type == EXPR_VARIABLE
&& gfc_impure_variable (rhs->symtree->n.sym))
{
gfc_error ("The impure variable at %L is assigned to "
case EXEC_OMP_DO:
gfc_resolve_omp_do_blocks (code, ns);
break;
+ case EXEC_SELECT_TYPE:
+ gfc_current_ns = code->ext.ns;
+ gfc_resolve_blocks (code->block, gfc_current_ns);
+ gfc_current_ns = ns;
+ break;
case EXEC_OMP_WORKSHARE:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 1;
case EXEC_COMPCALL:
compcall:
- if (code->expr1->symtree
- && code->expr1->symtree->n.sym->ts.type == BT_CLASS)
- resolve_class_typebound_call (code);
- else
- resolve_typebound_call (code);
+ resolve_typebound_subroutine (code);
break;
case EXEC_CALL_PPC:
value, the length of character entities declared is zero." */
if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
{
- gfc_warning_now ("CHARACTER variable has zero length at %L",
- &cl->length->where);
+ if (gfc_option.warn_surprising)
+ gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
+ " the length has been set to zero",
+ &cl->length->where, i);
gfc_replace_expr (cl->length, gfc_int_expr (0));
}
&& 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_error("Object '%s' at %L must have the SAVE attribute for "
- "default initialization of a component",
- sym->name, &sym->declared_at);
- return FAILURE;
- }
+ && 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)
{
{
gfc_formal_arglist *arg;
- if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
- gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
- "interfaces", sym->name, &sym->declared_at);
-
if (sym->attr.function
&& resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
return FAILURE;
}
/* Compare the interfaces. */
- if (gfc_compare_interfaces (sym1, sym2, NULL, 1, 0, NULL, 0))
+ if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
{
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
sym1->name, sym2->name, generic_name, &where);
&& resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
return FAILURE;
+ /* If this type is an extension, set the accessibility of the parent
+ component. */
+ if (super_type && c == sym->components
+ && strcmp (super_type->name, c->name) == 0)
+ c->attr.access = super_type->attr.access;
+
/* If this type is an extension, see if this component has the same name
as an inherited type-bound procedure. */
if (super_type
arguments. */
if (sym->as != NULL
- && (sym->as->type == AS_ASSUMED_SIZE
+ && ((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
|| sym->as->type == AS_ASSUMED_SHAPE)
&& sym->attr.dummy == 0)
{
gfc_impure_variable (gfc_symbol *sym)
{
gfc_symbol *proc;
+ gfc_namespace *ns;
if (sym->attr.use_assoc || sym->attr.in_common)
return 1;
- if (sym->ns != gfc_current_ns)
- return !sym->attr.function;
+ /* Check if the symbol's ns is inside the pure procedure. */
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ {
+ if (ns == sym->ns)
+ break;
+ if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
+ return 1;
+ }
proc = sym->ns->proc_name;
if (sym->attr.dummy && gfc_pure (proc)
}
-/* Test whether a symbol is pure or not. For a NULL pointer, checks the
- symbol of the current procedure. */
+/* Test whether a symbol is pure or not. For a NULL pointer, checks if the
+ current namespace is inside a pure procedure. */
int
gfc_pure (gfc_symbol *sym)
{
symbol_attribute attr;
+ gfc_namespace *ns;
if (sym == NULL)
- sym = gfc_current_ns->proc_name;
- if (sym == NULL)
- return 0;
+ {
+ /* Check if the current namespace or one of its parents
+ belongs to a pure procedure. */
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ {
+ sym = ns->proc_name;
+ if (sym == NULL)
+ return 0;
+ attr = sym->attr;
+ if (attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental))
+ return 1;
+ }
+ return 0;
+ }
attr = sym->attr;
OSDN Git Service
