From patchwork Thu Oct 10 23:07:26 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Steve Kargl X-Patchwork-Id: 1174825 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-510709-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=troutmask.apl.washington.edu Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="aek2KIdP"; 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 46q6Dn2vRpz9sN1 for ; Fri, 11 Oct 2019 10:07:37 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:reply-to:mime-version:content-type; q=dns; s=default; b=xaWCVlalMir7nbGSKa2/r+AVGU5d2SBWpDcDCuVN/mx Uzfcx+Wi76X7CLT2/yNiPz2z8mJFwnqW2/7IS+ZgRmLs6nreHqfbfZFL1/uUaisO zCuWTs3D7CUZTG+f5c9YV8dujg8vAx9oNEottDcAtbzXjyzSOGSK1p5HoW/gbyZU = 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:date :from:to:subject:message-id:reply-to:mime-version:content-type; s=default; bh=0y1nGG153Dl6ijROZ9zupTlk3y4=; b=aek2KIdP7OLIRljh+ 090JrVvWcsWgub03beje2BAOoHDKZ9ADPgP50XuEfpOvIVR9fYxznj6bfcYwOPlR q5AWEJIjH4MUhAfcziwBpV6QdoBwDjEOP33Gj0ZCvRrNUPBBG2RMNSiibF5YZqAY b5mfkrpsqhn6dQIXQcKKRMh43I= Received: (qmail 45846 invoked by alias); 10 Oct 2019 23:07:30 -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 45830 invoked by uid 89); 10 Oct 2019 23:07:30 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-8.3 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS autolearn=ham version=3.3.1 spammy= X-HELO: troutmask.apl.washington.edu Received: from troutmask.apl.washington.edu (HELO troutmask.apl.washington.edu) (128.95.76.21) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 10 Oct 2019 23:07:28 +0000 Received: from troutmask.apl.washington.edu (localhost [127.0.0.1]) by troutmask.apl.washington.edu (8.15.2/8.15.2) with ESMTPS id x9AN7QGp023983 (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384 bits=256 verify=NO); Thu, 10 Oct 2019 16:07:27 -0700 (PDT) (envelope-from sgk@troutmask.apl.washington.edu) Received: (from sgk@localhost) by troutmask.apl.washington.edu (8.15.2/8.15.2/Submit) id x9AN7QvA023982; Thu, 10 Oct 2019 16:07:26 -0700 (PDT) (envelope-from sgk) Date: Thu, 10 Oct 2019 16:07:26 -0700 From: Steve Kargl To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [PATCH] PR fortran/91649 -- Add additional checking for FINDLOC Message-ID: <20191010230726.GA23968@troutmask.apl.washington.edu> Reply-To: sgk@troutmask.apl.washington.edu MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.12.1 (2019-06-15) The attached patch has been tested on x86_64-*-freebsd. OK to commit? The patch adds additional check for the ARRAY and VALUE arguments. First, ARRAY and VALUE need to be type conformant, but gfortran did not check for the CHARACTER type nor for numeric types. Second, ARRAY must be an intrinsic type, which implies that VALUE must also be an intrinsic type. 2019-10-10 Steven G. Kargl PR fortran/91649 check.c (gfc_check_findloc): Additional checking for valid arguments 2019-10-10 Steven G. Kargl PR fortran/91649 * gfortran.dg/pr91649.f90 Index: gcc/fortran/check.c =================================================================== --- gcc/fortran/check.c (revision 276837) +++ gcc/fortran/check.c (working copy) @@ -3879,26 +3921,27 @@ bool gfc_check_findloc (gfc_actual_arglist *ap) { gfc_expr *a, *v, *m, *d, *k, *b; + bool a1, v1; a = ap->expr; if (!intrinsic_type_check (a, 0) || !array_check (a, 0)) return false; v = ap->next->expr; - if (!scalar_check (v,1)) + if (!intrinsic_type_check (v, 1) || !scalar_check (v,1)) return false; - /* Check if the type is compatible. */ + /* Check if the type are both logical. */ + a1 = a->ts.type == BT_LOGICAL; + v1 = v->ts.type == BT_LOGICAL; + if ((a1 && !v1) || (!a1 && v1)) + goto incompat; - if ((a->ts.type == BT_LOGICAL && v->ts.type != BT_LOGICAL) - || (a->ts.type != BT_LOGICAL && v->ts.type == BT_LOGICAL)) - { - gfc_error ("Argument %qs of %qs intrinsic at %L must be in type " - "conformance to argument %qs at %L", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &a->where, - gfc_current_intrinsic_arg[1]->name, &v->where); - } + /* Check if the type are both character. */ + a1 = a->ts.type == BT_CHARACTER; + v1 = v->ts.type == BT_CHARACTER; + if ((a1 && !v1) || (!a1 && v1)) + goto incompat; d = ap->next->next->expr; m = ap->next->next->next->expr; @@ -3946,6 +3989,14 @@ gfc_check_findloc (gfc_actual_arglist *ap) return false; return true; + +incompat: + gfc_error ("Argument %qs of %qs intrinsic at %L must be in type " + "conformance to argument %qs at %L", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &a->where, + gfc_current_intrinsic_arg[1]->name, &v->where); + return false; } Index: gcc/testsuite/gfortran.dg/pr91649.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr91649.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr91649.f90 (working copy) @@ -0,0 +1,23 @@ +! { dg-do compile } +! PR fortran/91649 +! Code originally contributed by Gerhard Steinmetz +subroutine p + logical :: back = .true. + integer :: x(1) = findloc([1, 2, 1], '1', back=back) ! { dg-error "must be in type conformance" } + print *, x +end + +subroutine q + type t + end type + logical :: back = .false. + integer :: x(1) = findloc([1, 2, 1], t(), back=back) ! { dg-error "must be of intrinsic type" } + print *, x +end + +subroutine s + character(4) :: c = '1234' + integer :: x(1) = findloc([1, 2, 1], c, back=.true.) ! { dg-error "must be in type conformance" } + print *, x +end +