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.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
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. */
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);
/* 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;
&& sym->ts.u.cl
&& sym->ts.u.cl->length == NULL
&& !sym->attr.dummy
+ && !sym->ts.deferred
&& expr->value.function.esym == NULL
&& !sym->attr.contained)
{
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 (n = 0; n < e->rank; n++)
mpz_clear (e->shape[n]);
- gfc_free (e->shape);
+ free (e->shape);
}
/* Give the expression the right symtree! */
/* 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;
+ 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;
+ 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;
{
int i, pointer, allocatable, dimension, is_abstract;
int codimension;
+ bool coindexed;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_expr *e2;
codimension = sym->attr.codimension;
}
+ coindexed = false;
+
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
{
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);
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;
}
success:
- if (e->ts.deferred)
- {
- gfc_error ("Support for entity at %L with deferred type parameter "
- "not yet implemented", &e->where);
- return FAILURE;
- }
return SUCCESS;
failure:
return;
}
+ /* F08:C935. */
+ if (ts->u.derived->attr.proc_pointer_comp)
+ {
+ gfc_error ("Data transfer element at %L cannot have "
+ "procedure pointer components", &code->loc);
+ return;
+ }
+
if (ts->u.derived->attr.alloc_comp)
{
gfc_error ("Data transfer element at %L cannot have "
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;
}
}
/* 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);
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,
}
/* 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",
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"
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)
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,
projects / platform / upstream / gcc.git / blobdiff