2011-06-16 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
* gfortran.h (gfc_check_vardef_context): Update prototype.
(iso_fortran_env_symbol): Handle derived types.
(symbol_attribute): Add lock_comp.
* expr.c (gfc_check_vardef_context): Add LOCK_TYPE check.
* interface.c (compare_parameter, gfc_procedure_use): Handle
LOCK_TYPE.
(compare_actual_formal): Update
gfc_check_vardef_context call.
* check.c (gfc_check_atomic_def, gfc_check_atomic_ref): Ditto.
* intrinsic.c (check_arglist): Ditto.
* io.c (resolve_tag, gfc_resolve_dt, gfc_resolve_inquire): Ditto.
* iso-fortran-env.def (ISOFORTRAN_LOCK_TYPE): Add.
* intrinsic.texi (ISO_FORTRAN_ENV): Document LOCK_TYPE.
* module.c (mio_symbol_attribute): Handle lock_comp.
(create_derived_type): New function.
(use_iso_fortran_env_module): Call it to handle LOCK_TYPE.
* parse.c (parse_derived): Add constraint check for LOCK_TYPE.
* resolve.c (resolve_symbol, resolve_lock_unlock): Add constraint
checks for LOCK_TYPE.
(gfc_resolve_iterator, resolve_deallocate_expr,
resolve_allocate_expr, resolve_code, resolve_transfer): Update
gfc_check_vardef_context call.
* trans-stmt.h (gfc_trans_lock_unlock): New prototype.
* trans-stmt.c (gfc_trans_lock_unlock): New function.
* trans.c (trans_code): Handle LOCK and UNLOCK.
2011-06-16 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
* gfortran.dg/coarray_lock_1.f90: Update dg-error.
* gfortran.dg/coarray_lock_3.f90: New.
@@ -1011,7 +1011,7 @@ gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
if (scalar_check (atom, 0) == FAILURE || scalar_check (value, 1) == FAILURE)
return FAILURE;
- if (gfc_check_vardef_context (atom, false, NULL) == FAILURE)
+ if (gfc_check_vardef_context (atom, false, false, NULL) == FAILURE)
{
gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
"definable", gfc_current_intrinsic, &atom->where);
@@ -1028,7 +1028,7 @@ gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
if (scalar_check (value, 0) == FAILURE || scalar_check (atom, 1) == FAILURE)
return FAILURE;
- if (gfc_check_vardef_context (value, false, NULL) == FAILURE)
+ if (gfc_check_vardef_context (value, false, false, NULL) == FAILURE)
{
gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
"definable", gfc_current_intrinsic, &value->where);
@@ -4373,7 +4373,8 @@ gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
and just the return status (SUCCESS / FAILURE) be requested. */
gfc_try
-gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
+gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
+ const char* context)
{
gfc_symbol* sym = NULL;
bool is_pointer;
@@ -4441,6 +4442,19 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
return FAILURE;
}
+ /* F2008, C1303. */
+ if (!alloc_obj
+ && (attr.lock_comp
+ || (e->ts.type == BT_DERIVED
+ && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)))
+ {
+ if (context)
+ gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
+ context, &e->where);
+ return FAILURE;
+ }
+
/* INTENT(IN) dummy argument. Check this, unless the object itself is
the component of sub-component of a pointer. Obviously,
procedure pointers are of no interest here. */
@@ -4555,7 +4569,8 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
}
/* Target must be allowed to appear in a variable definition context. */
- if (gfc_check_vardef_context (assoc->target, pointer, NULL) == FAILURE)
+ if (gfc_check_vardef_context (assoc->target, pointer, false, NULL)
+ == FAILURE)
{
if (context)
gfc_error ("Associate-name '%s' can not appear in a variable"
@@ -596,6 +596,7 @@ gfc_reverse;
#define NAMED_INTCST(a,b,c,d) a,
#define NAMED_KINDARRAY(a,b,c,d) a,
#define NAMED_FUNCTION(a,b,c,d) a,
+#define NAMED_DERIVED_TYPE(a,b,c,d) a,
typedef enum
{
ISOFORTRANENV_INVALID = -1,
@@ -606,6 +607,7 @@ iso_fortran_env_symbol;
#undef NAMED_INTCST
#undef NAMED_KINDARRAY
#undef NAMED_FUNCTION
+#undef NAMED_DERIVED_TYPE
#define NAMED_INTCST(a,b,c,d) a,
#define NAMED_REALCST(a,b,c) a,
@@ -774,7 +776,7 @@ typedef struct
possibly nested. zero_comp is true if the derived type has no
component at all. */
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
- private_comp:1, zero_comp:1, coarray_comp:1;
+ private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1;
/* This is a temporary selector for SELECT TYPE. */
unsigned select_type_temporary:1;
@@ -2735,7 +2737,7 @@ bool gfc_has_ultimate_allocatable (gfc_expr *);
bool gfc_has_ultimate_pointer (gfc_expr *);
gfc_expr* gfc_build_intrinsic_call (const char*, locus, unsigned, ...);
-gfc_try gfc_check_vardef_context (gfc_expr*, bool, const char*);
+gfc_try gfc_check_vardef_context (gfc_expr*, bool, bool, const char*);
/* st.c */
@@ -1618,7 +1618,22 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
"contiguous", formal->name, &actual->where);
return 0;
}
- }
+
+ /* F2008, C1303 and C1304. */
+ if (formal->attr.intent != INTENT_INOUT
+ && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
+ && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
+ || formal->attr.lock_comp))
+
+ {
+ if (where)
+ gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
+ "which is LOCK_TYPE or has a LOCK_TYPE component",
+ formal->name, &actual->where);
+ return 0;
+ }
+ }
/* F2008, C1239/C1240. */
if (actual->expr_type == EXPR_VARIABLE
@@ -2294,10 +2309,10 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
: NULL);
if (f->sym->attr.pointer
- && gfc_check_vardef_context (a->expr, true, context)
+ && gfc_check_vardef_context (a->expr, true, false, context)
== FAILURE)
return 0;
- if (gfc_check_vardef_context (a->expr, false, context)
+ if (gfc_check_vardef_context (a->expr, false, false, context)
== FAILURE)
return 0;
}
@@ -2749,6 +2764,19 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
"for procedure '%s' at %L", sym->name, &a->expr->where);
break;
}
+
+ /* F2008, C1303 and C1304. */
+ if (a->expr
+ && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
+ && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
+ || gfc_expr_attr (a->expr).lock_comp))
+ {
+ gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
+ "component at %L requires an explicit interface for "
+ "procedure '%s'", &a->expr->where, sym->name);
+ break;
+ }
}
return;
@@ -3642,7 +3642,7 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
: NULL);
/* No pointer arguments for intrinsics. */
- if (gfc_check_vardef_context (actual->expr, false, context)
+ if (gfc_check_vardef_context (actual->expr, false, false, context)
== FAILURE)
return FAILURE;
}
@@ -12963,6 +12963,16 @@ Scalar default-integer constant used as STAT= return value by @code{UNLOCK} to
denote that the lock variable is unlocked. (Fortran 2008 or later.)
@end table
+The module provides the following derived type:
+
+@table @asis
+@item @code{LOCK_TYPE}:
+Derived type with private components to be use with the @code{LOCK} and
+@code{UNLOCK} statement. A variable of its type has to be always declared
+as coarray and may not appear in a variable-definition context.
+(Fortran 2008 or later.)
+@end table
+
The module also provides the following intrinsic procedures:
@ref{COMPILER_OPTIONS} and @ref{COMPILER_VERSION}.
@@ -1531,7 +1531,7 @@ resolve_tag (const io_tag *tag, gfc_expr *e)
char context[64];
sprintf (context, _("%s tag"), tag->name);
- if (gfc_check_vardef_context (e, false, context) == FAILURE)
+ if (gfc_check_vardef_context (e, false, false, context) == FAILURE)
return FAILURE;
}
@@ -2836,8 +2836,8 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
/* If we are writing, make sure the internal unit can be changed. */
gcc_assert (k != M_PRINT);
if (k == M_WRITE
- && gfc_check_vardef_context (e, false, _("internal unit in WRITE"))
- == FAILURE)
+ && gfc_check_vardef_context (e, false, false,
+ _("internal unit in WRITE")) == FAILURE)
return FAILURE;
}
@@ -2866,7 +2866,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
gfc_try t;
e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
- t = gfc_check_vardef_context (e, false, NULL);
+ t = gfc_check_vardef_context (e, false, false, NULL);
gfc_free_expr (e);
if (t == FAILURE)
@@ -4032,7 +4032,7 @@ gfc_resolve_inquire (gfc_inquire *inquire)
{ \
char context[64]; \
sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
- if (gfc_check_vardef_context ((expr), false, context) == FAILURE) \
+ if (gfc_check_vardef_context ((expr), false, false, context) == FAILURE) \
return FAILURE; \
}
INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
@@ -110,7 +110,14 @@ NAMED_FUNCTION (ISOFORTRAN_COMPILER_OPTIONS, "compiler_options", \
NAMED_FUNCTION (ISOFORTRAN_COMPILER_VERSION, "compiler_version", \
GFC_ISYM_COMPILER_VERSION, GFC_STD_F2008)
+#ifndef NAMED_DERIVED_TYPE
+# define NAMED_DERIVED_TYPE(a,b,c,d)
+#endif
+
+NAMED_DERIVED_TYPE (ISOFORTRAN_LOCK_TYPE, "lock_type", \
+ get_int_kind_from_node (ptr_type_node), GFC_STD_F2008)
#undef NAMED_INTCST
#undef NAMED_KINDARRAY
#undef NAMED_FUNCTION
+#undef NAMED_DERIVED_TYPE
@@ -1673,7 +1673,7 @@ typedef enum
AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
- AB_VALUE, AB_VOLATILE, AB_PROTECTED,
+ AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP,
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
@@ -1716,6 +1716,7 @@ static const mstring attr_bits[] =
minit ("VALUE", AB_VALUE),
minit ("ALLOC_COMP", AB_ALLOC_COMP),
minit ("COARRAY_COMP", AB_COARRAY_COMP),
+ minit ("LOCK_COMP", AB_LOCK_COMP),
minit ("POINTER_COMP", AB_POINTER_COMP),
minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
@@ -1889,6 +1890,8 @@ mio_symbol_attribute (symbol_attribute *attr)
MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
if (attr->coarray_comp)
MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
+ if (attr->lock_comp)
+ MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
if (attr->zero_comp)
MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
if (attr->is_class)
@@ -2028,6 +2031,9 @@ mio_symbol_attribute (symbol_attribute *attr)
case AB_COARRAY_COMP:
attr->coarray_comp = 1;
break;
+ case AB_LOCK_COMP:
+ attr->lock_comp = 1;
+ break;
case AB_POINTER_COMP:
attr->pointer_comp = 1;
break;
@@ -5467,6 +5473,37 @@ create_int_parameter_array (const char *name, int size, gfc_expr *value,
}
+/* Add an derived type for a given module. */
+
+static void
+create_derived_type (const char *name, const char *modname,
+ intmod_id module, int id)
+{
+ gfc_symtree *tmp_symtree;
+ gfc_symbol *sym;
+
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ if (tmp_symtree != NULL)
+ {
+ if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
+ return;
+ else
+ gfc_error ("Symbol '%s' already declared", name);
+ }
+
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
+ sym = tmp_symtree->n.sym;
+
+ sym->module = gfc_get_string (modname);
+ sym->from_intmod = module;
+ sym->intmod_sym_id = id;
+ sym->attr.flavor = FL_DERIVED;
+ sym->attr.private_comp = 1;
+ sym->attr.zero_comp = 1;
+ sym->attr.use_assoc = 1;
+}
+
+
/* USE the ISO_FORTRAN_ENV intrinsic module. */
@@ -5487,6 +5524,9 @@ use_iso_fortran_env_module (void)
#define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
#include "iso-fortran-env.def"
#undef NAMED_KINDARRAY
+#define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
+#include "iso-fortran-env.def"
+#undef NAMED_DERIVED_TYPE
#define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
#include "iso-fortran-env.def"
#undef NAMED_FUNCTION
@@ -5571,6 +5611,16 @@ use_iso_fortran_env_module (void)
#include "iso-fortran-env.def"
#undef NAMED_KINDARRAY
+#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
+ case a:
+#include "iso-fortran-env.def"
+ create_derived_type (u->local_name[0] ? u->local_name
+ : u->use_name,
+ mod, INTMOD_ISO_FORTRAN_ENV,
+ symbol[i].id);
+ break;
+#undef NAMED_DERIVED_TYPE
+
#define NAMED_FUNCTION(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
@@ -5624,6 +5674,14 @@ use_iso_fortran_env_module (void)
#include "iso-fortran-env.def"
#undef NAMED_KINDARRAY
+#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
+ case a:
+#include "iso-fortran-env.def"
+ create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
+ symbol[i].id);
+ break;
+#undef NAMED_DERIVED_TYPE
+
#define NAMED_FUNCTION(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
@@ -2141,6 +2141,13 @@ endType:
|| (c->attr.coarray_comp && !c->attr.pointer && !c->attr.allocatable))
sym->attr.coarray_comp = 1;
+ /* Looking for lock_type components. */
+ if (c->attr.lock_comp
+ || (sym->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;
+
/* Look for private components. */
if (sym->component_access == ACCESS_PRIVATE
|| c->attr.access == ACCESS_PRIVATE
@@ -6235,7 +6235,7 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
== FAILURE)
return FAILURE;
- if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
+ if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
== FAILURE)
return FAILURE;
@@ -6502,9 +6502,11 @@ resolve_deallocate_expr (gfc_expr *e)
}
if (pointer
- && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
+ && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
+ == FAILURE)
return FAILURE;
- if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
+ if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
+ == FAILURE)
return FAILURE;
return SUCCESS;
@@ -6796,6 +6798,21 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
&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. */
@@ -6814,9 +6831,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
e2 = remove_last_array_ref (e);
t = SUCCESS;
if (t == SUCCESS && pointer)
- t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
+ t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
if (t == SUCCESS)
- t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
+ t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
gfc_free_expr (e2);
if (t == FAILURE)
goto failure;
@@ -6992,7 +7009,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
/* Check the stat variable. */
if (stat)
{
- gfc_check_vardef_context (stat, false, _("STAT variable"));
+ gfc_check_vardef_context (stat, false, false, _("STAT variable"));
if ((stat->ts.type != BT_INTEGER
&& !(stat->ref && (stat->ref->type == REF_ARRAY
@@ -7035,7 +7052,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
gfc_warning ("ERRMSG at %L is useless without a STAT tag",
&errmsg->where);
- gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
+ gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
if ((errmsg->ts.type != BT_CHARACTER
&& !(errmsg->ref
@@ -8100,7 +8117,8 @@ resolve_transfer (gfc_code *code)
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, _("item in READ")) == FAILURE)
+ && gfc_check_vardef_context (exp, false, false, _("item in READ"))
+ == FAILURE)
return;
sym = exp->symtree->n.sym;
@@ -8201,13 +8219,15 @@ find_reachable_labels (gfc_code *block)
static void
resolve_lock_unlock (gfc_code *code)
{
- /* FIXME: Add more lock-variable checks. For now, always reject it.
- Note that ISO_FORTRAN_ENV's LOCK_TYPE is not yet available. */
- /* if (code->expr2->ts.type != BT_DERIVED
- || code->expr2->rank != 0
- || code->expr2->expr_type != EXPR_VARIABLE) */
- gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
- &code->expr1->where);
+ 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
@@ -8216,6 +8236,11 @@ resolve_lock_unlock (gfc_code *code)
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
@@ -8223,12 +8248,22 @@ resolve_lock_unlock (gfc_code *code)
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;
}
@@ -9143,8 +9178,8 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (t == FAILURE)
break;
- if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
- == FAILURE)
+ if (gfc_check_vardef_context (code->expr1, false, false,
+ _("assignment")) == FAILURE)
break;
if (resolve_ordinary_assign (code, ns))
@@ -9182,9 +9217,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
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, _("pointer assignment"));
+ t = gfc_check_vardef_context (e, true, false,
+ _("pointer assignment"));
if (t == SUCCESS)
- t = gfc_check_vardef_context (e, false, _("pointer assignment"));
+ t = gfc_check_vardef_context (e, false, false,
+ _("pointer assignment"));
gfc_free_expr (e);
if (t == FAILURE)
break;
@@ -12338,6 +12375,17 @@ 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)
+ {
+ 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
@@ -12358,6 +12406,12 @@ resolve_symbol (gfc_symbol *sym)
}
}
+ /* 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)
@@ -653,6 +653,47 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
tree
+gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED)
+{
+ gfc_se se, argse;
+ tree stat = NULL_TREE, lock_acquired = NULL_TREE;
+
+ /* Short cut: For single images without STAT= or LOCK_ACQUIRED
+ return early. (ERRMSG= is always untouched for -fcoarray=single.) */
+ if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB)
+ return NULL_TREE;
+
+ gfc_init_se (&se, NULL);
+ gfc_start_block (&se.pre);
+
+ if (code->expr2)
+ {
+ gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr2);
+ stat = argse.expr;
+ }
+
+ if (code->expr4)
+ {
+ gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr2);
+ lock_acquired = argse.expr;
+ }
+
+ if (stat != NULL_TREE)
+ gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
+
+ if (stat != NULL_TREE)
+ gfc_add_modify (&se.pre, lock_acquired,
+ build_int_cst (TREE_TYPE (lock_acquired), 0));
+
+ return gfc_finish_block (&se.pre);
+}
+
+
+tree
gfc_trans_sync (gfc_code *code, gfc_exec_op type)
{
gfc_se se, argse;
@@ -54,6 +54,7 @@ tree gfc_trans_do (gfc_code *, tree);
tree gfc_trans_do_while (gfc_code *);
tree gfc_trans_select (gfc_code *);
tree gfc_trans_sync (gfc_code *, gfc_exec_op);
+tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op);
tree gfc_trans_forall (gfc_code *);
tree gfc_trans_where (gfc_code *);
tree gfc_trans_allocate (gfc_code *);
@@ -1318,6 +1318,11 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_sync (code, code->op);
break;
+ case EXEC_LOCK:
+ case EXEC_UNLOCK:
+ res = gfc_trans_lock_unlock (code, code->op);
+ break;
+
case EXEC_FORALL:
res = gfc_trans_forall (code);
break;
@@ -10,6 +10,6 @@ integer :: s
character(len=3) :: c
logical :: bool
-LOCK (a, stat=s, acquired_lock=bool, errmsg=c) ! { dg-error "must be a scalar of type LOCK_TYPE" }
-UNLOCK (a, stat=s, errmsg=c) ! { dg-error "must be a scalar of type LOCK_TYPE" }
+LOCK (a, stat=s, acquired_lock=bool, errmsg=c) ! { dg-error "must be a scalar coarray of type LOCK_TYPE" }
+UNLOCK (a, stat=s, errmsg=c) ! { dg-error "must be a scalar coarray of type LOCK_TYPE" }
end
@@ -0,0 +1,107 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+!
+! LOCK/LOCK_TYPE checks
+!
+subroutine extends()
+use iso_fortran_env
+type t
+end type t
+type, extends(t) :: t2 ! { dg-error "coarray component, parent type .t. shall also have one" }
+ type(lock_type), allocatable :: c(:)[:]
+end type t2
+end subroutine extends
+
+module m
+ use iso_fortran_env
+
+ type t
+ type(lock_type), allocatable :: x(:)[:]
+ end type t
+
+ type t2
+ type(lock_type), allocatable :: x
+ end type t2
+end module m
+
+subroutine sub(x)
+ use iso_fortran_env
+ type(lock_type), intent(out) :: x[*] ! OK
+end subroutine sub
+
+subroutine sub1(x) ! { dg-error "is INTENT.OUT. and can thus not be an allocatable coarray or have coarray components" }
+ use iso_fortran_env
+ type(lock_type), allocatable, intent(out) :: x(:)[:]
+end subroutine sub1
+
+subroutine sub2(x) ! { dg-error "is INTENT.OUT. and can thus not be an allocatable coarray or have coarray components" }
+ use m
+ type(t), intent(out) :: x
+end subroutine sub2
+
+subroutine sub3(x) ! { dg-error "with coarray component shall be a nonpointer, nonallocatable scalar" }
+ use m
+ type(t), intent(inout) :: x[*]
+end subroutine sub3
+
+subroutine sub4(x)
+ use m
+ type(t2), intent(inout) :: x[*] ! OK
+end subroutine sub4
+
+subroutine lock_test
+ use iso_fortran_env
+ type t
+ end type t
+ type(lock_type) :: lock ! { dg-error "type LOCK_TYPE must be a coarray" }
+end subroutine lock_test
+
+subroutine lock_test2
+ use iso_fortran_env
+ implicit none
+ type t
+ end type t
+ type(t) :: x
+ type(lock_type), save :: lock[*],lock2(2)[*]
+ lock(t) ! { dg-error "Syntax error in LOCK statement" }
+ lock(x) ! { dg-error "must be a scalar coarray of type LOCK_TYPE" }
+ lock(lock)
+ lock(lock2(1))
+ lock(lock2) ! { dg-error "must be a scalar coarray of type LOCK_TYPE" }
+ lock(lock[1]) ! { dg-error "must be a scalar coarray of type LOCK_TYPE" }
+end subroutine lock_test2
+
+
+subroutine lock_test3
+ use iso_fortran_env
+ type(lock_type), save :: a[*], b[*]
+ a = b ! { dg-error "LOCK_TYPE in variable definition context" }
+ b = lock_type() ! { dg-error "LOCK_TYPE in variable definition context" }
+ print *, a ! { dg-error "cannot have PRIVATE components" }
+end subroutine lock_test3
+
+
+subroutine lock_test4
+ use iso_fortran_env
+ type(lock_type), allocatable :: A(:)[:]
+ logical :: ob
+ allocate(A(1)[*])
+ lock(A(1), acquired_lock=ob)
+ unlock(A(1))
+ deallocate(A)
+end subroutine lock_test4
+
+
+subroutine argument_check()
+ use iso_fortran_env
+ type(lock_type), SAVE :: ll[*]
+ call no_interface(ll) ! { dg-error "Actual argument of LOCK_TYPE or with LOCK_TYPE component at .1. requires an explicit interface" }
+ call test(ll) ! { dg-error "non-INTENT.INOUT. dummy .x. at .1., which is LOCK_TYPE or has a LOCK_TYPE component" }
+contains
+ subroutine test(x)
+ type(lock_type), intent(in) :: x[*]
+ end subroutine test
+end subroutine argument_check
+
+! { dg-final { cleanup-modules "m" } }