From patchwork Tue Aug 4 19:01:58 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 1340985 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=gcc.gnu.org Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=wetVV/F+; dkim-atps=neutral Received: from sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4BLkdf3QHqz9sR4 for ; Wed, 5 Aug 2020 05:02:12 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id F32A1385043C; Tue, 4 Aug 2020 19:02:06 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org F32A1385043C DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1596567727; bh=7frxup29rW/8JXZjvgPahy9HBsxoz++U4aLJXwkZBZQ=; h=To:Subject:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=wetVV/F+tekz7k+WYRsnc/GmelkCYAyi3v60z9SqWTPnhB6FhCsSxfnEJ8/5NAQq6 pIBbs5AvyXApC2/4TIuW7AZXIPt0lAVBxSze/6P/3cdgZyiX8O9pzPEtITzEf/vhlz YNDNWoC7V3ChSf86fm5qvXapZotfxlF+DvFcHUL0= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from cc-smtpout2.netcologne.de (cc-smtpout2.netcologne.de [IPv6:2001:4dd0:100:1062:25:2:0:2]) by sourceware.org (Postfix) with ESMTPS id 178E7385043C; Tue, 4 Aug 2020 19:02:03 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 178E7385043C Received: from cc-smtpin3.netcologne.de (cc-smtpin3.netcologne.de [89.1.8.203]) by cc-smtpout2.netcologne.de (Postfix) with ESMTP id 8BF3B128ED; Tue, 4 Aug 2020 21:02:00 +0200 (CEST) Received: from localhost (localhost [127.0.0.1]) by cc-smtpin3.netcologne.de (Postfix) with ESMTP id 831A511EC2; Tue, 4 Aug 2020 21:02:00 +0200 (CEST) Received: from [2001:4dd6:c7b:0:5705:4afe:c770:8bfd] (helo=cc-smtpin3.netcologne.de) by localhost with ESMTP (eXpurgate 4.11.6) (envelope-from ) id 5f29b0a8-639b-7f0000012729-7f000001b406-1 for ; Tue, 04 Aug 2020 21:02:00 +0200 Received: from linux-p51k.fritz.box (2001-4dd6-c7b-0-5705-4afe-c770-8bfd.ipv6dyn.netcologne.de [IPv6:2001:4dd6:c7b:0:5705:4afe:c770:8bfd]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by cc-smtpin3.netcologne.de (Postfix) with ESMTPSA; Tue, 4 Aug 2020 21:01:59 +0200 (CEST) To: "fortran@gcc.gnu.org" , gcc-patches Subject: [patch, fortran] Compile-time check for change in DO variable in contained procedures Message-ID: <8cb915f9-f02d-81c5-71b2-8dddddadbe1e@netcologne.de> Date: Tue, 4 Aug 2020 21:01:58 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.10.0 MIME-Version: 1.0 Content-Language: de-DE X-Spam-Status: No, score=-9.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_DNSWL_LOW, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Thomas Koenig via Gcc-patches From: Thomas Koenig Reply-To: Thomas Koenig Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" Hello world, the attached patch issues an error for something that I am sure most people did at least once (I know I did), something like do i=1,10 call foo end do ... contains subroutine foo do i=1,5 ... end do which is, of course, illegal, but the programmer's fault. We issue an error with -fcheck=all, but a compile-time is better, of course. As you can see from the modification of do_check_4.f90, you have to go to some lengths to fool the compiler with this patch. As an aside, I could really have used three places for the error message here. As is, I settled for the place of the call from the DO loop checked, and the place where it is modified. With the name of the variable, the user should be able to figure out what's wrong. Regression-tested. OK for trunk? Best regards Thomas Static analysis for definition of DO index variables in contained procedures. When encountering a procedure call in a DO loop, this patch checks if the call is to a contained procedure, and if it is, check for changes in the index variable. gcc/fortran/ChangeLog: PR fortran/96469 * frontend-passes.c (doloop_contained_function_call): New function. (doloop_contained_procedure_code): New function. (CHECK_INQ): Macro for inquire checks. (doloop_code): Invoke doloop_contained_procedure_code and doloop_contained_function_call if appropriate. (do_intent): Likewise. gcc/testsuite/ChangeLog: PR fortran/96469 * gfortran.dg/do_check_4.f90: Hide change in index variable from compile-time analysis. * gfortran.dg/do_check_4.f90: New test. diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index cdeed8943b0..13390e33188 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -2305,6 +2305,208 @@ optimize_minmaxloc (gfc_expr **e) mpz_set_ui (a->expr->value.integer, 1); } +typedef struct contained_info +{ + gfc_symbol *do_var; + gfc_symbol *procedure; + locus where_do; +} contained_info; + + +/* Callback function that goes through the code in a contained + procedure to make sure it does not change a variable in a DO + loop. */ + +static enum gfc_exec_op last_io_op; + +static int +doloop_contained_function_call (gfc_expr **e, + int *walk_subtrees ATTRIBUTE_UNUSED, void *data) +{ + gfc_expr *expr = *e; + gfc_formal_arglist *f; + gfc_actual_arglist *a; + gfc_symbol *sym, *do_var; + contained_info *info; + + if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym) + return 0; + + sym = expr->value.function.esym; + f = gfc_sym_get_dummy_args (sym); + if (f == NULL) + return 0; + + info = (contained_info *) data; + do_var = info->do_var; + a = expr->value.function.actual; + + while (a && f) + { + if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var) + { + if (f->sym->attr.intent == INTENT_OUT) + { + gfc_error_now ("Index variable %qs set to undefined as " + "INTENT(OUT) argument at %L in procedure %qs " + "called from within DO loop at %L", do_var->name, + &a->expr->where, info->procedure->name, + &info->where_do); + return 1; + } + else if (f->sym->attr.intent == INTENT_INOUT) + { + gfc_error_now ("Index variable %qs not definable as " + "INTENT(INOUT) argument at %L in procedure %qs " + "called from within DO loop at %L", do_var->name, + &a->expr->where, info->procedure->name, + &info->where_do); + return 1; + } + } + a = a->next; + f = f->next; + } + return 0; +} + +static int +doloop_contained_procedure_code (gfc_code **c, + int *walk_subtrees ATTRIBUTE_UNUSED, + void *data) +{ + gfc_code *co = *c; + contained_info *info = (contained_info *) data; + gfc_symbol *do_var = info->do_var; + const char *errmsg = _("Index variable %qs redefined at %L in procedure %qs " + "called from within DO loop at %L"); + static enum gfc_exec_op saved_io_op; + + switch (co->op) + { + case EXEC_ASSIGN: + if (co->expr1->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->loc, info->procedure->name, + &info->where_do); + break; + + case EXEC_DO: + if (co->ext.iterator && co->ext.iterator->var + && co->ext.iterator->var->symtree->n.sym == do_var) + gfc_error (errmsg, do_var->name, &co->loc, info->procedure->name, + &info->where_do); + break; + + case EXEC_READ: + case EXEC_WRITE: + case EXEC_INQUIRE: + saved_io_op = last_io_op; + last_io_op = co->op; + break; + + case EXEC_OPEN: + if (co->ext.open->iostat + && co->ext.open->iostat->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->ext.open->iostat->where, + info->procedure->name, &info->where_do); + break; + + case EXEC_CLOSE: + if (co->ext.close->iostat + && co->ext.close->iostat->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->ext.close->iostat->where, + info->procedure->name, &info->where_do); + break; + + case EXEC_TRANSFER: + switch (last_io_op) + { + + case EXEC_INQUIRE: +#define CHECK_INQ(a) do { if (co->ext.inquire->a && \ + co->ext.inquire->a->symtree->n.sym == do_var) \ + gfc_error_now (errmsg, do_var->name, \ + &co->ext.inquire->a->where, \ + info->procedure->name, \ + &info->where_do); \ + } while (0) + + CHECK_INQ(iostat); + CHECK_INQ(number); + CHECK_INQ(position); + CHECK_INQ(recl); + CHECK_INQ(position); + CHECK_INQ(iolength); + CHECK_INQ(strm_pos); + break; +#undef CHECK_INQ + + case EXEC_READ: + if (co->expr1 && co->expr1->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->expr1->where, + info->procedure->name, &info->where_do); + + /* Fallthrough. */ + + case EXEC_WRITE: + if (co->ext.dt->iostat + && co->ext.dt->iostat->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->ext.dt->iostat->where, + info->procedure->name, &info->where_do); + break; + + default: + gcc_unreachable (); + } + break; + + case EXEC_DT_END: + last_io_op = saved_io_op; + break; + + case EXEC_CALL: + gfc_formal_arglist *f; + gfc_actual_arglist *a; + + f = gfc_sym_get_dummy_args (co->resolved_sym); + if (f == NULL) + break; + a = co->ext.actual; + /* Slightly different error message here. If there is an error, + return 1 to avoid an infinite loop. */ + while (a && f) + { + if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var) + { + if (f->sym->attr.intent == INTENT_OUT) + { + gfc_error_now ("Index variable %qs set to undefined as " + "INTENT(OUT) argument at %L in subroutine %qs " + "called from within DO loop at %L", + do_var->name, &a->expr->where, + info->procedure->name, &info->where_do); + return 1; + } + else if (f->sym->attr.intent == INTENT_INOUT) + { + gfc_error_now ("Index variable %qs not definable as " + "INTENT(INOUT) argument at %L in subroutine %qs " + "called from within DO loop at %L", do_var->name, + &a->expr->where, info->procedure->name, + &info->where_do); + return 1; + } + } + a = a->next; + f = f->next; + } + break; + default: + break; + } + return 0; +} + /* Callback function for code checking that we do not pass a DO variable to an INTENT(OUT) or INTENT(INOUT) dummy variable. */ @@ -2389,10 +2591,32 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, break; case EXEC_CALL: - if (co->resolved_sym == NULL) break; + /* Test if somebody stealthily changes the DO variable from + under us by changing it in a host-associated procedure. */ + if (co->resolved_sym->attr.contained) + { + FOR_EACH_VEC_ELT (doloop_list, i, lp) + { + gfc_symbol *sym = co->resolved_sym; + contained_info info; + gfc_namespace *ns; + + cl = lp->c; + info.do_var = cl->ext.iterator->var->symtree->n.sym; + info.procedure = co->resolved_sym; /* sym? */ + info.where_do = co->loc; + /* Look contained procedures under the namespace of the + variable. */ + for (ns = info.do_var->ns->contained; ns; ns = ns->sibling) + if (ns->proc_name && ns->proc_name == sym) + gfc_code_walker (&ns->code, doloop_contained_procedure_code, + doloop_contained_function_call, &info); + } + } + f = gfc_sym_get_dummy_args (co->resolved_sym); /* Withot a formal arglist, there is only unknown INTENT, @@ -2436,6 +2660,7 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, a = a->next; f = f->next; } + break; default: @@ -2737,6 +2962,7 @@ do_intent (gfc_expr **e) gfc_code *dl; do_t *lp; int i; + gfc_symbol *sym; expr = *e; if (expr->expr_type != EXPR_FUNCTION) @@ -2747,7 +2973,31 @@ do_intent (gfc_expr **e) if (expr->value.function.isym) return 0; - f = gfc_sym_get_dummy_args (expr->symtree->n.sym); + sym = expr->value.function.esym; + if (sym == NULL) + return 0; + + if (sym->attr.contained) + { + FOR_EACH_VEC_ELT (doloop_list, i, lp) + { + contained_info info; + gfc_namespace *ns; + + dl = lp->c; + info.do_var = dl->ext.iterator->var->symtree->n.sym; + info.procedure = sym; + info.where_do = expr->where; + /* Look contained procedures under the namespace of the + variable. */ + for (ns = info.do_var->ns->contained; ns; ns = ns->sibling) + if (ns->proc_name && ns->proc_name == sym) + gfc_code_walker (&ns->code, doloop_contained_procedure_code, + dummy_expr_callback, &info); + } + } + + f = gfc_sym_get_dummy_args (sym); /* Without a formal arglist, there is only unknown INTENT, which we don't check for. */ diff --git a/gcc/testsuite/gfortran.dg/do_check_4.f90 b/gcc/testsuite/gfortran.dg/do_check_4.f90 index 65bc92c7e1a..5b087e4dde3 100644 --- a/gcc/testsuite/gfortran.dg/do_check_4.f90 +++ b/gcc/testsuite/gfortran.dg/do_check_4.f90 @@ -5,17 +5,23 @@ ! PR fortran/34656 ! Run-time check for modifing loop variables ! + +module x + integer :: i +contains + SUBROUTINE do_something() + IMPLICIT NONE + DO i=1,10 + ENDDO + END SUBROUTINE do_something +end module x + PROGRAM test + use x IMPLICIT NONE - INTEGER :: i DO i=1,100 - CALL do_something() + CALL do_something() ENDDO -CONTAINS - SUBROUTINE do_something() - IMPLICIT NONE - DO i=1,10 - ENDDO - END SUBROUTINE do_something -END PROGRAM test +end PROGRAM test + ! { dg-output "Fortran runtime error: Loop variable has been modified" }