/* Perform type resolution on the various structures.
- Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+ 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
resolve_intrinsic (ifc, &ifc->declared_at);
if (ifc->result)
- sym->ts = ifc->result->ts;
+ {
+ sym->ts = ifc->result->ts;
+ sym->result = sym;
+ }
else
sym->ts = ifc->ts;
sym->ts.interface = ifc;
sym->attr.recursive = ifc->attr.recursive;
sym->attr.always_explicit = ifc->attr.always_explicit;
sym->attr.ext_attr |= ifc->attr.ext_attr;
+ sym->attr.is_bind_c = ifc->attr.is_bind_c;
/* Copy array spec. */
sym->as = gfc_copy_array_spec (ifc->as);
if (sym->as)
continue;
}
+ if (proc->attr.implicit_pure && !gfc_pure(sym))
+ proc->attr.implicit_pure = 0;
+
if (gfc_elemental (proc))
{
gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
continue;
}
- if (sym->ts.type == BT_UNKNOWN)
- {
- if (!sym->attr.function || sym->result == sym)
- gfc_set_default_type (sym, 1, sym->ns);
- }
+ if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
+ && (!sym->attr.function || sym->result == sym))
+ gfc_set_default_type (sym, 1, sym->ns);
gfc_resolve_array_spec (sym->as, 0);
shape until we know if it has the pointer or allocatable attributes.
*/
if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
- && !(sym->attr.pointer || sym->attr.allocatable))
+ && !(sym->attr.pointer || sym->attr.allocatable)
+ && sym->attr.flavor != FL_PROCEDURE)
{
sym->as->type = AS_ASSUMED_SHAPE;
for (i = 0; i < sym->as->rank; i++)
&& sym->attr.flavor != FL_PROCEDURE)
{
if (proc->attr.function && sym->attr.intent != INTENT_IN)
- gfc_error ("Argument '%s' of pure function '%s' at %L must be "
- "INTENT(IN)", sym->name, proc->name,
- &sym->declared_at);
+ {
+ if (sym->attr.value)
+ gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s' "
+ "of pure function '%s' at %L with VALUE "
+ "attribute but without INTENT(IN)", sym->name,
+ proc->name, &sym->declared_at);
+ else
+ gfc_error ("Argument '%s' of pure function '%s' at %L must be "
+ "INTENT(IN) or VALUE", sym->name, proc->name,
+ &sym->declared_at);
+ }
if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
- gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
- "have its INTENT specified", sym->name, proc->name,
- &sym->declared_at);
+ {
+ if (sym->attr.value)
+ gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s' "
+ "of pure subroutine '%s' at %L with VALUE "
+ "attribute but without INTENT", sym->name,
+ proc->name, &sym->declared_at);
+ else
+ gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
+ "have its INTENT specified or have the VALUE "
+ "attribute", sym->name, proc->name, &sym->declared_at);
+ }
+ }
+
+ if (proc->attr.implicit_pure && !sym->attr.pointer
+ && sym->attr.flavor != FL_PROCEDURE)
+ {
+ if (proc->attr.function && sym->attr.intent != INTENT_IN)
+ proc->attr.implicit_pure = 0;
+
+ if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
+ proc->attr.implicit_pure = 0;
}
if (gfc_elemental (proc))
if (sym->result->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->result->ts.u.cl;
- if (!cl || !cl->length)
+ if ((!cl || !cl->length) && !sym->result->ts.deferred)
{
/* See if this is a module-procedure and adapt error message
accordingly. */
}
+static gfc_try resolve_fl_derived0 (gfc_symbol *sym);
+
+
/* Resolve all of the elements of a structure constructor and make sure that
the types are correct. The 'init' flag indicates that the given
constructor is an initializer. */
t = SUCCESS;
if (expr->ts.type == BT_DERIVED)
- resolve_symbol (expr->ts.u.derived);
+ resolve_fl_derived0 (expr->ts.u.derived);
cons = gfc_constructor_first (expr->value.constructor);
/* A constructor may have references if it is the result of substituting a
!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
- if (strcmp (comp->name, "$extends") == 0)
+ if (strcmp (comp->name, "_extends") == 0)
{
- /* Can afford to be brutal with the $extends initializer.
+ /* 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;
cl2->next = cl->next;
gfc_free_expr (cl->length);
- gfc_free (cl);
+ free (cl);
}
cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
comp->name, &cons->expr->where);
}
+ if (gfc_implicit_pure (NULL)
+ && cons->expr->expr_type == EXPR_VARIABLE
+ && (gfc_impure_variable (cons->expr->symtree->n.sym)
+ || gfc_is_coindexed (cons->expr)))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
}
return t;
static gfc_try
resolve_intrinsic (gfc_symbol *sym, locus *loc)
{
- gfc_intrinsic_sym* isym;
+ gfc_intrinsic_sym* isym = NULL;
const char* symstd;
if (sym->formal)
return SUCCESS;
+ /* Already resolved. */
+ if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
+ return SUCCESS;
+
/* We already know this one is an intrinsic, so we don't call
gfc_is_intrinsic for full checking but rather use gfc_find_function and
gfc_find_subroutine directly to check whether it is a function or
subroutine. */
- if ((isym = gfc_find_function (sym->name)))
+ if (sym->intmod_sym_id)
+ isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
+ else
+ isym = gfc_find_function (sym->name);
+
+ if (isym)
{
if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
&& !sym->attr.implicit_type)
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
- gfc_component *comp;
for (; arg; arg = arg->next)
{
continue;
}
- if (gfc_is_proc_ptr_comp (e, &comp))
- {
- e->ts = comp->ts;
- 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 (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.generic
&& no_formal_args
if (sym->attr.contained && !sym->attr.use_assoc
&& sym->ns->proc_name->attr.flavor != FL_MODULE)
{
- gfc_error ("Internal procedure '%s' is not allowed as an "
- "actual argument at %L", sym->name, &e->where);
+ if (gfc_notify_std (GFC_STD_F2008,
+ "Fortran 2008: Internal procedure '%s' is"
+ " used as actual argument at %L",
+ sym->name, &e->where) == FAILURE)
+ return FAILURE;
}
if (sym->attr.elemental && !sym->attr.intrinsic)
}
-/* Go through each actual argument in ACTUAL and see if it can be
- implemented as an inlined, non-copying intrinsic. FNSYM is the
- function being called, or NULL if not known. */
-
-static void
-find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
-{
- gfc_actual_arglist *ap;
- gfc_expr *expr;
-
- for (ap = actual; ap; ap = ap->next)
- if (ap->expr
- && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
- && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
- NOT_ELEMENTAL))
- ap->expr->inline_noncopying_intrinsic = 1;
-}
-
-
/* This function does the checking of references to global procedures
as defined in sections 18.1 and 14.1, respectively, of the Fortran
77 and 95 standards. It checks for a gsymbol for the name, making
if (!gsym->ns->resolved)
{
gfc_dt_list *old_dt_list;
+ struct gfc_omp_saved_state old_omp_state;
/* Stash away derived types so that the backend_decls do not
get mixed up. */
old_dt_list = gfc_derived_types;
gfc_derived_types = NULL;
+ /* And stash away openmp state. */
+ gfc_omp_save_and_clear_state (&old_omp_state);
gfc_resolve (gsym->ns);
/* Restore the derived types of this namespace. */
gfc_derived_types = old_dt_list;
+ /* And openmp state. */
+ gfc_omp_restore_state (&old_omp_state);
}
/* Make sure that translation for the gsymbol occurs before
/* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
- && def_sym->ts.u.cl->length != NULL)
+ && def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL)
{
gfc_charlen *cl = sym->ts.u.cl;
switch (ref->type)
{
case REF_SUBSTRING:
- if (ref->u.ss.length != NULL
- && ref->u.ss.length->length != NULL
- && ref->u.ss.start
- && ref->u.ss.start->expr_type == EXPR_CONSTANT
- && ref->u.ss.end
- && ref->u.ss.end->expr_type == EXPR_CONSTANT)
- {
- start = (int) mpz_get_si (ref->u.ss.start->value.integer);
- end = (int) mpz_get_si (ref->u.ss.end->value.integer);
- if (end - start + 1 != 1)
- retval = FAILURE;
- }
- else
- retval = FAILURE;
+ if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
+ || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
+ retval = FAILURE;
break;
+
case REF_ARRAY:
if (ref->u.ar.type == AR_ELEMENT)
retval = SUCCESS;
{
/* We have constant lower and upper bounds. If the
difference between is 1, it can be considered a
- scalar. */
+ scalar.
+ FIXME: Use gfc_dep_compare_expr instead. */
start = (int) mpz_get_si
(ref->u.ar.as->lower[0]->value.integer);
end = (int) mpz_get_si
}
else if (sym->intmod_sym_id == ISOCBINDING_LOC)
{
+ gfc_ref *ref;
+ bool seen_section;
+
/* Make sure we have either the target or pointer attribute. */
if (!arg_attr.target && !arg_attr.pointer)
{
retval = FAILURE;
}
+ if (gfc_is_coindexed (args->expr))
+ {
+ gfc_error_now ("Coindexed argument not permitted"
+ " in '%s' call at %L", name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
+
+ /* Follow references to make sure there are no array
+ sections. */
+ seen_section = false;
+
+ for (ref=args->expr->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY)
+ {
+ if (ref->u.ar.type == AR_SECTION)
+ seen_section = true;
+
+ if (ref->u.ar.type != AR_ELEMENT)
+ {
+ gfc_ref *r;
+ for (r = ref->next; r; r=r->next)
+ if (r->type == REF_COMPONENT)
+ {
+ gfc_error_now ("Array section not permitted"
+ " in '%s' call at %L", name,
+ &(args->expr->where));
+ retval = FAILURE;
+ break;
+ }
+ }
+ }
+ }
+
+ if (seen_section && retval == SUCCESS)
+ gfc_warning ("Array section in '%s' call at %L", name,
+ &(args->expr->where));
+
/* See if we have interoperable type and type param. */
if (verify_c_interop (arg_ts) == SUCCESS
|| gfc_check_any_c_kind (arg_ts) == SUCCESS)
/* Resolve a function call, which means resolving the arguments, then figuring
out which entity the name refers to. */
-/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
- to INTENT(OUT) or INTENT(INOUT). */
static gfc_try
resolve_function (gfc_expr *expr)
&& sym->ts.u.cl
&& sym->ts.u.cl->length == NULL
&& !sym->attr.dummy
+ && !sym->ts.deferred
&& expr->value.function.esym == NULL
&& !sym->attr.contained)
{
}
}
+ if (!pure_function (expr, &name) && name && gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
/* Functions without the RECURSIVE attribution are not allowed to
* call themselves. */
if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
}
- if (t == SUCCESS
- && !((expr->value.function.esym
- && expr->value.function.esym->attr.elemental)
- ||
- (expr->value.function.isym
- && expr->value.function.isym->elemental)))
- find_noncopying_intrinsics (expr->value.function.esym,
- expr->value.function.actual);
-
/* Make sure that the expression has a typespec that works. */
if (expr->ts.type == BT_UNKNOWN)
{
if (resolve_elemental_actual (NULL, c) == FAILURE)
return FAILURE;
- if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
- find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
return t;
}
sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
e->value.op.uop->name, gfc_typename (&op1->ts));
else
- sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
- e->value.op.uop->name, gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ {
+ sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
+ e->value.op.uop->name, gfc_typename (&op1->ts),
+ gfc_typename (&op2->ts));
+ e->value.op.uop->op->sym->attr.referenced = 1;
+ }
goto bad_op;
switch (ar->dimen_type[i])
{
case DIMEN_VECTOR:
+ case DIMEN_THIS_IMAGE:
break;
case DIMEN_STAR:
if (ar->codimen != 0)
for (i = as->rank; i < as->rank + as->corank; i++)
{
- if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
+ if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
+ && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
{
gfc_error ("Coindex of codimension %d must be a scalar at %L",
i + 1 - as->rank, &ar->where);
return FAILURE;
}
+ if (as->corank && ar->codimen == 0)
+ {
+ int n;
+ ar->codimen = as->corank;
+ for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
+ ar->dimen_type[n] = DIMEN_THIS_IMAGE;
+ }
+
return SUCCESS;
}
for (ref = e->ref; ref; ref = ref->next)
{
+ if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
+ && ref->u.c.component->attr.function && !ref->next)
+ rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
+
if (ref->type != REF_ARRAY)
continue;
{
gfc_ref *ref, *ref2 = NULL;
- if (e->ts.type == BT_CLASS)
- {
- gfc_error ("Polymorphic subobject of coindexed object at %L",
- &e->where);
- t = FAILURE;
- }
-
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT)
if (ref->type == REF_COMPONENT)
break;
+ /* Expression itself is not coindexed object. */
+ if (ref && e->ts.type == BT_CLASS)
+ {
+ gfc_error ("Polymorphic subobject of coindexed object at %L",
+ &e->where);
+ t = FAILURE;
+ }
+
/* Expression itself is coindexed object. */
if (ref == NULL)
{
for (n = 0; n < e->rank; n++)
mpz_clear (e->shape[n]);
- gfc_free (e->shape);
+ free (e->shape);
}
/* Give the expression the right symtree! */
{
/* Original was variable so convert array references into
an actual arglist. This does not need any checking now
- since gfc_resolve_function will take care of it. */
+ since resolve_function will take care of it. */
e->value.function.actual = NULL;
e->expr_type = EXPR_FUNCTION;
e->symtree = st;
if (!po)
return FAILURE;
+ /* F08:R739. */
if (po->rank > 0)
{
gfc_error ("Passed-object at %L must be scalar", &e->where);
return FAILURE;
}
+ /* F08:C611. */
+ if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
+ {
+ gfc_error ("Base object for procedure-pointer component call at %L is of"
+ " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
+ return FAILURE;
+ }
+
gcc_assert (tb->pass_arg_num > 0);
e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
tb->pass_arg_num,
check_typebound_baseobject (gfc_expr* e)
{
gfc_expr* base;
+ gfc_try return_value = FAILURE;
base = extract_compcall_passed_object (e);
if (!base)
gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
+ /* F08:C611. */
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;
+ goto cleanup;
}
- /* If the procedure called is NOPASS, the base object must be scalar. */
+ /* F08:C1230. 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;
+ goto cleanup;
}
- /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
+ /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */
if (base->rank > 0)
{
gfc_error ("Non-scalar base object at %L currently not implemented",
&e->where);
- return FAILURE;
+ goto cleanup;
}
- return SUCCESS;
+ return_value = SUCCESS;
+
+cleanup:
+ gfc_free_expr (base);
+ return return_value;
}
/* 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);
+ st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
if (st)
e->value.compcall.tbp = st->n.tb;
/* Deal with typebound operators for CLASS objects. */
expr = e->value.compcall.base_object;
- if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
- && e->value.compcall.name)
+ if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
{
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
- ts = expr->symtree->n.sym->ts;
+ ts = expr->ts;
declared = ts.u.derived;
- c = gfc_find_component (declared, "$vptr", true, true);
+ c = gfc_find_component (declared, "_vptr", true, true);
if (c->ts.u.derived == NULL)
c->ts.u.derived = gfc_find_derived_vtab (declared);
/* Use the generic name if it is there. */
name = name ? name : e->value.function.esym->name;
e->symtree = expr->symtree;
- expr->symtree->n.sym->ts.u.derived = declared;
- gfc_add_component_ref (e, "$vptr");
+ e->ref = gfc_copy_ref (expr->ref);
+ gfc_add_vptr_component (e);
gfc_add_component_ref (e, name);
e->value.function.esym = NULL;
return SUCCESS;
return resolve_compcall (e, NULL);
}
- c = gfc_find_component (declared, "$data", true, true);
+ c = gfc_find_component (declared, "_data", true, true);
declared = c->ts.u.derived;
/* Treat the call as if it is a typebound procedure, in order to roll
if (new_ref)
e->ref = new_ref;
- /* '$vptr' points to the vtab, which contains the procedure pointers. */
- gfc_add_component_ref (e, "$vptr");
+ /* '_vptr' points to the vtab, which contains the procedure pointers. */
+ gfc_add_vptr_component (e);
gfc_add_component_ref (e, name);
/* Recover the typespec for the expression. This is really only
/* Deal with typebound operators for CLASS objects. */
expr = code->expr1->value.compcall.base_object;
- if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
- && code->expr1->value.compcall.name)
+ if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
{
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
- ts = expr->symtree->n.sym->ts;
- declared = ts.u.derived;
- c = gfc_find_component (declared, "$vptr", true, true);
+ declared = expr->ts.u.derived;
+ c = gfc_find_component (declared, "_vptr", true, true);
if (c->ts.u.derived == NULL)
c->ts.u.derived = gfc_find_derived_vtab (declared);
/* Use the generic name if it is there. */
name = name ? name : code->expr1->value.function.esym->name;
code->expr1->symtree = expr->symtree;
- expr->symtree->n.sym->ts.u.derived = declared;
- gfc_add_component_ref (code->expr1, "$vptr");
+ code->expr1->ref = gfc_copy_ref (expr->ref);
+ gfc_add_vptr_component (code->expr1);
gfc_add_component_ref (code->expr1, name);
code->expr1->value.function.esym = NULL;
return SUCCESS;
if (new_ref)
code->expr1->ref = new_ref;
- /* '$vptr' points to the vtab, which contains the procedure pointers. */
- gfc_add_component_ref (code->expr1, "$vptr");
+ /* '_vptr' points to the vtab, which contains the procedure pointers. */
+ gfc_add_vptr_component (code->expr1);
gfc_add_component_ref (code->expr1, name);
/* Recover the typespec for the expression. This is really only
== FAILURE)
return FAILURE;
- if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
- {
- gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
- &iter->var->where);
- return FAILURE;
- }
+ if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
+ == FAILURE)
+ return FAILURE;
if (gfc_resolve_iterator_expr (iter->start, real_ok,
"Start expression in DO loop") == FAILURE)
resolve_deallocate_expr (gfc_expr *e)
{
symbol_attribute attr;
- int allocatable, pointer, check_intent_in;
+ int allocatable, pointer;
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 (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
}
for (ref = e->ref; ref; ref = ref->next)
{
- if (pointer)
- check_intent_in = 0;
-
switch (ref->type)
{
case REF_ARRAY:
- if (ref->u.ar.type != AR_FULL)
+ if (ref->u.ar.type != AR_FULL
+ && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
+ && ref->u.ar.codimen && gfc_ref_this_image (ref)))
allocatable = 0;
break;
return FAILURE;
}
- if (check_intent_in && sym->attr.intent == INTENT_IN)
+ /* F2008, C644. */
+ if (gfc_is_coindexed (e))
{
- gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
- sym->name, &e->where);
+ gfc_error ("Coindexed allocatable object at %L", &e->where);
return FAILURE;
}
- if (e->ts.type == BT_CLASS)
- {
- /* Only deallocate the DATA component. */
- gfc_add_component_ref (e, "$data");
- }
+ if (pointer
+ && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
+ == FAILURE)
+ return FAILURE;
+ if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
+ == FAILURE)
+ return FAILURE;
return SUCCESS;
}
}
+/* If the last ref of an expression is an array ref, return a copy of the
+ expression with that one removed. Otherwise, a copy of the original
+ expression. This is used for allocate-expressions and pointer assignment
+ LHS, where there may be an array specification that needs to be stripped
+ off when using gfc_check_vardef_context. */
+
+static gfc_expr*
+remove_last_array_ref (gfc_expr* e)
+{
+ gfc_expr* e2;
+ gfc_ref** r;
+
+ e2 = gfc_copy_expr (e);
+ for (r = &e2->ref; *r; r = &(*r)->next)
+ if ((*r)->type == REF_ARRAY && !(*r)->next)
+ {
+ gfc_free_ref_list (*r);
+ *r = NULL;
+ break;
+ }
+
+ return e2;
+}
+
+
/* 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
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
- int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
+ int i, pointer, allocatable, dimension, is_abstract;
int codimension;
+ bool coindexed;
symbol_attribute attr;
gfc_ref *ref, *ref2;
+ gfc_expr *e2;
gfc_array_ref *ar;
gfc_symbol *sym = NULL;
gfc_alloc *a;
gfc_component *c;
-
- /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
- check_intent_in = 1;
+ gfc_try t;
/* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
checking of coarrays. */
codimension = sym->attr.codimension;
}
+ coindexed = false;
+
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
{
- if (pointer)
- check_intent_in = 0;
-
switch (ref->type)
{
case REF_ARRAY:
+ if (ref->u.ar.codimen > 0)
+ {
+ int n;
+ for (n = ref->u.ar.dimen;
+ n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
+ if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
+ {
+ coindexed = true;
+ break;
+ }
+ }
+
if (ref->next != NULL)
pointer = 0;
break;
case REF_COMPONENT:
/* F2008, C644. */
- if (gfc_is_coindexed (e))
+ if (coindexed)
{
gfc_error ("Coindexed allocatable object at %L",
&e->where);
&e->where, &code->expr3->where);
goto failure;
}
+
+ /* Check F2008, C642. */
+ if (code->expr3->ts.type == BT_DERIVED
+ && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
+ || (code->expr3->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && code->expr3->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_LOCK_TYPE)))
+ {
+ gfc_error ("The source-expr at %L shall neither be of type "
+ "LOCK_TYPE nor have a LOCK_TYPE component if "
+ "allocate-object at %L is a coarray",
+ &code->expr3->where, &e->where);
+ goto failure;
+ }
}
/* Check F08:C629. */
goto failure;
}
- if (check_intent_in && sym->attr.intent == INTENT_IN)
+ /* In the variable definition context checks, gfc_expr_attr is used
+ on the expression. This is fooled by the array specification
+ present in e, thus we have to eliminate that one temporarily. */
+ e2 = remove_last_array_ref (e);
+ t = SUCCESS;
+ if (t == SUCCESS && pointer)
+ t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
+ if (t == SUCCESS)
+ t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
+ gfc_free_expr (e2);
+ if (t == FAILURE)
+ goto failure;
+
+ if (!code->expr3)
{
- gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
- sym->name, &e->where);
- goto failure;
+ /* Set up default initializer if needed. */
+ gfc_typespec ts;
+ gfc_expr *init_e;
+
+ if (code->ext.alloc.ts.type == BT_DERIVED)
+ ts = code->ext.alloc.ts;
+ else
+ ts = e->ts;
+
+ if (ts.type == BT_CLASS)
+ ts = ts.u.derived->components->ts;
+
+ if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&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 (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
+ {
+ /* Default initialization via MOLD (non-polymorphic). */
+ gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
+ gfc_resolve_expr (rhs);
+ gfc_free_expr (code->expr3);
+ code->expr3 = rhs;
}
if (e->ts.type == BT_CLASS)
gfc_find_derived_vtab (ts.u.derived);
}
- if (pointer || (dimension == 0 && codimension == 0))
+ if (dimension == 0 && codimension == 0)
goto success;
- /* Make sure the next-to-last reference node is an array specification. */
+ /* Make sure the last reference node is an array specifiction. */
- if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
+ if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
|| (dimension && ref2->u.ar.dimen == 0))
{
gfc_error ("Array specification required in ALLOCATE statement "
ar = &ref2->u.ar;
- if (codimension && ar->codimen == 0)
- {
- gfc_error ("Coarray specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
- }
+ if (codimension)
+ for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
+ if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
+ {
+ gfc_error ("Coarray specification required in ALLOCATE statement "
+ "at %L", &e->where);
+ goto failure;
+ }
for (i = 0; i < ar->dimen; i++)
{
case DIMEN_UNKNOWN:
case DIMEN_VECTOR:
case DIMEN_STAR:
+ case DIMEN_THIS_IMAGE:
gfc_error ("Bad array specification in ALLOCATE statement at %L",
&e->where);
goto failure;
goto failure;
}
- if (codimension && ar->as->rank == 0)
- {
- gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
- "at %L", &e->where);
- goto failure;
- }
-
success:
return SUCCESS;
gfc_expr *stat, *errmsg, *pe, *qe;
gfc_alloc *a, *p, *q;
- stat = code->expr1 ? code->expr1 : NULL;
-
- errmsg = code->expr2 ? code->expr2 : NULL;
+ stat = code->expr1;
+ errmsg = code->expr2;
/* Check the stat variable. */
if (stat)
{
- if (stat->symtree->n.sym->attr.intent == INTENT_IN)
- gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
- stat->symtree->n.sym->name, &stat->where);
-
- if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
- gfc_error ("Illegal stat-variable at %L for a PURE procedure",
- &stat->where);
+ gfc_check_vardef_context (stat, false, false, _("STAT variable"));
if ((stat->ts.type != BT_INTEGER
&& !(stat->ref && (stat->ref->type == REF_ARRAY
gfc_warning ("ERRMSG at %L is useless without a STAT tag",
&errmsg->where);
- if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
- gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
- errmsg->symtree->n.sym->name, &errmsg->where);
-
- if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
- gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
- &errmsg->where);
+ gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
if ((errmsg->ts.type != BT_CHARACTER
&& !(errmsg->ref
for (p = code->ext.alloc.list; p; p = p->next)
{
pe = p->expr;
- if ((pe->ref && pe->ref->type != REF_COMPONENT)
- && (pe->symtree->n.sym->ts.type != BT_DERIVED))
+ for (q = p->next; q; q = q->next)
{
- for (q = p->next; q; q = q->next)
+ qe = q->expr;
+ if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
{
- qe = q->expr;
- if ((qe->ref && qe->ref->type != REF_COMPONENT)
- && (qe->symtree->n.sym->ts.type != BT_DERIVED)
- && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
- gfc_error ("Allocate-object at %L also appears at %L",
- &pe->where, &qe->where);
+ /* This is a potential collision. */
+ gfc_ref *pr = pe->ref;
+ gfc_ref *qr = qe->ref;
+
+ /* Follow the references until
+ a) They start to differ, in which case there is no error;
+ you can deallocate a%b and a%c in a single statement
+ b) Both of them stop, which is an error
+ c) One of them stops, which is also an error. */
+ while (1)
+ {
+ if (pr == NULL && qr == NULL)
+ {
+ gfc_error ("Allocate-object at %L also appears at %L",
+ &pe->where, &qe->where);
+ break;
+ }
+ else if (pr != NULL && qr == NULL)
+ {
+ gfc_error ("Allocate-object at %L is subobject of"
+ " object at %L", &pe->where, &qe->where);
+ break;
+ }
+ else if (pr == NULL && qr != NULL)
+ {
+ gfc_error ("Allocate-object at %L is subobject of"
+ " object at %L", &qe->where, &pe->where);
+ break;
+ }
+ /* Here, pr != NULL && qr != NULL */
+ gcc_assert(pr->type == qr->type);
+ if (pr->type == REF_ARRAY)
+ {
+ /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
+ which are legal. */
+ gcc_assert (qr->type == REF_ARRAY);
+
+ if (pr->next && qr->next)
+ {
+ gfc_array_ref *par = &(pr->u.ar);
+ gfc_array_ref *qar = &(qr->u.ar);
+ if (gfc_dep_compare_expr (par->start[0],
+ qar->start[0]) != 0)
+ break;
+ }
+ }
+ else
+ {
+ if (pr->u.c.component->name != qr->u.c.component->name)
+ break;
+ }
+
+ pr = pr->next;
+ qr = qr->next;
+ }
}
}
}
if (type == BT_INTEGER)
for (body = code->block; body; body = body->block)
- for (cp = body->ext.case_list; cp; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp; cp = cp->next)
{
if (cp->low
&& gfc_check_integer_range (cp->low->value.integer,
for (body = code->block; body; body = body->block)
{
/* Walk the case label list. */
- for (cp = body->ext.case_list; cp; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp; cp = cp->next)
{
/* Intercept the DEFAULT case. It does not have a kind. */
if (cp->low == NULL && cp->high == NULL)
/* Walk the case label list, making sure that all case labels
are legal. */
- for (cp = body->ext.case_list; cp; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp; cp = cp->next)
{
/* Count the number of cases in the whole construct. */
ncases++;
if (seen_unreachable)
{
/* Advance until the first case in the list is reachable. */
- while (body->ext.case_list != NULL
- && body->ext.case_list->unreachable)
+ while (body->ext.block.case_list != NULL
+ && body->ext.block.case_list->unreachable)
{
- gfc_case *n = body->ext.case_list;
- body->ext.case_list = body->ext.case_list->next;
+ gfc_case *n = body->ext.block.case_list;
+ body->ext.block.case_list = body->ext.block.case_list->next;
n->next = NULL;
gfc_free_case_list (n);
}
/* Strip all other unreachable cases. */
- if (body->ext.case_list)
+ if (body->ext.block.case_list)
{
- for (cp = body->ext.case_list; cp->next; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
{
if (cp->next->unreachable)
{
unreachable case labels for a block. */
for (body = code; body && body->block; body = body->block)
{
- if (body->block->ext.case_list == NULL)
+ if (body->block->ext.block.case_list == NULL)
{
/* Cut the unreachable block from the code chain. */
gfc_code *c = body->block;
resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
{
gfc_expr* target;
- bool to_var;
gcc_assert (sym->assoc);
gcc_assert (sym->attr.flavor == FL_VARIABLE);
sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
}
- sym->ts = target->ts;
+ /* Get type if this was not already set. Note that it can be
+ some other type than the target in case this is a SELECT TYPE
+ selector! So we must not update when the type is already there. */
+ if (sym->ts.type == BT_UNKNOWN)
+ sym->ts = target->ts;
gcc_assert (sym->ts.type != BT_UNKNOWN);
/* See if this is a valid association-to-variable. */
- to_var = (target->expr_type == EXPR_VARIABLE
- && !gfc_has_vector_subscript (target));
- if (sym->assoc->variable && !to_var)
- {
- if (target->expr_type == EXPR_VARIABLE)
- gfc_error ("'%s' at %L associated to vector-indexed target can not"
- " be used in a variable definition context",
- sym->name, &sym->declared_at);
- else
- gfc_error ("'%s' at %L associated to expression can not"
- " be used in a variable definition context",
- sym->name, &sym->declared_at);
-
- return;
- }
- sym->assoc->variable = to_var;
+ sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
+ && !gfc_has_vector_subscript (target));
/* Finally resolve if this is an array or not. */
if (sym->attr.dimension && target->rank == 0)
/* Resolve a SELECT TYPE statement. */
static void
-resolve_select_type (gfc_code *code)
+resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
{
gfc_symbol *selector_type;
gfc_code *body, *new_st, *if_st, *tail;
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
- c = body->ext.case_list;
+ c = body->ext.block.case_list;
/* Check F03:C815. */
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
{
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);
+ &default_case->ext.block.case_list->where, &c->where);
error++;
continue;
}
- else
- default_case = body;
+
+ default_case = body;
}
}
return;
/* Transform SELECT TYPE statement to BLOCK and associate selector to
- target if present. */
+ target if present. If there are any EXIT statements referring to the
+ SELECT TYPE construct, this is no problem because the gfc_code
+ reference stays the same and EXIT is equally possible from the BLOCK
+ it is changed to. */
code->op = EXEC_BLOCK;
if (code->expr2)
{
ns->code->next = new_st;
code = new_st;
code->op = EXEC_SELECT;
- gfc_add_component_ref (code->expr1, "$vptr");
- gfc_add_component_ref (code->expr1, "$hash");
+ gfc_add_vptr_component (code->expr1);
+ gfc_add_hash_component (code->expr1);
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
- c = body->ext.case_list;
+ c = body->ext.block.case_list;
if (c->ts.type == BT_DERIVED)
c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
'global' one). */
if (c->ts.type == BT_CLASS)
- sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
+ sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
else
- sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
+ sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
st = gfc_find_symtree (ns->sym_root, name);
gcc_assert (st->n.sym->assoc);
st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
if (c->ts.type == BT_DERIVED)
- gfc_add_component_ref (st->n.sym->assoc->target, "$data");
+ gfc_add_data_component (st->n.sym->assoc->target);
new_st = gfc_get_code ();
new_st->op = EXEC_BLOCK;
body = code;
while (body && body->block)
{
- if (body->block->ext.case_list->ts.type == BT_CLASS)
+ if (body->block->ext.block.case_list->ts.type == BT_CLASS)
{
/* Add to class_is list. */
if (class_is == NULL)
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->ext.block.case_list = gfc_get_case ();
+ tail->ext.block.case_list->ts.type = BT_UNKNOWN;
tail->next = NULL;
default_case = tail;
}
{
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)
+ if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
+ == c2->ext.block.case_list->ts.u.derived->hash_value)
{
gfc_error ("Double CLASS IS block in SELECT TYPE "
- "statement at %L", &c2->ext.case_list->where);
+ "statement at %L",
+ &c2->ext.block.case_list->where);
return;
}
- if ((*c1)->ext.case_list->ts.u.derived->attr.extension
- < c2->ext.case_list->ts.u.derived->attr.extension)
+ if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
+ < c2->ext.block.case_list->ts.u.derived->attr.extension)
{
/* Swap. */
(*c1)->block = c2->block;
/* 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);
+ new_st->expr1->value.function.actual->expr->where = code->loc;
+ gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
+ vtab = gfc_find_derived_vtab (body->ext.block.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);
default_case->next = if_st;
}
- resolve_select (code);
+ /* Resolve the internal code. This can not be done earlier because
+ it requires that the sym->assoc of selectors is set already. */
+ gfc_current_ns = ns;
+ gfc_resolve_blocks (code->block, gfc_current_ns);
+ gfc_current_ns = old_ns;
+ resolve_select (code);
}
&& exp->expr_type != EXPR_FUNCTION))
return;
+ /* If we are reading, the variable will be changed. Note that
+ code->ext.dt may be NULL if the TRANSFER is related to
+ an INQUIRE statement -- but in this case, we are not reading, either. */
+ if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
+ && gfc_check_vardef_context (exp, false, false, _("item in READ"))
+ == FAILURE)
+ return;
+
sym = exp->symtree->n.sym;
ts = &sym->ts;
/* Go to actual component transferred. */
- for (ref = code->expr1->ref; ref; ref = ref->next)
+ for (ref = exp->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
ts = &ref->u.c.component->ts;
+ if (ts->type == BT_CLASS)
+ {
+ /* FIXME: Test for defined input/output. */
+ gfc_error ("Data transfer element at %L cannot be polymorphic unless "
+ "it is processed by a defined input/output procedure",
+ &code->loc);
+ return;
+ }
+
if (ts->type == BT_DERIVED)
{
/* Check that transferred derived type doesn't contain POINTER
components. */
if (ts->u.derived->attr.pointer_comp)
{
+ gfc_error ("Data transfer element at %L cannot have POINTER "
+ "components unless it is processed by a defined "
+ "input/output procedure", &code->loc);
+ return;
+ }
+
+ /* F08:C935. */
+ if (ts->u.derived->attr.proc_pointer_comp)
+ {
gfc_error ("Data transfer element at %L cannot have "
- "POINTER components", &code->loc);
+ "procedure pointer components", &code->loc);
return;
}
if (ts->u.derived->attr.alloc_comp)
{
- gfc_error ("Data transfer element at %L cannot have "
- "ALLOCATABLE components", &code->loc);
+ gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
+ "components unless it is processed by a defined "
+ "input/output procedure", &code->loc);
return;
}
static void
+resolve_lock_unlock (gfc_code *code)
+{
+ if (code->expr1->ts.type != BT_DERIVED
+ || code->expr1->expr_type != EXPR_VARIABLE
+ || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+ || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
+ || code->expr1->rank != 0
+ || !(gfc_expr_attr (code->expr1).codimension
+ || gfc_is_coindexed (code->expr1)))
+ gfc_error ("Lock variable at %L must be a scalar coarray of type "
+ "LOCK_TYPE", &code->expr1->where);
+
+ /* Check STAT. */
+ if (code->expr2
+ && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
+ || code->expr2->expr_type != EXPR_VARIABLE))
+ gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
+ &code->expr2->where);
+
+ if (code->expr2
+ && gfc_check_vardef_context (code->expr2, false, false,
+ _("STAT variable")) == FAILURE)
+ return;
+
+ /* Check ERRMSG. */
+ if (code->expr3
+ && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
+ || code->expr3->expr_type != EXPR_VARIABLE))
+ gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
+ &code->expr3->where);
+
+ if (code->expr3
+ && gfc_check_vardef_context (code->expr3, false, false,
+ _("ERRMSG variable")) == FAILURE)
+ return;
+
+ /* Check ACQUIRED_LOCK. */
+ if (code->expr4
+ && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
+ || code->expr4->expr_type != EXPR_VARIABLE))
+ gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
+ "variable", &code->expr4->where);
+
+ if (code->expr4
+ && gfc_check_vardef_context (code->expr4, false, false,
+ _("ACQUIRED_LOCK variable")) == FAILURE)
+ return;
+}
+
+
+static void
resolve_sync (gfc_code *code)
{
/* Check imageset. The * case matches expr1 == NULL. */
total_var = gfc_count_forall_iterators (code);
/* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
- var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
+ var_expr = XCNEWVEC (gfc_expr *, total_var);
}
/* The information about FORALL iterator, including FORALL index start, end
gcc_assert (forall_save == 0);
/* VAR_EXPR is not needed any more. */
- gfc_free (var_expr);
+ free (var_expr);
total_var = 0;
}
}
case EXEC_OMP_SINGLE:
case EXEC_OMP_TASK:
case EXEC_OMP_TASKWAIT:
+ case EXEC_OMP_TASKYIELD:
case EXEC_OMP_WORKSHARE:
break;
}
}
-
if (lhs->ts.type == BT_CHARACTER
&& gfc_option.warn_character_truncation)
{
if (gfc_pure (NULL))
{
- if (gfc_impure_variable (lhs->symtree->n.sym))
- {
- gfc_error ("Cannot assign to variable '%s' in PURE "
- "procedure at %L",
- lhs->symtree->n.sym->name,
- &lhs->where);
- return rval;
- }
-
if (lhs->ts.type == BT_DERIVED
&& lhs->expr_type == EXPR_VARIABLE
&& lhs->ts.u.derived->attr.pointer_comp
}
}
+ if (gfc_implicit_pure (NULL))
+ {
+ if (lhs->expr_type == EXPR_VARIABLE
+ && lhs->symtree->n.sym != gfc_current_ns->proc_name
+ && lhs->symtree->n.sym->ns != gfc_current_ns)
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
+ 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_is_coindexed (rhs)))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
+ /* Fortran 2008, C1283. */
+ if (gfc_is_coindexed (lhs))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ }
+
/* F03:7.4.1.2. */
/* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
gfc_resolve_omp_do_blocks (code, ns);
break;
case EXEC_SELECT_TYPE:
- gfc_current_ns = code->ext.block.ns;
- gfc_resolve_blocks (code->block, gfc_current_ns);
- gfc_current_ns = ns;
+ /* Blocks are handled in resolve_select_type because we have
+ to transform the SELECT TYPE into ASSOCIATE first. */
break;
case EXEC_OMP_WORKSHARE:
omp_workshare_save = omp_workshare_flag;
resolve_sync (code);
break;
+ case EXEC_LOCK:
+ case EXEC_UNLOCK:
+ resolve_lock_unlock (code);
+ break;
+
case EXEC_ENTRY:
/* Keep track of which entry we are up to. */
current_entry_id = code->ext.entry->id;
if (t == FAILURE)
break;
+ if (gfc_check_vardef_context (code->expr1, false, false,
+ _("assignment")) == FAILURE)
+ break;
+
if (resolve_ordinary_assign (code, ns))
{
if (code->op == EXEC_COMPCALL)
break;
case EXEC_POINTER_ASSIGN:
- if (t == FAILURE)
- break;
+ {
+ gfc_expr* e;
- gfc_check_pointer_assign (code->expr1, code->expr2);
- break;
+ if (t == FAILURE)
+ break;
+
+ /* This is both a variable definition and pointer assignment
+ context, so check both of them. For rank remapping, a final
+ array ref may be present on the LHS and fool gfc_expr_attr
+ used in gfc_check_vardef_context. Remove it. */
+ e = remove_last_array_ref (code->expr1);
+ t = gfc_check_vardef_context (e, true, false,
+ _("pointer assignment"));
+ if (t == SUCCESS)
+ t = gfc_check_vardef_context (e, false, false,
+ _("pointer assignment"));
+ gfc_free_expr (e);
+ if (t == FAILURE)
+ break;
+
+ gfc_check_pointer_assign (code->expr1, code->expr2);
+ break;
+ }
case EXEC_ARITHMETIC_IF:
if (t == SUCCESS
break;
case EXEC_SELECT_TYPE:
- resolve_select_type (code);
+ resolve_select_type (code, ns);
break;
case EXEC_BLOCK:
case EXEC_FORALL:
resolve_forall_iterators (code->ext.forall_iterator);
- if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
- gfc_error ("FORALL mask clause at %L requires a LOGICAL "
+ if (code->expr1 != NULL
+ && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
+ gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
"expression", &code->expr1->where);
break;
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
case EXEC_OMP_TASKWAIT:
+ case EXEC_OMP_TASKYIELD:
case EXEC_OMP_WORKSHARE:
gfc_resolve_omp_directive (code, ns);
break;
return SUCCESS;
}
+
/* Resolve a charlen structure. */
static gfc_try
build_init_assign (sym, init);
}
+
/* Resolution of common features of flavors variable and procedure. */
static gfc_try
resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
{
+ /* Avoid double diagnostics for function result symbols. */
+ if ((sym->result || sym->attr.result) && !sym->attr.dummy
+ && (sym->ns != gfc_current_ns))
+ return SUCCESS;
+
/* Constraints on deferred shape variable. */
if (sym->as == NULL || sym->as->type != AS_DEFERRED)
{
else
{
if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
- && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
+ && sym->ts.type != BT_CLASS && !sym->assoc)
{
gfc_error ("Array '%s' at %L cannot have a deferred shape",
sym->name, &sym->declared_at);
return FAILURE;
}
+ /* Constraints on deferred type parameter. */
+ if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
+ {
+ gfc_error ("Entity '%s' at %L has a deferred type parameter and "
+ "requires either the pointer or allocatable attribute",
+ sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
if (sym->ts.type == BT_CHARACTER)
{
/* Make sure that character string variables with assumed length are
dummy arguments. */
e = sym->ts.u.cl->length;
- if (e == NULL && !sym->attr.dummy && !sym->attr.result)
+ if (e == NULL && !sym->attr.dummy && !sym->attr.result
+ && !sym->ts.deferred)
{
gfc_error ("Entity with assumed character length at %L must be a "
"dummy argument or a PARAMETER", &sym->declared_at);
/* Also, they must not have the SAVE attribute.
SAVE_IMPLICIT is checked below. */
- if (sym->attr.save == SAVE_EXPLICIT)
+ if (sym->as && sym->attr.codimension)
+ {
+ int corank = sym->as->corank;
+ sym->as->corank = 0;
+ no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
+ sym->as->corank = corank;
+ }
+ if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
{
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
return FAILURE;
/* Reject illegal initializers. */
if (!sym->mark && sym->value)
{
- if (sym->attr.allocatable)
+ if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->attr.allocatable))
gfc_error ("Allocatable '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.external)
the host. */
if (!(sym->ns->parent
&& sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
- && gfc_check_access(sym->attr.access, sym->ns->default_access))
+ && gfc_check_symbol_access (sym))
{
gfc_interface *iface;
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.u.derived->attr.use_assoc
- && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
- arg->sym->ts.u.derived->ns->default_access)
+ && !gfc_check_symbol_access (arg->sym->ts.u.derived)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
"PRIVATE type and cannot be a dummy argument"
" of '%s', which is PUBLIC at %L",
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.u.derived->attr.use_assoc
- && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
- arg->sym->ts.u.derived->ns->default_access)
+ && !gfc_check_symbol_access (arg->sym->ts.u.derived)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
"'%s' in PUBLIC interface '%s' at %L "
"takes dummy arguments of '%s' which is "
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.u.derived->attr.use_assoc
- && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
- arg->sym->ts.u.derived->ns->default_access)
+ && !gfc_check_symbol_access (arg->sym->ts.u.derived)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
"'%s' in PUBLIC interface '%s' at %L "
"takes dummy arguments of '%s' which is "
return FAILURE;
}
+ if (sym->attr.proc == PROC_ST_FUNCTION
+ && (sym->attr.allocatable || sym->attr.pointer))
+ {
+ gfc_error ("Statement function '%s' at %L may not have pointer or "
+ "allocatable attribute", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
/* 5.1.1.5 of the Standard: A function name declared with an asterisk
char-len-param shall not be array-valued, pointer-valued, recursive
or pure. ....snip... A character value of * may only be used in the
}
/* Appendix B.2 of the standard. Contained functions give an
- error anyway. Fixed-form is likely to be F77/legacy. */
- if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
+ error anyway. Fixed-form is likely to be F77/legacy. Deferred
+ character length is an F2003 feature. */
+ if (!sym->attr.contained
+ && gfc_current_form != FORM_FIXED
+ && !sym->ts.deferred)
gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
"CHARACTER(*) function '%s' at %L",
sym->name, &sym->declared_at);
resolve_typebound_procedures (gfc_symbol* derived)
{
int op;
+ gfc_symbol* super_type;
if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
return SUCCESS;
+
+ super_type = gfc_get_derived_super_type (derived);
+ if (super_type)
+ resolve_typebound_procedures (super_type);
resolve_bindings_derived = derived;
resolve_bindings_result = SUCCESS;
for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
if (derived == dt_list->derived)
- break;
+ return;
- if (dt_list == NULL)
- {
- dt_list = gfc_get_dt_list ();
- dt_list->next = gfc_derived_types;
- dt_list->derived = derived;
- gfc_derived_types = dt_list;
- }
+ dt_list = gfc_get_dt_list ();
+ dt_list->next = gfc_derived_types;
+ dt_list->derived = derived;
+ gfc_derived_types = dt_list;
}
}
-/* Resolve the components of a derived type. */
+/* Resolve the components of a derived type. This does not have to wait until
+ resolution stage, but can be done as soon as the dt declaration has been
+ parsed. */
static gfc_try
-resolve_fl_derived (gfc_symbol *sym)
+resolve_fl_derived0 (gfc_symbol *sym)
{
gfc_symbol* super_type;
gfc_component *c;
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)
}
/* Ensure the extended type gets resolved before we do. */
- if (super_type && resolve_fl_derived (super_type) == FAILURE)
+ if (super_type && resolve_fl_derived0 (super_type) == FAILURE)
return FAILURE;
/* An ABSTRACT type must be extensible. */
return FAILURE;
}
- if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
+ if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
+ && !c->ts.deferred)
{
if (c->ts.u.cl->length == NULL
|| (resolve_charlen (c->ts.u.cl) == FAILURE)
}
}
+ if (c->ts.type == BT_CHARACTER && c->ts.deferred
+ && !c->attr.pointer && !c->attr.allocatable)
+ {
+ gfc_error ("Character component '%s' of '%s' at %L with deferred "
+ "length must be a POINTER or ALLOCATABLE",
+ c->name, sym->name, &c->loc);
+ return FAILURE;
+ }
+
if (c->ts.type == BT_DERIVED
&& sym->component_access != ACCESS_PRIVATE
- && gfc_check_access (sym->attr.access, sym->ns->default_access)
+ && gfc_check_symbol_access (sym)
&& !is_sym_host_assoc (c->ts.u.derived, sym->ns)
&& !c->ts.u.derived->attr.use_assoc
- && !gfc_check_access (c->ts.u.derived->attr.access,
- c->ts.u.derived->ns->default_access)
+ && !gfc_check_symbol_access (c->ts.u.derived)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
"is a PRIVATE type and cannot be a component of "
"'%s', which is PUBLIC at %L", c->name,
sym->name, &sym->declared_at) == FAILURE)
return FAILURE;
+ if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
+ {
+ gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
+ "type %s", c->name, &c->loc, sym->name);
+ return FAILURE;
+ }
+
if (sym->attr.sequence)
{
if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
return FAILURE;
}
- if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
+ if (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->attr.class_pointer
&& CLASS_DATA (c)->ts.u.derived->components == NULL
&& !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
{
}
/* C437. */
- if (c->ts.type == BT_CLASS
- && !(CLASS_DATA (c)->attr.class_pointer
- || CLASS_DATA (c)->attr.allocatable))
+ if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
+ && (!c->attr.class_ok
+ || !(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);
return FAILURE;
}
- /* Resolve the type-bound procedures. */
- if (resolve_typebound_procedures (sym) == FAILURE)
- return FAILURE;
-
- /* Resolve the finalizer procedures. */
- if (gfc_resolve_finalizers (sym) == FAILURE)
- return FAILURE;
-
/* 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
}
+/* The following procedure does the full resolution of a derived type,
+ including resolution of all type-bound procedures (if present). In contrast
+ to 'resolve_fl_derived0' this can only be done after the module has been
+ parsed completely. */
+
+static gfc_try
+resolve_fl_derived (gfc_symbol *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;
+ }
+ }
+
+ if (resolve_fl_derived0 (sym) == FAILURE)
+ return FAILURE;
+
+ /* Resolve the type-bound procedures. */
+ if (resolve_typebound_procedures (sym) == FAILURE)
+ return FAILURE;
+
+ /* Resolve the finalizer procedures. */
+ if (gfc_resolve_finalizers (sym) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
static gfc_try
resolve_fl_namelist (gfc_symbol *sym)
{
gfc_namelist *nl;
gfc_symbol *nlsym;
+ for (nl = sym->namelist; nl; nl = nl->next)
+ {
+ /* Check again, the check in match only works if NAMELIST comes
+ after the decl. */
+ if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
+ {
+ gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
+ "allowed", nl->sym->name, sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
+ "object '%s' with assumed shape in namelist "
+ "'%s' at %L", nl->sym->name, sym->name,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
+
+ if (is_non_constant_shape_array (nl->sym)
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
+ "object '%s' with nonconstant shape in namelist "
+ "'%s' at %L", nl->sym->name, sym->name,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
+
+ if (nl->sym->ts.type == BT_CHARACTER
+ && (nl->sym->ts.u.cl->length == NULL
+ || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
+ "'%s' with nonconstant character length in "
+ "namelist '%s' at %L", nl->sym->name, sym->name,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
+
+ /* FIXME: Once UDDTIO is implemented, the following can be
+ removed. */
+ if (nl->sym->ts.type == BT_CLASS)
+ {
+ gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
+ "polymorphic and requires a defined input/output "
+ "procedure", nl->sym->name, sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ if (nl->sym->ts.type == BT_DERIVED
+ && (nl->sym->ts.u.derived->attr.alloc_comp
+ || nl->sym->ts.u.derived->attr.pointer_comp))
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
+ "'%s' in namelist '%s' at %L with ALLOCATABLE "
+ "or POINTER components", nl->sym->name,
+ sym->name, &sym->declared_at) == FAILURE)
+ return FAILURE;
+
+ /* FIXME: Once UDDTIO is implemented, the following can be
+ removed. */
+ gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
+ "ALLOCATABLE or POINTER components and thus requires "
+ "a defined input/output procedure", nl->sym->name,
+ sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+ }
+
/* Reject PRIVATE objects in a PUBLIC namelist. */
- if (gfc_check_access(sym->attr.access, sym->ns->default_access))
+ if (gfc_check_symbol_access (sym))
{
for (nl = sym->namelist; nl; nl = nl->next)
{
if (!nl->sym->attr.use_assoc
&& !is_sym_host_assoc (nl->sym, sym->ns)
- && !gfc_check_access(nl->sym->attr.access,
- nl->sym->ns->default_access))
+ && !gfc_check_symbol_access (nl->sym))
{
gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
"cannot be member of PUBLIC namelist '%s' at %L",
/* Types with private components that are defined in the same module. */
if (nl->sym->ts.type == BT_DERIVED
&& !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
- && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
- ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
- nl->sym->ns->default_access))
+ && nl->sym->ts.u.derived->attr.private_comp)
{
gfc_error ("NAMELIST object '%s' has PRIVATE components and "
"cannot be a member of PUBLIC namelist '%s' at %L",
}
}
- for (nl = sym->namelist; nl; nl = nl->next)
- {
- /* Reject namelist arrays of assumed shape. */
- if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
- && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
- "must not have assumed shape in namelist "
- "'%s' at %L", nl->sym->name, sym->name,
- &sym->declared_at) == FAILURE)
- return FAILURE;
-
- /* Reject namelist arrays that are not constant shape. */
- if (is_non_constant_shape_array (nl->sym))
- {
- gfc_error ("NAMELIST array object '%s' must have constant "
- "shape in namelist '%s' at %L", nl->sym->name,
- sym->name, &sym->declared_at);
- return FAILURE;
- }
-
- /* Namelist objects cannot have allocatable or pointer components. */
- if (nl->sym->ts.type != BT_DERIVED)
- continue;
-
- if (nl->sym->ts.u.derived->attr.alloc_comp)
- {
- gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
- "have ALLOCATABLE components",
- nl->sym->name, sym->name, &sym->declared_at);
- return FAILURE;
- }
-
- if (nl->sym->ts.u.derived->attr.pointer_comp)
- {
- gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
- "have POINTER components",
- nl->sym->name, sym->name, &sym->declared_at);
- return FAILURE;
- }
- }
-
/* 14.1.2 A module or internal procedure represent local entities
of the same type as a namelist member and so are not allowed. */
gfc_namespace *ns;
gfc_component *c;
- /* Avoid double resolution of function result symbols. */
- if ((sym->result || sym->attr.result) && !sym->attr.dummy
- && (sym->ns != gfc_current_ns))
- return;
-
if (sym->attr.flavor == FL_UNKNOWN)
{
for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
{
symtree = gfc_find_symtree (ns->sym_root, sym->name);
- if (symtree && symtree->n.sym->generic)
+ if (symtree && (symtree->n.sym->generic ||
+ (symtree->n.sym->attr.flavor == FL_PROCEDURE
+ && sym->ns->construct_entities)))
{
this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
sym->name);
}
}
}
+ else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
+ gfc_resolve_array_spec (sym->result->as, false);
/* Assumed size arrays and assumed shape arrays must be dummy
arguments. Array-spec's of implied-shape should have been resolved to
return;
gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
- if (!ds && sym->attr.function
- && gfc_check_access (sym->attr.access, sym->ns->default_access))
+ if (!ds && sym->attr.function && gfc_check_symbol_access (sym))
{
symtree = gfc_new_symtree (&sym->ns->sym_root,
sym->ts.u.derived->name);
if (sym->ts.type == BT_DERIVED
&& sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
&& !sym->ts.u.derived->attr.use_assoc
- && gfc_check_access (sym->attr.access, sym->ns->default_access)
- && !gfc_check_access (sym->ts.u.derived->attr.access,
- sym->ts.u.derived->ns->default_access)
+ && gfc_check_symbol_access (sym)
+ && !gfc_check_symbol_access (sym->ts.u.derived)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
"of PRIVATE derived type '%s'",
(sym->attr.flavor == FL_PARAMETER) ? "parameter"
sym->ts.u.derived->name) == FAILURE)
return;
+ /* F2008, C1302. */
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE
+ && !sym->attr.codimension)
+ {
+ gfc_error ("Variable '%s' at %L of type LOCK_TYPE must be a coarray",
+ sym->name, &sym->declared_at);
+ return;
+ }
+
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
default initialization is defined (5.1.2.4.4). */
if (sym->ts.type == BT_DERIVED
}
}
+ /* F2008, C542. */
+ if (sym->ts.type == BT_DERIVED && sym->attr.dummy
+ && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
+ gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
+ "INTENT(OUT)", sym->name, &sym->declared_at);
+
/* F2008, C526. */
if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
|| sym->attr.codimension)
sym->name, &sym->declared_at);
/* F2008, C526. The function-result case was handled above. */
- if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
- || sym->attr.codimension)
+ if (sym->attr.codimension
&& !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
+ || sym->ns->save_all
|| sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program
|| sym->attr.function || sym->attr.result || sym->attr.use_assoc))
- gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
- "component and is not ALLOCATABLE, SAVE nor a "
- "dummy argument", sym->name, &sym->declared_at);
+ gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
+ "nor a dummy argument", sym->name, &sym->declared_at);
/* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
else if (sym->attr.codimension && !sym->attr.allocatable
&& sym->as && sym->as->cotype == AS_DEFERRED)
if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
&& sym->attr.dummy && sym->attr.intent == INTENT_OUT
- && !sym->attr.pointer && !sym->attr.allocatable)
+ && !CLASS_DATA (sym)->attr.class_pointer
+ && !CLASS_DATA (sym)->attr.allocatable)
apply_default_init (sym);
/* If this symbol has a type-spec, check it. */
has_pointer = sym->attr.pointer;
+ if (gfc_is_coindexed (e))
+ {
+ gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
+ where);
+ return FAILURE;
+ }
+
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
has_pointer = 1;
- if (ref->type == REF_ARRAY && ref->u.ar.codimen)
- {
- gfc_error ("DATA element '%s' at %L cannot have a coindex",
- sym->name, where);
- return FAILURE;
- }
-
if (has_pointer
&& ref->type == REF_ARRAY
&& ref->u.ar.type != AR_FULL)
mpz_set_ui (size, 0);
}
- t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
- offset, range);
+ t = gfc_assign_data_value (var->expr, values.vnode->expr,
+ offset, &range);
mpz_add (offset, offset, range);
mpz_clear (range);
mpz_sub_ui (values.left, values.left, 1);
mpz_sub_ui (size, size, 1);
- t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
+ t = gfc_assign_data_value (var->expr, values.vnode->expr,
+ offset, NULL);
if (t == FAILURE)
break;
}
+/* Test whether a symbol is implicitly pure or not. For a NULL pointer,
+ checks if the current namespace is implicitly pure. Note that this
+ function returns false for a PURE procedure. */
+
+int
+gfc_implicit_pure (gfc_symbol *sym)
+{
+ symbol_attribute attr;
+
+ if (sym == NULL)
+ {
+ /* Check if the current namespace is implicit_pure. */
+ sym = gfc_current_ns->proc_name;
+ if (sym == NULL)
+ return 0;
+ attr = sym->attr;
+ if (attr.flavor == FL_PROCEDURE
+ && attr.implicit_pure && !attr.pure)
+ return 1;
+ return 0;
+ }
+
+ attr = sym->attr;
+
+ return attr.flavor == FL_PROCEDURE && attr.implicit_pure && !attr.pure;
+}
+
+
/* Test whether the current procedure is elemental or not. */
int
e->ts.u.cl = NULL;
}
ref = ref->next;
- gfc_free (mem);
+ free (mem);
}
/* Any further ref is an error. */
if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
&& !sym->attr.contained
- && !gfc_check_access (sym->ts.u.derived->attr.access,
- sym->ts.u.derived->ns->default_access)
- && gfc_check_access (sym->attr.access, sym->ns->default_access))
+ && !gfc_check_symbol_access (sym->ts.u.derived)
+ && gfc_check_symbol_access (sym))
{
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
"%L of PRIVATE type '%s'", sym->name,
resolve_contained_functions (ns);
+ if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
+ && ns->proc_name->attr.if_source == IFSRC_IFBODY)
+ resolve_formal_arglist (ns->proc_name);
+
gfc_traverse_ns (ns, resolve_bind_c_derived_types);
for (cl = ns->cl_list; cl; cl = cl->next)
gfc_namespace *n;
bitmap_obstack old_obstack;
+ if (ns->resolved == 1)
+ return;
+
for (n = ns->contained; n; n = n->sibling)
resolve_codes (n);
OSDN Git Service
