diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 29 | ||||
| -rw-r--r-- | gcc/fortran/check.c | 4 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 19 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 6 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 34 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.texi | 10 | ||||
| -rw-r--r-- | gcc/fortran/io.c | 10 | ||||
| -rw-r--r-- | gcc/fortran/iso-fortran-env.def | 7 | ||||
| -rw-r--r-- | gcc/fortran/module.c | 60 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 7 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 92 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 42 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/trans.c | 5 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray/lock_1.f90 | 32 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray_lock_1.f90 | 4 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray_lock_3.f90 | 107 |
19 files changed, 441 insertions, 37 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 08c666a..2e73625 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 972b290..79e1c95 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 f23fbbd4..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 e787187..dcf6c4e 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 89281a5..4afe467 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; @@ -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" diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 5ce5c1e..ba28648 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -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 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index cec45ca..f484a22 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; @@ -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) diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 183778f..a5f2d9e 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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; 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/ChangeLog b/gcc/testsuite/ChangeLog index 7939b52..f18487f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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, diff --git a/gcc/testsuite/gfortran.dg/coarray/lock_1.f90 b/gcc/testsuite/gfortran.dg/coarray/lock_1.f90 new file mode 100644 index 0000000..db4fbc8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/lock_1.f90 @@ -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 + 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 diff --git a/gcc/testsuite/gfortran.dg/coarray_lock_3.f90 b/gcc/testsuite/gfortran.dg/coarray_lock_3.f90 new file mode 100644 index 0000000..5e4c73f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_lock_3.f90 @@ -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" } } |