OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays]) 

2011-06-20  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-20  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.
        * gfortran.dg/coarray/lock_1.f90: New.

From-SVN: r175228
This commit is contained in:
Tobias Burnus 2011-06-20 23:12:39 +02:00 committed by Tobias Burnus
parent 998c75b661
commit fea549356d
19 changed files with 441 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
gcc/fortran/ChangeLog
View File

@ -1,3 +1,32 @@
2011-06-20 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-18 Janus Weil <janus@gcc.gnu.org>
PR fortran/49400

4
gcc/fortran/check.c
View File

@ -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);

19
gcc/fortran/expr.c
View File

@ -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"

6
gcc/fortran/gfortran.h
View File

@ -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 */

34
gcc/fortran/interface.c
View File

@ -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;

2
gcc/fortran/intrinsic.c
View File

@ -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;
}

10
gcc/fortran/intrinsic.texi
View File

@ -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}.

10
gcc/fortran/io.c
View File

@ -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);

7
gcc/fortran/iso-fortran-env.def
View File

@ -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

60
gcc/fortran/module.c
View File

@ -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;
@ -5469,6 +5475,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. */
@ -5489,6 +5526,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
@ -5573,6 +5613,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"
@ -5626,6 +5676,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"

7
gcc/fortran/parse.c
View File

@ -2143,6 +2143,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

92
gcc/fortran/resolve.c
View File

@ -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;
@ -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)

42
gcc/fortran/trans-stmt.c
View File

@ -652,6 +652,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)
{

1
gcc/fortran/trans-stmt.h
View File

@ -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 *);

5
gcc/fortran/trans.c
View File

@ -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;

7
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,10 @@
2011-06-20 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.
* gfortran.dg/coarray/lock_1.f90: New.
2011-06-20 Janis Johnson <janisjo@codesourcery.com>
* lib/scandump.exp (scan-dump, scan-dump-times, scan-dump-not,

32
gcc/testsuite/gfortran.dg/coarray/lock_1.f90 Normal file
View File

@ -0,0 +1,32 @@
! { 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

4
gcc/testsuite/gfortran.dg/coarray_lock_1.f90
View File

@ -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

107
gcc/testsuite/gfortran.dg/coarray_lock_3.f90 Normal file
View File

@ -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" } }