* [Patch, Fortran] (coarray) Add LOCK_TYPE
@ 2011-06-16 6:38 Tobias Burnus
2011-06-20 14:50 ` Tobias Burnus
0 siblings, 1 reply; 4+ messages in thread
From: Tobias Burnus @ 2011-06-16 6:38 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 462 bytes --]
This patch adds ISO_Fortran_Env's LOCK_TYPE, tons of constraint checks
and a simple implementation for -fcoarray=single.
With the implementation of LOCK_TYPE and (UN)LOCK, gfortran can now
parse all coarrays constructs of Fortran 2008. (However, there are still
known deficits and bugs in the resolving/code-producing stage; for
instance, allocatable scalar coarrays are not yet implemented.)
Build and regtested on x86-64-linux.
OK for the trunk?
Tobias
[-- Attachment #2: lock_type-2.diff --]
[-- Type: text/x-patch, Size: 29958 bytes --]
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.
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 1178967..04cd188 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -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);
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index f881bb1..4a7a951 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -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"
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index f23fbbd..8b834ab 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -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 */
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 46f9d14..19adf8a 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.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;
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 1cce144..a72da91 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -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;
}
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index cb46a77..57338f1 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -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}.
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index c2d46af..58c942f 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -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);
diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def
index 8ec7074..240a022 100644
--- a/gcc/fortran/iso-fortran-env.def
+++ b/gcc/fortran/iso-fortran-env.def
@@ -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
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 533246d..d524aee 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -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"
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 6013931..4f88411 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -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
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index b2c3189..e7c2e8a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -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)
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 183778f..31b2e10 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -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;
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index 8b77750..2d0faf1 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -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 *);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index ee35387..33593c5 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -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;
diff --git a/gcc/testsuite/gfortran.dg/coarray_lock_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lock_1.f90
index 419ba47..f9ef581 100644
--- a/gcc/testsuite/gfortran.dg/coarray_lock_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lock_1.f90
@@ -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
--- /dev/null 2011-06-15 19:51:47.947868702 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_lock_3.f90 2011-06-16 01:45:19.000000000 +0200
@@ -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" } }
^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: [Patch, Fortran] (coarray) Add LOCK_TYPE
2011-06-16 6:38 [Patch, Fortran] (coarray) Add LOCK_TYPE Tobias Burnus
@ 2011-06-20 14:50 ` Tobias Burnus
2011-06-20 19:35 ` Paul Richard Thomas
0 siblings, 1 reply; 4+ messages in thread
From: Tobias Burnus @ 2011-06-20 14:50 UTC (permalink / raw)
To: gcc patches, gfortran
*PING*
On 06/16/2011 08:27 AM, Tobias Burnus wrote:
> This patch adds ISO_Fortran_Env's LOCK_TYPE, tons of constraint checks
> and a simple implementation for -fcoarray=single.
>
> With the implementation of LOCK_TYPE and (UN)LOCK, gfortran can now
> parse all coarrays constructs of Fortran 2008. (However, there are
> still known deficits and bugs in the resolving/code-producing stage;
> for instance, allocatable scalar coarrays are not yet implemented.)
>
> Build and regtested on x86-64-linux.
> OK for the trunk?
>
> Tobias
^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: [Patch, Fortran] (coarray) Add LOCK_TYPE
2011-06-20 14:50 ` Tobias Burnus
@ 2011-06-20 19:35 ` Paul Richard Thomas
2011-06-20 22:10 ` Tobias Burnus
0 siblings, 1 reply; 4+ messages in thread
From: Paul Richard Thomas @ 2011-06-20 19:35 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
Dear Tobias,
I have checked out the code for any obvious style or other minor
errors and all looks well. However, I had a look at 8.5.6 "LOCK and
UNLOCK statements" in the standard and can only confess to feeling
very stupid tonight because I could not make head nor tail of the
example. Thus, I can offer no judgement on the functionality of your
patch.
In light of this and the rather thorough protection of the core F95
compiler from co-arrays, I would just go ahead and commit the patch,
if I were you.
OK for trunk
Paul
PS Please give me a co-array tutorial sometime!
On Mon, Jun 20, 2011 at 4:45 PM, Tobias Burnus <burnus@net-b.de> wrote:
> *PING*
>
> On 06/16/2011 08:27 AM, Tobias Burnus wrote:
>>
>> This patch adds ISO_Fortran_Env's LOCK_TYPE, tons of constraint checks and
>> a simple implementation for -fcoarray=single.
>>
>> With the implementation of LOCK_TYPE and (UN)LOCK, gfortran can now parse
>> all coarrays constructs of Fortran 2008. (However, there are still known
>> deficits and bugs in the resolving/code-producing stage; for instance,
>> allocatable scalar coarrays are not yet implemented.)
>>
>> Build and regtested on x86-64-linux.
>> OK for the trunk?
>>
>> Tobias
>
--
The knack of flying is learning how to throw yourself at the ground and miss.
--Hitchhikers Guide to the Galaxy
^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: [Patch, Fortran] (coarray) Add LOCK_TYPE
2011-06-20 19:35 ` Paul Richard Thomas
@ 2011-06-20 22:10 ` Tobias Burnus
0 siblings, 0 replies; 4+ messages in thread
From: Tobias Burnus @ 2011-06-20 22:10 UTC (permalink / raw)
To: Paul Richard Thomas; +Cc: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 2579 bytes --]
Dear Paul,
Paul Richard Thomas wrote:
> I have checked out the code for any obvious style or other minor
> errors and all looks well. However, I had a look at 8.5.6 "LOCK and
> UNLOCK statements" in the standard and can only confess to feeling
> very stupid tonight because I could not make head nor tail of the
> example. Thus, I can offer no judgement on the functionality of your
> patch.
Well, for a single image - and more the current patch does not support -
it is very simple: LOCK and UNLOCK do not do anything. If there is a
STAT=, it is set to 0 and if there is a LOCK_ACQUIRED= it is set to true.
But in general, a LOCK/UNLOCK pair allows to create a critical section,
where only one process at a time processes a certain block. Mostly one
image (process) can hold a lock at any given time.
The simplest case for LOCK is a CRITICAL block where only one process
(image) at a time can execute code in the block. However, LOCK allows more:
* With LOCK_ACQUIRED, it allows to perform some alternative action when
it cannot get the lock (otherwise, LOCK waits until it can obtain the lock)
* As the example in the standard shows: One can use one lock (variable)
to lock different section of the code.
In the example (Example 8.45): Each image (process) has a work queue.
This queue is filled (remotely) by its neighbour, i.e. "this_image()-1",
which is possible as the work queue is a coarray. In the first block,
each process checks whether there is a new item in its own
("this_image()") workqueue - in the second block, it adds a new item to
the neighbouring queue. While an item is being added or removed from the
queue, no parallel access should be happen - thus the access is guarded
via a lock. The lock is also a coarray, thus, there are num_image() locks.
In the example "work_queue" is the local arrays and thus semantically
identical to "work_queue[this_image()]" while "work_queue[me+1]" refers
to the remote coarray on image "me+1".
> OK for trunk
Thanks for the review! And good that you asked about the trans part.
There was actually a bug in it:
+ if (stat != NULL_TREE)
+ gfc_add_modify (&se.pre, lock_acquired,
+ build_int_cst (TREE_TYPE (lock_acquired), 0));
The check in "if" should be "lock_acquired" not "stat". Corrected in the
committed version (Rev. 175228). I have now also added a run-test (cf.
attachment) to make sure that it actually works.
> PS Please give me a co-array tutorial sometime!
I will, though I think for the real fun, one needs to have a working
mult-image support.
Tobias
[-- Attachment #2: lock_1.f90 --]
[-- Type: text/plain, Size: 476 bytes --]
! { dg-do run }
!
! LOCK/UNLOCK check
!
! PR fortran/18918
!
use iso_fortran_env
implicit none
type(lock_type) :: lock[*]
integer :: stat
logical :: acquired
LOCK(lock)
UNLOCK(lock)
stat = 99
LOCK(lock, stat=stat)
if (stat /= 0) call abort()
stat = 99
UNLOCK(lock, stat=stat)
if (stat /= 0) call abort()
if (this_image() == 1) then
acquired = .false.
LOCK (lock[this_image()], acquired_lock=acquired)
if (.not. acquired) call abort()
UNLOCK (lock[1])
end if
end
[-- Attachment #3: lock-changes.diff --]
[-- Type: text/x-patch, Size: 9242 bytes --]
Index: trans-stmt.c
===================================================================
--- trans-stmt.c (Revision 175227)
+++ trans-stmt.c (Arbeitskopie)
@@ -653,6 +653,48 @@ 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->expr4->expr_type == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr4);
+ lock_acquired = argse.expr;
+ }
+
+ if (stat != NULL_TREE)
+ gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
+
+ if (lock_acquired != NULL_TREE)
+ gfc_add_modify (&se.pre, lock_acquired,
+ fold_convert (TREE_TYPE (lock_acquired),
+ boolean_true_node));
+
+ return gfc_finish_block (&se.pre);
+}
+
+
+tree
gfc_trans_sync (gfc_code *code, gfc_exec_op type)
{
gfc_se se, argse;
Index: resolve.c
===================================================================
--- resolve.c (Revision 175227)
+++ resolve.c (Arbeitskopie)
@@ -6235,7 +6235,7 @@ gfc_resolve_iterator (gfc_iterator *iter, bool rea
== 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
/* 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
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;
@@ -12340,6 +12377,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
@@ -12360,6 +12408,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)
^ permalink raw reply [flat|nested] 4+ messages in thread
end of thread, other threads:[~2011-06-20 21:13 UTC | newest]
Thread overview: 4+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2011-06-16 6:38 [Patch, Fortran] (coarray) Add LOCK_TYPE Tobias Burnus
2011-06-20 14:50 ` Tobias Burnus
2011-06-20 19:35 ` Paul Richard Thomas
2011-06-20 22:10 ` Tobias Burnus
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).