diff options
Diffstat (limited to 'gcc/fortran/resolve.c')
| -rw-r--r-- | gcc/fortran/resolve.c | 93 |
1 files changed, 82 insertions, 11 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index febf0fa..6598855 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7055,6 +7055,21 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) &code->expr3->where, &e->where); goto failure; } + + /* Check TS18508, C702/C703. */ + if (code->expr3->ts.type == BT_DERIVED + && ((codimension && gfc_expr_attr (code->expr3).event_comp) + || (code->expr3->ts.u.derived->from_intmod + == INTMOD_ISO_FORTRAN_ENV + && code->expr3->ts.u.derived->intmod_sym_id + == ISOFORTRAN_EVENT_TYPE))) + { + gfc_error ("The source-expr at %L shall neither be of type " + "EVENT_TYPE nor have a EVENT_TYPE component if " + "allocate-object at %L is a coarray", + &code->expr3->where, &e->where); + goto failure; + } } /* Check F08:C629. */ @@ -7106,6 +7121,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) no SOURCE exists by setting expr3. */ code->expr3 = gfc_default_initializer (&code->ext.alloc.ts); } + else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED + && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) + { + /* We have to zero initialize the integer variable. */ + code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0); + } else if (!code->expr3) { /* Set up default initializer if needed. */ @@ -8706,21 +8728,40 @@ find_reachable_labels (gfc_code *block) static void -resolve_lock_unlock (gfc_code *code) +resolve_lock_unlock_event (gfc_code *code) { if (code->expr1->expr_type == EXPR_FUNCTION && code->expr1->value.function.isym && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET) remove_caf_get_intrinsic (code->expr1); - 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_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1))) + if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK) + && (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_is_coarray (code->expr1) && + !gfc_is_coindexed (code->expr1)))) gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE", &code->expr1->where); + else if ((code->op == EXEC_EVENT_POST && code->op == EXEC_EVENT_WAIT) + && (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_EVENT_TYPE + || code->expr1->rank != 0)) + gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE", + &code->expr1->where); + else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1) + && !gfc_is_coindexed (code->expr1)) + gfc_error ("Event variable argument at %L must be a coarray or coindexed", + &code->expr1->where); + else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1)) + gfc_error ("Event variable argument at %L must be a coarray but not " + "coindexed", &code->expr1->where); /* Check STAT. */ if (code->expr2 @@ -8746,17 +8787,23 @@ resolve_lock_unlock (gfc_code *code) _("ERRMSG variable"))) return; - /* Check ACQUIRED_LOCK. */ - if (code->expr4 + /* Check for LOCK the ACQUIRED_LOCK. */ + if (code->op != EXEC_EVENT_WAIT && 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 + if (code->op != EXEC_EVENT_WAIT && code->expr4 && !gfc_check_vardef_context (code->expr4, false, false, false, _("ACQUIRED_LOCK variable"))) return; + + /* Check for EVENT WAIT the UNTIL_COUNT. */ + if (code->op == EXEC_EVENT_WAIT && code->expr4 + && (code->expr4->ts.type != BT_INTEGER || code->expr4->rank != 0)) + gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER " + "expression", &code->expr4->where); } @@ -10403,7 +10450,9 @@ start: case EXEC_LOCK: case EXEC_UNLOCK: - resolve_lock_unlock (code); + case EXEC_EVENT_POST: + case EXEC_EVENT_WAIT: + resolve_lock_unlock_event (code); break; case EXEC_ENTRY: @@ -14001,6 +14050,19 @@ resolve_symbol (gfc_symbol *sym) return; } + /* TS18508, C702/C703. */ + if (sym->ts.type == BT_DERIVED + && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) + || sym->ts.u.derived->attr.event_comp) + && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp) + { + gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent 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 @@ -14030,6 +14092,15 @@ resolve_symbol (gfc_symbol *sym) return; } + /* TS18508. */ + if (sym->ts.type == BT_DERIVED && sym->attr.dummy + && sym->attr.intent == INTENT_OUT && sym->attr.event_comp) + { + gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be " + "INTENT(OUT)", sym->name, &sym->declared_at); + return; + } + /* F2008, C525. */ if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) || (sym->ts.type == BT_CLASS && sym->attr.class_ok |