From patchwork Mon Sep 3 15:13:04 2018 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Jerry DeLisle X-Patchwork-Id: 965499 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-485031-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=charter.net Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="wf8It6DU"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 423tl33qdpz9s3x for ; Tue, 4 Sep 2018 01:13:17 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to:cc :from:subject:message-id:date:mime-version:content-type; q=dns; s=default; b=JZgkrhlg2zSgKLPyVP3zpInElQcOckZVMZuEvtVvbImkq3XL3G XEJaJhTNEsJJCsO7AtYzcqAdsOAgrZU3l3hBL7cdyEY1pL9v6eW56A7hS+0NqfZa TxqnOv0C/bEQ8Pwkf1vKDp+SjBHe9yMBV8XSpXxiaFj/g2oLFEVbIdnb0= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to:cc :from:subject:message-id:date:mime-version:content-type; s= default; bh=sdIjhpHlTsIxqDS6Kjjo3lrc7X4=; b=wf8It6DUOlzb6OX+4PtH tshw03NkrMauHLFCyCA8GPVXeZUsHiAy7fwDPaVbf0J0IEOOedH8EtbIwC8lFDyI zsY4wzhFlDVqP58XNsxASaB28iEkddklkRpfB4CWi5xn65LRbqPdBBeDH2bY+g2p hLTetkwov+i+MZEhcUT+e5M= Received: (qmail 105148 invoked by alias); 3 Sep 2018 15:13:10 -0000 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 Received: (qmail 105129 invoked by uid 89); 3 Sep 2018 15:13:09 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-24.5 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_NUMSUBJECT, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=Bad X-HELO: mtaout005-public.msg.strl.va.charter.net Received: from mtaout005-public.msg.strl.va.charter.net (HELO mtaout005-public.msg.strl.va.charter.net) (68.114.190.30) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Mon, 03 Sep 2018 15:13:07 +0000 Received: from impout003 ([68.114.189.18]) by mtaout005.msg.strl.va.charter.net (InterMail vM.9.00.023.01 201-2473-194) with ESMTP id <20180903151306.ZFJY7356.mtaout005.msg.strl.va.charter.net@impout003>; Mon, 3 Sep 2018 10:13:06 -0500 Received: from [192.168.1.6] ([96.41.213.35]) by impout003 with charter.net id X3D51y0020mPCJg013D5rG; Mon, 03 Sep 2018 10:13:06 -0500 X-Auth-id: anZkZWxpc2xlQGNoYXJ0ZXIubmV0 To: "fortran@gcc.gnu.org" Cc: GCC Patches , Mark Eggleston From: Jerry DeLisle Subject: [patch, fortran] Fix for modulo checking similar to PR86045 Message-ID: <47c956bf-1cc3-b4d9-83ec-d9ae41626c32@charter.net> Date: Mon, 3 Sep 2018 08:13:04 -0700 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:52.0) Gecko/20100101 Thunderbird/52.9.1 MIME-Version: 1.0 Hi all, Similar to Steve's fix of 'mod' checking for 86045, the attached patch fixes an ICE in 'modulo' when P = 0. Mark pointed this out and greatly assisted with the patch. I have regression tested and plan to commit to trunk, 8, and 7 so that we are in sync with the 'mod' patch. If no objections, later today I will commit with the test case. Regards, Jerry 2018-09-03 Jerry DeLisle * simplify.c (gfc_simplify_modulo): Re-arrange code to test whether 'P' is zero and issue an error if it is. diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 41997367cf9..d35bbbaaa1b 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -5525,54 +5525,57 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) gfc_expr *result; int kind; - if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) + /* First check p. */ + if (p->expr_type != EXPR_CONSTANT) return NULL; - kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; - result = gfc_get_constant_expr (a->ts.type, kind, &a->where); - - switch (a->ts.type) + /* p shall not be 0. */ + switch (p->ts.type) { case BT_INTEGER: if (mpz_cmp_ui (p->value.integer, 0) == 0) { - /* Result is processor-dependent. This processor just opts - to not handle it at all. */ - gfc_error ("Second argument of MODULO at %L is zero", &a->where); - gfc_free_expr (result); + gfc_error ("Argument %qs of MODULO at %L shall not be zero", + "P", &p->where); return &gfc_bad_expr; } - mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); - break; - case BT_REAL: if (mpfr_cmp_ui (p->value.real, 0) == 0) { - /* Result is processor-dependent. */ - gfc_error ("Second argument of MODULO at %L is zero", &p->where); - gfc_free_expr (result); + gfc_error ("Argument %qs of MODULO at %L shall not be zero", + "P", &p->where); return &gfc_bad_expr; } - - gfc_set_model_kind (kind); - mpfr_fmod (result->value.real, a->value.real, p->value.real, - GFC_RND_MODE); - if (mpfr_cmp_ui (result->value.real, 0) != 0) - { - if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real)) - mpfr_add (result->value.real, result->value.real, p->value.real, - GFC_RND_MODE); - } - else - mpfr_copysign (result->value.real, result->value.real, - p->value.real, GFC_RND_MODE); break; - default: gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); } + if (a->expr_type != EXPR_CONSTANT) + return NULL; + + kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; + result = gfc_get_constant_expr (a->ts.type, kind, &a->where); + + if (a->ts.type == BT_INTEGER) + mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); + else + { + gfc_set_model_kind (kind); + mpfr_fmod (result->value.real, a->value.real, p->value.real, + GFC_RND_MODE); + if (mpfr_cmp_ui (result->value.real, 0) != 0) + { + if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real)) + mpfr_add (result->value.real, result->value.real, p->value.real, + GFC_RND_MODE); + } + else + mpfr_copysign (result->value.real, result->value.real, + p->value.real, GFC_RND_MODE); + } + return range_check (result, "MODULO"); } diff --git a/gcc/testsuite/gfortran.dg/modulo_check.f90 b/gcc/testsuite/gfortran.dg/modulo_check.f90 new file mode 100644 index 00000000000..8819a2f8e4e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/modulo_check.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! Test checks on modulo with p == 0 +program p + logical :: a(2) = (modulo([2,3],0) == 0) ! { dg-error "shall not be zero" } + integer :: b = count(modulo([2,3],0) == 0) ! { dg-error "shall not be zero" } + integer :: c = all(modulo([2,3],0) == 0) ! { dg-error "shall not be zero" } + integer :: d = any(modulo([2,3],0) == 0) ! { dg-error "shall not be zero" } +end program