OK, I played a bit myself to see what the "right way" would look like, and I
came up with the attached patch, which is complicated, and not even correct.
And indeed, it plays with allocatable and pointer stuff.
So your approach makes some sense now.
I do here some propositions for comment and error messages which IMO explain
better where the problem lies (Iff I have understood the problem correctly).
They are quite verbose however, and possibly not correct english (many
negations).
One could consider separating the "is LOCK_TYPE type" and "type has type
LOCK_TYPE components" cases to make the diagnostic easier to read, but that
would make the code even more complex.
Anyway comments and propositions welcome.
review, 2nd try:
> diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
> index 2910ab5..9f732e5 100644
> --- a/gcc/fortran/parse.c
> +++ b/gcc/fortran/parse.c
> @@ -2148,15 +2157,61 @@ endType:
>
> /* Looking for coarray components. */
> if (c->attr.codimension
> - || (c->attr.coarray_comp && !c->attr.pointer && !c->attr.allocatable))
> - sym->attr.coarray_comp = 1;
> + || (c->ts.type == BT_CLASS && c->attr.class_ok
> + && CLASS_DATA (c)->attr.codimension))
> + {
> + coarray = true;
> + sym->attr.coarray_comp = 1;
> + }
> +
> + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.codimension)
- Err, is the codimension attribute on the derived type?
Or did you mean [...] && c->ts.u.derived->attr.coarray_comp (to match the code
removed)?
> + {
> + coarray = true;
> + if (!pointer && !allocatable)
> + sym->attr.coarray_comp = 1;
> + }
>
> /* Looking for lock_type components. */
> - if (c->attr.lock_comp
> - || (sym->ts.type == BT_DERIVED
> + if ((c->ts.type == BT_DERIVED
> && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
> - && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))
> - sym->attr.lock_comp = 1;
> + && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
> + || (c->ts.type == BT_CLASS && c->attr.class_ok
> + && CLASS_DATA (c)->ts.u.derived->from_intmod
> + == INTMOD_ISO_FORTRAN_ENV
> + && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
> + == ISOFORTRAN_LOCK_TYPE)
> + || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp
> + && !allocatable && !pointer))
> + {
> + lock_type = 1;
> + lock_comp = c;
> + sym->attr.lock_comp = 1;
> + }
> +
> + /* F2008, C1302. */
> +
Additional comment:
/* 5.3.14: An entity with the pointer attribute shall not be a coarray.
2.4.7: A subobject of a coarray is a coarray if it doesn't have any pointer
component selection. */
> + if (pointer && !coarray && (lock_type
> + || (c->ts.type == BT_DERIVED
> + && c->ts.u.derived->attr.lock_comp)))
> + gfc_error ("Component %s at %L of type LOCK_TYPE or with subcomponent "
> + "of type LOCK_TYPE is a pointer but not a coarray",
> + c->name, &c->loc);
"Component %s at %L can be neither a coarray as it is a pointer, nor a non-
coarray as it would be a non-coarray of type LOCK_TYPE or would have a non-
coarray subcomponent of type LOCK_TYPE", c->name, &c->loc
> +
/* 2.4.7: A subobject of a coarray is a coarray if it doesn't have any
allocatable component selection.
Thus, an allocatable component has to be a coarray for its subcomponents to
be coarrays. */
> + if (lock_type && allocatable && !coarray)
- If lock_type && allocatable is true, then subcomponents of type LOCK_TYPE
are discarded (cf the condition above for lock_type = 1), is that right?
I don't think you have this case in the tests you proposed.
> + gfc_error ("Component %s at %L of type LOCK_TYPE or with subcomponent "
> + "of type LOCK_TYPE is allocatable but not a "
> + "coarray", c->name, &c->loc);
"Allocatable component %s at %L can't be a non-coarray as it would be a non-
coarray of type LOCK_TYPE or it would have a non-coarray sub-component of type
LOCK_TYPE"
> +
/* 5.3.6: An entity whose type has a coarray ultimate component shall not be a
coarray. */
> + if (sym->attr.coarray_comp && !coarray && lock_type)
> + gfc_error ("Component %s at %L of type LOCK_TYPE or with subcomponent "
> + "of type LOCK_TYPE is not a coarray, but other coarray "
> + "components exist", c->name, &c->loc);
"An entity of type %s at %L can be neither a coarray as it has a coarray
sub-component, nor a non-coarray as its sub-component %s would be a non-
coarray of type LOCK_TYPE or would have a non-coarray sub-component of type
LOCK_TYPE"
> +
> + if (sym->attr.lock_comp && coarray && !lock_type)
> + gfc_error ("Component %s at %L of type LOCK_TYPE or with subcomponent "
> + "of type LOCK_TYPE has to be a coarray as %s at %L has a "
> + "codimension", lock_comp->name, &lock_comp->loc, c->name,
> + &c->loc);
"An entity of type %s at %L can be neither a coarray as its component %s at %L
has a codimension, nor a non-coarray as its component %s at %L would be a
non-coarray of type LOCK_TYPE or would have a non-coarray sub-component of
type LOCK_TYPE"
>
> /* Look for private components. */
> if (sym->component_access == ACCESS_PRIVATE
The rest looks good.
Mikael
diff --git a/gfortran.h b/gfortran.h
index acfa9d4..e03f172 100644
--- a/gfortran.h
+++ b/gfortran.h
@@ -786,6 +786,8 @@ typedef struct
/* The namespace where the attribute has been set. */
struct gfc_namespace *volatile_ns, *asynchronous_ns;
+
+ const char *lock_comp_ref, *noncoarray_lock_comp_ref;
}
symbol_attribute;
diff --git a/resolve.c b/resolve.c
index b8a8ebb..fedad13 100644
--- a/resolve.c
+++ b/resolve.c
@@ -12087,6 +12087,112 @@ resolve_fl_parameter (gfc_symbol *sym)
}
+static bool
+is_type_lock_type (gfc_typespec *ts)
+{
+ return (ts->type == BT_DERIVED
+ && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && ts->u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE);
+}
+
+
+static const char *
+set_subref_str (const char **dest, const char *base_name,
+ const char *subref)
+{
+ const unsigned int bufflen = strlen(base_name) + strlen(subref) + 2;
+ char *str;
+
+ if (subref == NULL || !strcmp (subref, ""))
+ return NULL;
+
+ str = XCNEWVEC (char, bufflen);
+ snprintf (str, bufflen, "%s%%%s", base_name, subref);
+ *dest = str;
+ return *dest;
+}
+
+
+static const char *comp_pick_lock_comp (gfc_component *);
+
+static const char *
+type_pick_lock_comp (gfc_symbol *derived)
+{
+ gfc_component *c;
+ const char *str;
+
+ if (derived->attr.lock_comp_ref != NULL)
+ return derived->attr.lock_comp_ref;
+
+ for (c = derived->components; c; c = c->next)
+ {
+ str = set_subref_str (&c->attr.lock_comp_ref, c->name,
+ comp_pick_lock_comp (c));
+ if (str != NULL)
+ return str;
+ }
+
+ derived->attr.lock_comp_ref = "";
+ return derived->attr.lock_comp_ref;
+}
+
+
+static const char *
+type_pick_noncoarray_lock_comp (gfc_symbol *derived)
+{
+ gfc_component *c;
+ gfc_typespec *ts;
+ const char *str;
+
+ if (derived->attr.noncoarray_lock_comp_ref != NULL)
+ return derived->attr.noncoarray_lock_comp_ref;
+
+ for (c = derived->components; c; c = c->next)
+ {
+ ts = &c->ts;
+ if (ts->type != BT_DERIVED)
+ continue;
+
+ if (!c->attr.codimension && is_type_lock_type (&c->ts))
+ {
+ c->attr.noncoarray_lock_comp_ref = gfc_get_string (c->name);
+ return c->attr.noncoarray_lock_comp_ref;
+ }
+
+ if (c->attr.pointer || c->attr.allocatable)
+ {
+ str = set_subref_str (&c->attr.noncoarray_lock_comp_ref,
+ c->name, comp_pick_lock_comp (c));
+ if (str != NULL)
+ return str;
+ }
+ else
+ {
+ str = set_subref_str (&c->attr.noncoarray_lock_comp_ref, c->name,
+ type_pick_noncoarray_lock_comp (c->ts.u.derived));
+ if (str != NULL)
+ return str;
+ }
+ }
+
+ derived->attr.noncoarray_lock_comp_ref = "";
+ return derived->attr.noncoarray_lock_comp_ref;
+}
+
+
+static const char *
+comp_pick_lock_comp (gfc_component *comp)
+{
+ if (comp->ts.type != BT_DERIVED)
+ return NULL;
+
+ if (is_type_lock_type (&comp->ts))
+ return gfc_get_string (comp->name);
+
+ return type_pick_lock_comp (comp->ts.u.derived);
+}
+
+
/* Do anything necessary to resolve a symbol. Right now, we just
assume that an otherwise unknown symbol is a variable. This sort
of thing commonly happens for symbols in module. */
@@ -12403,15 +12509,28 @@ resolve_symbol (gfc_symbol *sym)
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)
+ if (!sym->attr.codimension)
{
- gfc_error ("Variable '%s' at %L of type LOCK_TYPE must be a coarray",
- sym->name, &sym->declared_at);
- return;
+ if (is_type_lock_type (&sym->ts))
+ {
+ gfc_error ("Variable '%s' at %L must be a coarray as it is of type "
+ "LOCK_TYPE", sym->name, &sym->declared_at);
+ return;
+ }
+ else if (sym->ts.type == BT_DERIVED)
+ {
+ const char *comp_ref =
+ type_pick_noncoarray_lock_comp (sym->ts.u.derived);
+
+ if (strcmp (comp_ref, "") != 0)
+ {
+ gfc_error ("Variable '%s' at %L must be a coarray as its "
+ "sub-component '%s%%%s' is a non-coarray of type "
+ "LOCK_TYPE.", sym->name, &sym->declared_at, sym->name,
+ comp_ref);
+ return;
+ }
+ }
}
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
