From patchwork Wed Sep 22 12:10:22 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Daniel Kraft X-Patchwork-Id: 65419 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 0B5ECB70D5 for ; Wed, 22 Sep 2010 22:05:29 +1000 (EST) Received: (qmail 9776 invoked by alias); 22 Sep 2010 12:05:26 -0000 Received: (qmail 9724 invoked by uid 22791); 22 Sep 2010 12:05:15 -0000 X-SWARE-Spam-Status: No, hits=-1.2 required=5.0 tests=AWL, BAYES_50, RCVD_IN_DNSWL_LOW, SPF_HELO_PASS X-Spam-Check-By: sourceware.org Received: from taro.utanet.at (HELO taro.utanet.at) (213.90.36.45) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Wed, 22 Sep 2010 12:04:44 +0000 Received: from plenty.xoc.tele2net.at ([213.90.36.8]) by taro.utanet.at with esmtp (Exim 4.71) (envelope-from ) id 1OyO40-0007G4-OF; Wed, 22 Sep 2010 14:04:40 +0200 Received: from d86-33-197-55.cust.tele2.at ([86.33.197.55] helo=[192.168.1.18]) by plenty.xoc.tele2net.at with esmtpa (Exim 4.71) (envelope-from ) id 1OyO3z-00049D-Cf; Wed, 22 Sep 2010 14:04:40 +0200 Message-ID: <4C99F22E.6010403@domob.eu> Date: Wed, 22 Sep 2010 14:10:22 +0200 From: Daniel Kraft User-Agent: Thunderbird 2.0.0.0 (X11/20070425) MIME-Version: 1.0 To: Fortran List , gcc-patches Subject: [Patch, Fortran] Variable definition context checks Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Hi all, the attached patch implements general checks for things, that may/may not appear in a "variable definition context" or "pointer association context". Previously, checks that INTENT(IN), PROTECTED or impure variables (and other stuff) are not changed, were distributed among a number of source files and "duplicated" for all contexts, where a change could occur. This is reworked now so that all checks are done by gfc_check_vardef_context and this is called from different places as appropriate. In addition to the refactoring, the patch implements better checks for ASSOCIATE names, fixes the remaining bit of PR 44044, implements better checks for matching INTENT within procedures (i.e., that INTENT(IN) dummies are not passed on to INTENT([IN]OUT)) and also INTENT([IN]OUT) checks for intrinsics (which is PR 45474, IIRC). Finally, there were also rejects-valid issues with PROTECTED that are corrected now (see the changes in protected_4, protected_6 and protected_7). Note that this patch does not yet check the full list of variable definition contexts as given in the standard (F2008, 16.6.7), missing are the LOCK/UNLOCK items as well as the stuff related to IO -- this was the minimal set required to make the test-suite pass. As the patch is already quite large, I would like to get this in now since there are no test-suite regressions and add the remaining contexts as a follow-up. But if you prefer to have the full set at once, I can do this as well. All pointer association contexts (F2008, 16.6.8) should be checked, though. No regressions on GNU/Linux-x86-32. Ok for trunk? (If the follow-up is ok, I will prepare a ChangeLog for the current patch before check-in.) Yours, Daniel Index: gcc/fortran/interface.c =================================================================== --- gcc/fortran/interface.c (revision 164495) +++ gcc/fortran/interface.c (working copy) @@ -1655,36 +1655,6 @@ compare_parameter (gfc_symbol *formal, g } -/* Given a symbol of a formal argument list and an expression, see if - the two are compatible as arguments. Returns nonzero if - compatible, zero if not compatible. */ - -static int -compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual) -{ - if (actual->expr_type != EXPR_VARIABLE) - return 1; - - if (!actual->symtree->n.sym->attr.is_protected) - return 1; - - if (!actual->symtree->n.sym->attr.use_assoc) - return 1; - - if (formal->attr.intent == INTENT_IN - || formal->attr.intent == INTENT_UNKNOWN) - return 1; - - if (!actual->symtree->n.sym->attr.pointer) - return 0; - - if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer) - return 0; - - return 1; -} - - /* Returns the storage size of a symbol (formal argument) or zero if it cannot be determined. */ @@ -2205,27 +2175,20 @@ compare_actual_formal (gfc_actual_arglis } /* Check intent = OUT/INOUT for definable actual argument. */ - if ((a->expr->expr_type != EXPR_VARIABLE - || (a->expr->symtree->n.sym->attr.flavor != FL_VARIABLE - && a->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE)) - && (f->sym->attr.intent == INTENT_OUT - || f->sym->attr.intent == INTENT_INOUT)) - { - if (where) - gfc_error ("Actual argument at %L must be definable as " - "the dummy argument '%s' is INTENT = OUT/INOUT", - &a->expr->where, f->sym->name); - return 0; - } - - if (!compare_parameter_protected(f->sym, a->expr)) + if ((f->sym->attr.intent == INTENT_OUT + || f->sym->attr.intent == INTENT_INOUT)) { - if (where) - gfc_error ("Actual argument at %L is use-associated with " - "PROTECTED attribute and dummy argument '%s' is " - "INTENT = OUT/INOUT", - &a->expr->where,f->sym->name); - return 0; + const char* context = (where + ? _("actual argument to INTENT = OUT/INOUT") + : NULL); + + if (f->sym->attr.pointer + && gfc_check_vardef_context (a->expr, true, context) + == FAILURE) + return 0; + if (gfc_check_vardef_context (a->expr, false, context) + == FAILURE) + return 0; } if ((f->sym->attr.intent == INTENT_OUT Index: gcc/fortran/intrinsic.c =================================================================== --- gcc/fortran/intrinsic.c (revision 164495) +++ gcc/fortran/intrinsic.c (working copy) @@ -3585,6 +3585,19 @@ check_arglist (gfc_actual_arglist **ap, gfc_typename (&actual->expr->ts)); return FAILURE; } + + /* If the formal argument is INTENT([IN]OUT), check for definability. */ + if (formal->intent == INTENT_INOUT || formal->intent == INTENT_OUT) + { + const char* context = (error_flag + ? _("actual argument to INTENT = OUT/INOUT") + : NULL); + + /* No pointer arguments for intrinsics. */ + if (gfc_check_vardef_context (actual->expr, false, context) + == FAILURE) + return FAILURE; + } } return SUCCESS; Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (revision 164495) +++ gcc/fortran/gfortran.h (working copy) @@ -784,6 +784,9 @@ typedef struct unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1, private_comp:1, zero_comp:1, coarray_comp:1; + /* This is a temporary selector for SELECT TYPE. */ + unsigned select_type_temporary:1; + /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES). */ unsigned ext_attr:EXT_ATTR_NUM; @@ -2726,6 +2729,7 @@ bool gfc_has_ultimate_allocatable (gfc_e 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*); /* st.c */ Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (revision 164495) +++ gcc/fortran/expr.c (working copy) @@ -3043,10 +3043,8 @@ gfc_check_assign (gfc_expr *lvalue, gfc_ sym = lvalue->symtree->n.sym; - /* Check INTENT(IN), unless the object itself is the component or - sub-component of a pointer. */ + /* See if this is the component or subcomponent of a pointer. */ has_pointer = sym->attr.pointer; - for (ref = lvalue->ref; ref; ref = ref->next) if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) { @@ -3054,13 +3052,6 @@ gfc_check_assign (gfc_expr *lvalue, gfc_ break; } - if (!has_pointer && sym->attr.intent == INTENT_IN) - { - gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L", - sym->name, &lvalue->where); - return FAILURE; - } - /* 12.5.2.2, Note 12.26: The result variable is very similar to any other variable local to a function subprogram. Its existence begins when execution of the function is initiated and ends when execution of the @@ -3239,7 +3230,7 @@ gfc_check_pointer_assign (gfc_expr *lval symbol_attribute attr; gfc_ref *ref; bool is_pure, rank_remap; - int pointer, check_intent_in, proc_pointer; + int proc_pointer; if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN && !lvalue->symtree->n.sym->attr.proc_pointer) @@ -3259,24 +3250,13 @@ gfc_check_pointer_assign (gfc_expr *lval return FAILURE; } - - /* Check INTENT(IN), unless the object itself is the component or - sub-component of a pointer. */ - check_intent_in = 1; - pointer = lvalue->symtree->n.sym->attr.pointer; proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer; rank_remap = false; for (ref = lvalue->ref; ref; ref = ref->next) { - if (pointer) - check_intent_in = 0; - if (ref->type == REF_COMPONENT) - { - pointer = ref->u.c.component->attr.pointer; - proc_pointer = ref->u.c.component->attr.proc_pointer; - } + proc_pointer = ref->u.c.component->attr.proc_pointer; if (ref->type == REF_ARRAY && ref->next == NULL) { @@ -3332,30 +3312,8 @@ gfc_check_pointer_assign (gfc_expr *lval } } - if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN) - { - gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L", - lvalue->symtree->n.sym->name, &lvalue->where); - return FAILURE; - } - - if (!pointer && !proc_pointer - && !(lvalue->ts.type == BT_CLASS - && CLASS_DATA (lvalue)->attr.class_pointer)) - { - gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where); - return FAILURE; - } - is_pure = gfc_pure (NULL); - if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym) - && lvalue->symtree->n.sym->value != rvalue) - { - gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where); - return FAILURE; - } - /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type, kind, etc for lvalue and rvalue must match, and rvalue must be a pure variable if we're in a pure function. */ @@ -4338,3 +4296,188 @@ gfc_build_intrinsic_call (const char* na return result; } + + +/* Check if an expression may appear in a variable definition context + (F2008, 16.6.7) or pointer association context (F2008, 16.6.8). + This is called from the various places when resolving + the pieces that make up such a context. + + Optionally, a possible error message can be suppressed if context is NULL + and just the return status (SUCCESS / FAILURE) be requested. */ + +gfc_try +gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context) +{ + gfc_symbol* sym; + bool is_pointer; + bool check_intentin; + bool ptr_component; + symbol_attribute attr; + gfc_ref* ref; + + if (e->expr_type != EXPR_VARIABLE) + { + if (context) + gfc_error ("Non-variable expression in variable definition context (%s)" + " at %L", context, &e->where); + return FAILURE; + } + + gcc_assert (e->symtree); + sym = e->symtree->n.sym; + + if (!pointer && sym->attr.flavor == FL_PARAMETER) + { + if (context) + gfc_error ("Named constant '%s' in variable definition context (%s)" + " at %L", sym->name, context, &e->where); + return FAILURE; + } + if (!pointer && sym->attr.flavor != FL_VARIABLE + && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result) + && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)) + { + if (context) + gfc_error ("'%s' in variable definition context (%s) at %L is not" + " a variable", sym->name, context, &e->where); + return FAILURE; + } + + /* Find out whether the expr is a pointer; this also means following + component references to the last one. */ + attr = gfc_expr_attr (e); + is_pointer = (attr.pointer || attr.proc_pointer); + if (pointer && !is_pointer) + { + if (context) + gfc_error ("Non-POINTER in pointer association 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. */ + check_intentin = true; + ptr_component = sym->attr.pointer; + for (ref = e->ref; ref && check_intentin; ref = ref->next) + { + if (ptr_component && ref->type == REF_COMPONENT) + check_intentin = false; + if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) + ptr_component = true; + } + if (check_intentin && sym->attr.intent == INTENT_IN) + { + if (pointer && is_pointer) + { + if (context) + gfc_error ("Dummy-argument '%s' with INTENT(IN) in pointer" + " association context (%s) at %L", + sym->name, context, &e->where); + return FAILURE; + } + if (!pointer && !is_pointer) + { + if (context) + gfc_error ("Dummy-argument '%s' with INTENT(IN) in variable" + " definition context (%s) at %L", + sym->name, context, &e->where); + return FAILURE; + } + } + + /* PROTECTED and use-associated. */ + if (sym->attr.is_protected && sym->attr.use_assoc) + { + if (pointer && is_pointer) + { + if (context) + gfc_error ("Variable '%s' is PROTECTED and can not appear in a" + " pointer association context (%s) at %L", + sym->name, context, &e->where); + return FAILURE; + } + if (!pointer && !is_pointer) + { + if (context) + gfc_error ("Variable '%s' is PROTECTED and can not appear in a" + " variable definition context (%s) at %L", + sym->name, context, &e->where); + return FAILURE; + } + } + + /* Variable not assignable from a PURE procedure but appears in + variable definition context. */ + if (!pointer && gfc_pure (NULL) && gfc_impure_variable (sym)) + { + if (context) + gfc_error ("Variable '%s' can not appear in a variable definition" + " context (%s) at %L in PURE procedure", + sym->name, context, &e->where); + return FAILURE; + } + + /* Check variable definition context for associate-names. */ + if (!pointer && sym->assoc) + { + const char* name; + gfc_association_list* assoc; + + gcc_assert (sym->assoc->target); + + /* If this is a SELECT TYPE temporary (the association is used internally + for SELECT TYPE), silently go over to the target. */ + if (sym->attr.select_type_temporary) + { + gfc_expr* t = sym->assoc->target; + + gcc_assert (t->expr_type == EXPR_VARIABLE); + name = t->symtree->name; + + if (t->symtree->n.sym->assoc) + assoc = t->symtree->n.sym->assoc; + else + assoc = sym->assoc; + } + else + { + name = sym->name; + assoc = sym->assoc; + } + gcc_assert (name && assoc); + + /* Is association to a valid variable? */ + if (!assoc->variable) + { + if (context) + { + if (assoc->target->expr_type == EXPR_VARIABLE) + gfc_error ("'%s' at %L associated to vector-indexed target can" + " not be used in a variable definition context (%s)", + name, &e->where, context); + else + gfc_error ("'%s' at %L associated to expression can" + " not be used in a variable definition context (%s)", + name, &e->where, context); + } + return FAILURE; + } + + /* Target must be allowed to appear in a variable definition context. */ + if (gfc_check_vardef_context (assoc->target, pointer, NULL) == FAILURE) + { + if (context) + gfc_error ("Associate-name '%s' can not appear in a variable" + " definition context (%s) at %L because it's target" + " at %L can not, either", + name, context, &e->where, + &assoc->target->where); + return FAILURE; + } + } + + return SUCCESS; +} Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 164495) +++ gcc/fortran/resolve.c (working copy) @@ -2859,8 +2859,6 @@ gfc_iso_c_func_interface (gfc_symbol *sy /* Resolve a function call, which means resolving the arguments, then figuring out which entity the name refers to. */ -/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed - to INTENT(OUT) or INTENT(INOUT). */ static gfc_try resolve_function (gfc_expr *expr) @@ -6131,12 +6129,9 @@ gfc_resolve_iterator (gfc_iterator *iter == FAILURE) return FAILURE; - if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym)) - { - gfc_error ("Cannot assign to loop variable in PURE procedure at %L", - &iter->var->where); - return FAILURE; - } + if (gfc_check_vardef_context (iter->var, false, _("iterator variable")) + == FAILURE) + return FAILURE; if (gfc_resolve_iterator_expr (iter->start, real_ok, "Start expression in DO loop") == FAILURE) @@ -6331,14 +6326,11 @@ static gfc_try resolve_deallocate_expr (gfc_expr *e) { symbol_attribute attr; - int allocatable, pointer, check_intent_in; + int allocatable, pointer; gfc_ref *ref; gfc_symbol *sym; gfc_component *c; - /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ - check_intent_in = 1; - if (gfc_resolve_expr (e) == FAILURE) return FAILURE; @@ -6359,9 +6351,6 @@ resolve_deallocate_expr (gfc_expr *e) } for (ref = e->ref; ref; ref = ref->next) { - if (pointer) - check_intent_in = 0; - switch (ref->type) { case REF_ARRAY: @@ -6399,12 +6388,11 @@ resolve_deallocate_expr (gfc_expr *e) return FAILURE; } - if (check_intent_in && sym->attr.intent == INTENT_IN) - { - gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L", - sym->name, &e->where); - return FAILURE; - } + if (pointer + && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE) + return FAILURE; + if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE) + return FAILURE; if (e->ts.type == BT_CLASS) { @@ -6464,6 +6452,31 @@ gfc_expr_to_initialize (gfc_expr *e) } +/* If the last ref of an expression is an array ref, return a copy of the + expression with that one removed. Otherwise, a copy of the original + expression. This is used for allocate-expressions and pointer assignment + LHS, where there may be an array specification that needs to be stripped + off when using gfc_check_vardef_context. */ + +static gfc_expr* +remove_last_array_ref (gfc_expr* e) +{ + gfc_expr* e2; + gfc_ref** r; + + e2 = gfc_copy_expr (e); + for (r = &e2->ref; *r; r = &(*r)->next) + if ((*r)->type == REF_ARRAY && !(*r)->next) + { + gfc_free_ref_list (*r); + *r = NULL; + break; + } + + return e2; +} + + /* Used in resolve_allocate_expr to check that a allocation-object and a source-expr are conformable. This does not catch all possible cases; in particular a runtime checking is needed. */ @@ -6526,17 +6539,16 @@ conformable_arrays (gfc_expr *e1, gfc_ex static gfc_try resolve_allocate_expr (gfc_expr *e, gfc_code *code) { - int i, pointer, allocatable, dimension, check_intent_in, is_abstract; + int i, pointer, allocatable, dimension, is_abstract; int codimension; symbol_attribute attr; gfc_ref *ref, *ref2; + gfc_expr *e2; gfc_array_ref *ar; gfc_symbol *sym = NULL; gfc_alloc *a; gfc_component *c; - - /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ - check_intent_in = 1; + gfc_try t; /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR checking of coarrays. */ @@ -6588,9 +6600,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_ for (ref = e->ref; ref; ref2 = ref, ref = ref->next) { - if (pointer) - check_intent_in = 0; - switch (ref->type) { case REF_ARRAY: @@ -6677,12 +6686,18 @@ resolve_allocate_expr (gfc_expr *e, gfc_ goto failure; } - if (check_intent_in && sym->attr.intent == INTENT_IN) - { - gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L", - sym->name, &e->where); - goto failure; - } + /* In the variable definition context checks, gfc_expr_attr is used + on the expression. This is fooled by the array specification + present in e, thus we have to eliminate that one temporarily. */ + e2 = remove_last_array_ref (e); + t = SUCCESS; + if (t == SUCCESS && pointer) + t = gfc_check_vardef_context (e2, true, _("ALLOCATE object")); + if (t == SUCCESS) + t = gfc_check_vardef_context (e2, false, _("ALLOCATE object")); + gfc_free_expr (e2); + if (t == FAILURE) + goto failure; if (!code->expr3) { @@ -6733,9 +6748,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_ if (pointer || (dimension == 0 && codimension == 0)) goto success; - /* Make sure the next-to-last reference node is an array specification. */ + /* Make sure the last reference node is an array specifiction. */ - if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL + if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL || (dimension && ref2->u.ar.dimen == 0)) { gfc_error ("Array specification required in ALLOCATE statement " @@ -6846,20 +6861,13 @@ resolve_allocate_deallocate (gfc_code *c gfc_expr *stat, *errmsg, *pe, *qe; gfc_alloc *a, *p, *q; - stat = code->expr1 ? code->expr1 : NULL; - - errmsg = code->expr2 ? code->expr2 : NULL; + stat = code->expr1; + errmsg = code->expr2; /* Check the stat variable. */ if (stat) { - if (stat->symtree->n.sym->attr.intent == INTENT_IN) - gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)", - stat->symtree->n.sym->name, &stat->where); - - if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym)) - gfc_error ("Illegal stat-variable at %L for a PURE procedure", - &stat->where); + gfc_check_vardef_context (stat, false, _("STAT variable")); if ((stat->ts.type != BT_INTEGER && !(stat->ref && (stat->ref->type == REF_ARRAY @@ -6902,13 +6910,7 @@ resolve_allocate_deallocate (gfc_code *c gfc_warning ("ERRMSG at %L is useless without a STAT tag", &errmsg->where); - if (errmsg->symtree->n.sym->attr.intent == INTENT_IN) - gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)", - errmsg->symtree->n.sym->name, &errmsg->where); - - if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym)) - gfc_error ("Illegal errmsg-variable at %L for a PURE procedure", - &errmsg->where); + gfc_check_vardef_context (errmsg, false, _("ERRMSG variable")); if ((errmsg->ts.type != BT_CHARACTER && !(errmsg->ref @@ -7539,7 +7541,6 @@ static void resolve_assoc_var (gfc_symbol* sym, bool resolve_target) { gfc_expr* target; - bool to_var; gcc_assert (sym->assoc); gcc_assert (sym->attr.flavor == FL_VARIABLE); @@ -7573,22 +7574,8 @@ resolve_assoc_var (gfc_symbol* sym, bool gcc_assert (sym->ts.type != BT_UNKNOWN); /* See if this is a valid association-to-variable. */ - to_var = (target->expr_type == EXPR_VARIABLE - && !gfc_has_vector_subscript (target)); - if (sym->assoc->variable && !to_var) - { - if (target->expr_type == EXPR_VARIABLE) - gfc_error ("'%s' at %L associated to vector-indexed target can not" - " be used in a variable definition context", - sym->name, &sym->declared_at); - else - gfc_error ("'%s' at %L associated to expression can not" - " be used in a variable definition context", - sym->name, &sym->declared_at); - - return; - } - sym->assoc->variable = to_var; + sym->assoc->variable = (target->expr_type == EXPR_VARIABLE + && !gfc_has_vector_subscript (target)); /* Finally resolve if this is an array or not. */ if (sym->attr.dimension && target->rank == 0) @@ -7617,7 +7604,7 @@ resolve_assoc_var (gfc_symbol* sym, bool /* Resolve a SELECT TYPE statement. */ static void -resolve_select_type (gfc_code *code) +resolve_select_type (gfc_code *code, gfc_namespace *old_ns) { gfc_symbol *selector_type; gfc_code *body, *new_st, *if_st, *tail; @@ -7895,8 +7882,13 @@ resolve_select_type (gfc_code *code) default_case->next = if_st; } - resolve_select (code); + /* Resolve the internal code. This can not be done earlier because + it requires that the sym->assoc of selectors is set already. */ + gfc_current_ns = ns; + gfc_resolve_blocks (code->block, gfc_current_ns); + gfc_current_ns = old_ns; + resolve_select (code); } @@ -8657,7 +8649,6 @@ resolve_ordinary_assign (gfc_code *code, } } - if (lhs->ts.type == BT_CHARACTER && gfc_option.warn_character_truncation) { @@ -8698,15 +8689,6 @@ resolve_ordinary_assign (gfc_code *code, if (gfc_pure (NULL)) { - if (gfc_impure_variable (lhs->symtree->n.sym)) - { - gfc_error ("Cannot assign to variable '%s' in PURE " - "procedure at %L", - lhs->symtree->n.sym->name, - &lhs->where); - return rval; - } - if (lhs->ts.type == BT_DERIVED && lhs->expr_type == EXPR_VARIABLE && lhs->ts.u.derived->attr.pointer_comp @@ -8810,9 +8792,8 @@ resolve_code (gfc_code *code, gfc_namesp gfc_resolve_omp_do_blocks (code, ns); break; case EXEC_SELECT_TYPE: - gfc_current_ns = code->ext.block.ns; - gfc_resolve_blocks (code->block, gfc_current_ns); - gfc_current_ns = ns; + /* Blocks are handled in resolve_select_type because we have + to transform the SELECT TYPE into ASSOCIATE first. */ break; case EXEC_OMP_WORKSHARE: omp_workshare_save = omp_workshare_flag; @@ -8899,6 +8880,10 @@ resolve_code (gfc_code *code, gfc_namesp if (t == FAILURE) break; + if (gfc_check_vardef_context (code->expr1, false, _("assignment")) + == FAILURE) + break; + if (resolve_ordinary_assign (code, ns)) { if (code->op == EXEC_COMPCALL) @@ -8923,11 +8908,27 @@ resolve_code (gfc_code *code, gfc_namesp break; case EXEC_POINTER_ASSIGN: - if (t == FAILURE) - break; + { + gfc_expr* e; - gfc_check_pointer_assign (code->expr1, code->expr2); - break; + if (t == FAILURE) + break; + + /* This is both a variable definition and pointer assignment + context, so check both of them. For rank remapping, a final + 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")); + if (t == SUCCESS) + t = gfc_check_vardef_context (e, false, _("pointer assignment")); + gfc_free_expr (e); + if (t == FAILURE) + break; + + gfc_check_pointer_assign (code->expr1, code->expr2); + break; + } case EXEC_ARITHMETIC_IF: if (t == SUCCESS @@ -8970,7 +8971,7 @@ resolve_code (gfc_code *code, gfc_namesp break; case EXEC_SELECT_TYPE: - resolve_select_type (code); + resolve_select_type (code, ns); break; case EXEC_BLOCK: Index: gcc/fortran/match.c =================================================================== --- gcc/fortran/match.c (revision 164495) +++ gcc/fortran/match.c (working copy) @@ -978,13 +978,6 @@ gfc_match_iterator (gfc_iterator *iter, goto cleanup; } - if (var->symtree->n.sym->attr.intent == INTENT_IN) - { - gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)", - var->symtree->n.sym->name); - goto cleanup; - } - gfc_match_char ('='); var->symtree->n.sym->attr.implied_index = 1; @@ -1847,9 +1840,7 @@ gfc_match_associate (void) /* The `variable' field is left blank for now; because the target is not yet resolved, we can't use gfc_has_vector_subscript to determine it - for now. Instead, if the symbol is matched as variable, this field - is set -- and during resolution we check that. */ - newAssoc->variable = 0; + for now. This is set during resolution. */ /* Put it into the list. */ newAssoc->next = new_st.ext.block.assoc; @@ -3166,12 +3157,6 @@ gfc_match_nullify (void) if (gfc_check_do_variable (p->symtree)) goto cleanup; - if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym)) - { - gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure"); - goto cleanup; - } - /* build ' => NULL() '. */ e = gfc_get_null_expr (&gfc_current_locus); @@ -4523,6 +4508,7 @@ select_type_set_tmp (gfc_typespec *ts) &tmp->n.sym->as, false); tmp->n.sym->attr.class_ok = 1; } + tmp->n.sym->attr.select_type_temporary = 1; /* Add an association for it, so the rest of the parser knows it is an associate-name. The target will be set during resolution. */ Index: gcc/fortran/primary.c =================================================================== --- gcc/fortran/primary.c (revision 164495) +++ gcc/fortran/primary.c (working copy) @@ -2007,7 +2007,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_t if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION) gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable"); - ref = expr->ref; sym = expr->symtree->n.sym; attr = sym->attr; @@ -2031,7 +2030,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_t if (ts != NULL && expr->ts.type == BT_UNKNOWN) *ts = sym->ts; - for (; ref; ref = ref->next) + for (ref = expr->ref; ref; ref = ref->next) switch (ref->type) { case REF_ARRAY: @@ -2986,13 +2985,7 @@ match_variable (gfc_expr **result, int e switch (sym->attr.flavor) { case FL_VARIABLE: - if (sym->attr.is_protected && sym->attr.use_assoc) - { - gfc_error ("Assigning to PROTECTED variable at %C"); - return MATCH_ERROR; - } - if (sym->assoc) - sym->assoc->variable = 1; + /* Everything is alright. */ break; case FL_UNKNOWN: @@ -3024,22 +3017,24 @@ match_variable (gfc_expr **result, int e case FL_PARAMETER: if (equiv_flag) - gfc_error ("Named constant at %C in an EQUIVALENCE"); - else - gfc_error ("Cannot assign to a named constant at %C"); - return MATCH_ERROR; + { + gfc_error ("Named constant at %C in an EQUIVALENCE"); + return MATCH_ERROR; + } + /* Otherwise this is checked for and an error given in the + variable definition context checks. */ break; case FL_PROCEDURE: /* Check for a nonrecursive function result variable. */ if (sym->attr.function - && !sym->attr.external - && sym->result == sym - && (gfc_is_function_return_value (sym, gfc_current_ns) - || (sym->attr.entry - && sym->ns == gfc_current_ns) - || (sym->attr.entry - && sym->ns == gfc_current_ns->parent))) + && !sym->attr.external + && sym->result == sym + && (gfc_is_function_return_value (sym, gfc_current_ns) + || (sym->attr.entry + && sym->ns == gfc_current_ns) + || (sym->attr.entry + && sym->ns == gfc_current_ns->parent))) { /* If a function result is a derived type, then the derived type may still have to be resolved. */ Index: gcc/testsuite/gfortran.dg/associate_5.f03 =================================================================== --- gcc/testsuite/gfortran.dg/associate_5.f03 (revision 164495) +++ gcc/testsuite/gfortran.dg/associate_5.f03 (working copy) @@ -18,9 +18,26 @@ PROGRAM main ptr => a ! { dg-error "neither TARGET nor POINTER" } END ASSOCIATE - ASSOCIATE (a => 5, & ! { dg-error "variable definition context" } - b => arr((/ 1, 3 /))) ! { dg-error "variable definition context" } - a = 4 - b = 7 + ASSOCIATE (a => 5, b => arr((/ 1, 3 /))) + a = 4 ! { dg-error "variable definition context" } + b = 7 ! { dg-error "variable definition context" } + CALL test2 (a) ! { dg-error "variable definition context" } + CALL test2 (b) ! { dg-error "variable definition context" } END ASSOCIATE + +CONTAINS + + SUBROUTINE test (x) + INTEGER, INTENT(IN) :: x + ASSOCIATE (y => x) ! { dg-error "variable definition context" } + y = 5 ! { dg-error "variable definition context" } + CALL test2 (x) ! { dg-error "variable definition context" } + END ASSOCIATE + END SUBROUTINE test + + ELEMENTAL SUBROUTINE test2 (x) + INTEGER, INTENT(OUT) :: x + x = 5 + END SUBROUTINE test2 + END PROGRAM main Index: gcc/testsuite/gfortran.dg/impure_assignment_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/impure_assignment_2.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/impure_assignment_2.f90 (working copy) @@ -23,7 +23,7 @@ CONTAINS TYPE(node_type), POINTER :: node TYPE(node_type), POINTER :: give_next give_next => node%next ! { dg-error "Bad target" } - node%next => give_next ! { dg-error "Bad pointer object" } + node%next => give_next ! { dg-error "variable definition context" } END FUNCTION ! Comment #2 PURE integer FUNCTION give_next2(i) @@ -55,14 +55,14 @@ CONTAINS TYPE(T1), POINTER :: RES RES => A ! { dg-error "Bad target" } RES => B ! { dg-error "Bad target" } - B => RES ! { dg-error "Bad pointer object" } + B => RES ! { dg-error "variable definition context" } END FUNCTION PURE FUNCTION TST2(A) RESULT(RES) TYPE(T1), INTENT(IN), TARGET :: A TYPE(T1), POINTER :: RES allocate (RES) RES = A - B = RES ! { dg-error "Cannot assign" } + B = RES ! { dg-error "variable definition context" } RES = B END FUNCTION END MODULE pr20882 Index: gcc/testsuite/gfortran.dg/enum_5.f90 =================================================================== --- gcc/testsuite/gfortran.dg/enum_5.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/enum_5.f90 (working copy) @@ -10,7 +10,7 @@ program main enumerator :: blue = 1 end enum junk ! { dg-error "Syntax error" } - blue = 10 ! { dg-error " assign to a named constant" } + blue = 10 ! { dg-error "Unexpected assignment" } end program main ! { dg-error "Expecting END ENUM" } ! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } Index: gcc/testsuite/gfortran.dg/pointer_intent_3.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pointer_intent_3.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/pointer_intent_3.f90 (working copy) @@ -19,11 +19,11 @@ program test contains subroutine a(p) integer, pointer,intent(in) :: p - p => null(p)! { dg-error "Cannot assign to INTENT\\(IN\\) variable" } - nullify(p) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" } - allocate(p) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" } - call c(p) ! { dg-error "is INTENT\\(IN\\) while interface specifies INTENT\\(INOUT\\)" } - deallocate(p) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" } + p => null(p)! { dg-error "pointer association context" } + nullify(p) ! { dg-error "pointer association context" } + allocate(p) ! { dg-error "pointer association context" } + call c(p) ! { dg-error "pointer association context" } + deallocate(p) ! { dg-error "pointer association context" } end subroutine subroutine c(p) integer, pointer, intent(inout) :: p @@ -32,10 +32,10 @@ contains subroutine b(t) type(myT),intent(in) :: t t%jp = 5 - t%jp => null(t%jp) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" } - nullify(t%jp) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" } - t%j = 7 ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" } - allocate(t%jp) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" } - deallocate(t%jp) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" } + t%jp => null(t%jp) ! { dg-error "pointer association context" } + nullify(t%jp) ! { dg-error "pointer association context" } + t%j = 7 ! { dg-error "variable definition context" } + allocate(t%jp) ! { dg-error "pointer association context" } + deallocate(t%jp) ! { dg-error "pointer association context" } end subroutine b end program Index: gcc/testsuite/gfortran.dg/intent_out_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/intent_out_1.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/intent_out_1.f90 (working copy) @@ -3,10 +3,10 @@ ! Contributed by Paul Thomas real, parameter :: a =42.0 real :: b - call foo(b + 2.0) ! { dg-error "must be definable" } - call foo(a) ! { dg-error "must be definable" } - call bar(b + 2.0) ! { dg-error "must be definable" } - call bar(a) ! { dg-error "must be definable" } + call foo(b + 2.0) ! { dg-error "variable definition context" } + call foo(a) ! { dg-error "variable definition context" } + call bar(b + 2.0) ! { dg-error "variable definition context" } + call bar(a) ! { dg-error "variable definition context" } contains subroutine foo(a) real, intent(out) :: a Index: gcc/testsuite/gfortran.dg/select_type_17.f03 =================================================================== --- gcc/testsuite/gfortran.dg/select_type_17.f03 (revision 0) +++ gcc/testsuite/gfortran.dg/select_type_17.f03 (revision 0) @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +! PR fortran/44044 +! Definability check for select type to expression. +! This is "bonus feature #2" from comment #3 of the PR. + +! Contributed by Janus Weil, janus@gcc.gnu.org. + +implicit none + +type :: t1 + integer :: i +end type + +type, extends(t1) :: t2 +end type + +type(t1),target :: x1 +type(t2),target :: x2 + +select type ( y => fun(1) ) +type is (t1) + y%i = 1 ! { dg-error "variable definition context" } +type is (t2) + y%i = 2 ! { dg-error "variable definition context" } +end select + +contains + + function fun(i) + class(t1),pointer :: fun + integer :: i + if (i>0) then + fun => x1 + else if (i<0) then + fun => x2 + else + fun => NULL() + end if + end function + +end + Index: gcc/testsuite/gfortran.dg/protected_5.f90 =================================================================== --- gcc/testsuite/gfortran.dg/protected_5.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/protected_5.f90 (working copy) @@ -49,9 +49,9 @@ end module good2 program main use good2 implicit none - t%j = 15 ! { dg-error "Assigning to PROTECTED variable" } - nullify(t%p) ! { dg-error "Assigning to PROTECTED variable" } - allocate(t%array(15))! { dg-error "Assigning to PROTECTED variable" } + t%j = 15 ! { dg-error "variable definition context" } + nullify(t%p) ! { dg-error "pointer association context" } + allocate(t%array(15))! { dg-error "variable definition context" } end program main ! { dg-final { cleanup-modules "good1 good2 bad1 bad2" } } Index: gcc/testsuite/gfortran.dg/intent_out_3.f90 =================================================================== --- gcc/testsuite/gfortran.dg/intent_out_3.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/intent_out_3.f90 (working copy) @@ -15,6 +15,6 @@ CONTAINS END SUBROUTINE S1 END MODULE M1 USE M1 -CALL S1(D1%I(3)) ! { dg-error "must be definable" } +CALL S1(D1%I(3)) ! { dg-error "variable definition context" } END ! { dg-final { cleanup-modules "m1" } } Index: gcc/testsuite/gfortran.dg/protected_7.f90 =================================================================== --- gcc/testsuite/gfortran.dg/protected_7.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/protected_7.f90 (working copy) @@ -13,8 +13,8 @@ program p integer, pointer :: unprotected_pointer ! The next two lines should be rejected; see PR 37513 why ! we get such a strange error message. - protected_pointer => unprotected_pointer ! { dg-error "only allowed in specification part" } - protected_pointer = unprotected_pointer ! { dg-error "only allowed in specification part" } + protected_pointer => unprotected_pointer ! { dg-error "pointer association context" } + protected_pointer = unprotected_pointer ! OK unprotected_pointer => protected_target ! { dg-error "target has PROTECTED attribute" } unprotected_pointer => protected_pointer ! OK end program p Index: gcc/testsuite/gfortran.dg/equiv_constraint_8.f90 =================================================================== --- gcc/testsuite/gfortran.dg/equiv_constraint_8.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/equiv_constraint_8.f90 (working copy) @@ -9,7 +9,7 @@ pure integer function test(j) common /z/ i integer :: k equivalence(i,k) ! { dg-error "EQUIVALENCE object in the pure" } - k=1 ! { dg-error "in PURE procedure at" } + k=1 ! { dg-error "variable definition context" } test=i*j end function test end Index: gcc/testsuite/gfortran.dg/deallocate_alloc_opt_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/deallocate_alloc_opt_2.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/deallocate_alloc_opt_2.f90 (working copy) @@ -6,7 +6,7 @@ subroutine sub(i, j, err) integer, intent(in), allocatable :: i(:) integer, allocatable :: m(:) integer n - deallocate(i) ! { dg-error "Cannot deallocate" "" } - deallocate(m, stat=j) ! { dg-error "cannot be" "" } - deallocate(m,stat=n,errmsg=err) ! { dg-error "cannot be" "" } + deallocate(i) ! { dg-error "variable definition context" } + deallocate(m, stat=j) ! { dg-error "variable definition context" } + deallocate(m,stat=n,errmsg=err) ! { dg-error "variable definition context" } end subroutine sub Index: gcc/testsuite/gfortran.dg/char_expr_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/char_expr_2.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/char_expr_2.f90 (working copy) @@ -11,5 +11,5 @@ interface end subroutine foo end interface character :: n(5) -call foo( (n) ) ! { dg-error "must be definable" } +call foo( (n) ) ! { dg-error "Non-variable expression" } end Index: gcc/testsuite/gfortran.dg/pointer_assign_7.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pointer_assign_7.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/pointer_assign_7.f90 (working copy) @@ -18,7 +18,7 @@ type(face_t), pointer :: face allocate(face) allocate(blu) -face%bla => blu ! { dg-error "Pointer assignment to non-POINTER" } +face%bla => blu ! { dg-error "Non-POINTER in pointer association context" } end program Index: gcc/testsuite/gfortran.dg/enum_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/enum_2.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/enum_2.f90 (working copy) @@ -9,5 +9,7 @@ program main enumerator blue = 1 ! { dg-error "Syntax error in ENUMERATOR definition" } end enum + red = 42 ! { dg-error "variable definition context" } + enumerator :: sun ! { dg-error "ENUM" } end program main Index: gcc/testsuite/gfortran.dg/pr19936_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr19936_1.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/pr19936_1.f90 (working copy) @@ -1,5 +1,5 @@ ! { dg-do compile } program pr19936_1 integer, parameter :: i=4 - print *,(/(i,i=1,4)/) ! { dg-error "assign to a named constant" } + print *,(/(i,i=1,4)/) ! { dg-error "variable definition context" } end program pr19936_1 Index: gcc/testsuite/gfortran.dg/impure_assignment_3.f90 =================================================================== --- gcc/testsuite/gfortran.dg/impure_assignment_3.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/impure_assignment_3.f90 (working copy) @@ -20,7 +20,7 @@ contains class is (myType) x%a = 42. r3 = 43. - g = 44. ! { dg-error "Cannot assign to variable" } + g = 44. ! { dg-error "variable definition context" } end select end subroutine @@ -30,7 +30,7 @@ contains real :: r2 r1 = 45. r2 = 46. - g = 47. ! { dg-error "Cannot assign to variable" } + g = 47. ! { dg-error "variable definition context" } end block end subroutine Index: gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 =================================================================== --- gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 (working copy) @@ -38,7 +38,7 @@ type(t) :: x x%ptr2 => x ! { dg-error "Invalid procedure pointer assignment" } -x => x%ptr2 ! { dg-error "Pointer assignment to non-POINTER" } +x => x%ptr2 ! { dg-error "Non-POINTER in pointer association context" } print *, x%ptr1() ! { dg-error "attribute conflicts with" } call x%ptr2() ! { dg-error "attribute conflicts with" } Index: gcc/testsuite/gfortran.dg/simpleif_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/simpleif_2.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/simpleif_2.f90 (working copy) @@ -10,6 +10,6 @@ module read subroutine a integer, parameter :: n = 2 if (i .eq. 0) read(j,*) k - if (i .eq. 0) n = j ! { dg-error "assign to a named constant" "" } + if (i .eq. 0) n = j ! { dg-error "Named constant 'n' in variable definition context" } end subroutine a end module read Index: gcc/testsuite/gfortran.dg/protected_4.f90 =================================================================== --- gcc/testsuite/gfortran.dg/protected_4.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/protected_4.f90 (working copy) @@ -23,15 +23,15 @@ program main integer :: j logical :: asgnd protected :: j ! { dg-error "only allowed in specification part of a module" } - a = 43 ! { dg-error "Assigning to PROTECTED variable" } - ap => null() ! { dg-error "Assigning to PROTECTED variable" } - nullify(ap) ! { dg-error "Assigning to PROTECTED variable" } - ap => at ! { dg-error "Assigning to PROTECTED variable" } - ap = 3 ! { dg-error "Assigning to PROTECTED variable" } - allocate(ap) ! { dg-error "Assigning to PROTECTED variable" } - ap = 73 ! { dg-error "Assigning to PROTECTED variable" } - call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" } - call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" } + a = 43 ! { dg-error "variable definition context" } + ap => null() ! { dg-error "pointer association context" } + nullify(ap) ! { dg-error "pointer association context" } + ap => at ! { dg-error "pointer association context" } + ap = 3 ! OK + allocate(ap) ! { dg-error "pointer association context" } + ap = 73 ! OK + call increment(a,at) ! { dg-error "variable definition context" } + call pointer_assignments(ap) ! { dg-error "pointer association context" } asgnd = pointer_check(ap) contains subroutine increment(a1,a3) Index: gcc/testsuite/gfortran.dg/protected_6.f90 =================================================================== --- gcc/testsuite/gfortran.dg/protected_6.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/protected_6.f90 (working copy) @@ -19,15 +19,15 @@ end module protmod program main use protmod implicit none - a = 43 ! { dg-error "Assigning to PROTECTED variable" } - ap => null() ! { dg-error "Assigning to PROTECTED variable" } - nullify(ap) ! { dg-error "Assigning to PROTECTED variable" } - ap => at ! { dg-error "Assigning to PROTECTED variable" } - ap = 3 ! { dg-error "Assigning to PROTECTED variable" } - allocate(ap) ! { dg-error "Assigning to PROTECTED variable" } - ap = 73 ! { dg-error "Assigning to PROTECTED variable" } - call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" } - call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" } + a = 43 ! { dg-error "variable definition context" } + ap => null() ! { dg-error "pointer association context" } + nullify(ap) ! { dg-error "pointer association context" } + ap => at ! { dg-error "pointer association context" } + ap = 3 ! OK + allocate(ap) ! { dg-error "pointer association context" } + ap = 73 ! OK + call increment(a,at) ! { dg-error "variable definition context" } + call pointer_assignments(ap) ! { dg-error "pointer association context" } contains subroutine increment(a1,a3) integer, intent(inout) :: a1, a3 Index: gcc/testsuite/gfortran.dg/intrinsic_intent_1.f03 =================================================================== --- gcc/testsuite/gfortran.dg/intrinsic_intent_1.f03 (revision 0) +++ gcc/testsuite/gfortran.dg/intrinsic_intent_1.f03 (revision 0) @@ -0,0 +1,11 @@ +! { dg-do compile } + +! PR fortran/45474 +! Definability checks for INTENT([IN]OUT) and intrinsics. + +! Contributed by Tobias Burnus, burnus@gcc.gnu.org. + +call execute_command_line("date", .true.,(1),1,'aa') ! { dg-error "variable definition context" } +call execute_command_line("date", .true.,1,(1),'aa') ! { dg-error "variable definition context" } +call execute_command_line("date", .true.,1,1,('aa')) ! { dg-error "variable definition context" } +end Index: gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90 (working copy) @@ -16,13 +16,13 @@ contains subroutine init2(x) integer, allocatable, intent(in) :: x(:) - allocate(x(3)) ! { dg-error "Cannot allocate" } + allocate(x(3)) ! { dg-error "variable definition context" } end subroutine init2 subroutine kill(x) integer, allocatable, intent(in) :: x(:) - deallocate(x) ! { dg-error "Cannot deallocate" } + deallocate(x) ! { dg-error "variable definition context" } end subroutine kill end program alloc_dummy Index: gcc/testsuite/gfortran.dg/allocate_alloc_opt_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_alloc_opt_2.f90 (revision 164495) +++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_2.f90 (working copy) @@ -6,7 +6,7 @@ subroutine sub(i, j, err) integer, intent(in), allocatable :: i(:) integer, allocatable :: m(:) integer n - allocate(i(2)) ! { dg-error "Cannot allocate" "" } - allocate(m(2), stat=j) ! { dg-error "cannot be" "" } - allocate(m(2),stat=n,errmsg=err) ! { dg-error "cannot be" "" } + allocate(i(2)) ! { dg-error "variable definition context" } + allocate(m(2), stat=j) ! { dg-error "variable definition context" } + allocate(m(2),stat=n,errmsg=err) ! { dg-error "variable definition context" } end subroutine sub