From patchwork Thu Aug 1 21:11:39 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Steve Kargl X-Patchwork-Id: 1140777 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-506032-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="yNCOb9pC"; 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 4602zT6JG2z9sDB for ; Fri, 2 Aug 2019 07:11:49 +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:date :from:to:subject:message-id:reply-to:mime-version:content-type; q=dns; s=default; b=G1XFx6u6MnK0meFlv0QMqe0V+CA/2tPlTy+rxIhX6If MVHWd1svXsOwClrg7umJ8lHHMo/xY4Mjie4Ew8YsCcF84D7J8DaG6DZQ9OwKGOvn EFkg+ysaWU9O2pOqv045TPtf67ZIgJCBpedAV4QU0JX4ZwFCdgJAtln3vlXTR2WU = 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=oo61C9n9CqrtDgd2R9bRNZNc0tQ=; b=yNCOb9pCzY1NBqj7S ETbcVrI5Bd2Y+hRAt/D61EKx6m5ZdBobtfMyNcQ8917V96OK2bwSG9jLBV9s0lPa jVSA4E/tuEu0P96uqCETVgTLaFE/3fiWQbVdFAjqRHqdRndd7TuHVFeSlYwXyDL6 ZH1iRqWfquA97dUTRFmgwChW54= Received: (qmail 24764 invoked by alias); 1 Aug 2019 21:11:42 -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 24538 invoked by uid 89); 1 Aug 2019 21:11:42 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-8.1 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS autolearn=ham version=3.3.1 spammy=273950, fortunately, correspondence, x86_64-*-freebsd 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, 01 Aug 2019 21:11:41 +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 x71LBdoB094173 (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384 bits=256 verify=NO); Thu, 1 Aug 2019 14:11:39 -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 x71LBdZb094172; Thu, 1 Aug 2019 14:11:39 -0700 (PDT) (envelope-from sgk) Date: Thu, 1 Aug 2019 14:11:39 -0700 From: Steve Kargl To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [PATCH] PR fortran/42546 -- ALLOCATED has 2 mutually exclusive keywords Message-ID: <20190801211139.GA88674@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 fixed the issues raised in the PR fortran/42546. Namely, ALLOCATED has two possible keywords: ALLOCATE(ARRAY=...) or ALLOCATED(SCALAR=...) In Tobias' original patch (attached to the PR), he tried to make both ARRAY and SCALAR options, then in gfc_check_allocated() appropriate checking was added. I started down that road, but intrinsic.c( sort_actual) got in the way. Fortunately, the checking for ARRAY or SCALAR can be special-cased in sort_actual. See the patch. Regression tested on x86_64-*-freebsd. OK to commit? 2019-08-01 Steven G. Kargl PR fortran/42546 * check.c(gfc_check_allocated): Add comment pointing to ... * intrinsic.c(sort_actual): ... the checking done here. 2019-08-01 Steven G. Kargl PR fortran/42546 * gfortran.dg/allocated_1.f90: New test. * gfortran.dg/allocated_2.f90: Ditto. Index: gcc/fortran/check.c =================================================================== --- gcc/fortran/check.c (revision 273950) +++ gcc/fortran/check.c (working copy) @@ -1168,6 +1168,10 @@ gfc_check_all_any (gfc_expr *mask, gfc_expr *dim) } +/* Limited checking for ALLOCATED intrinsic. Additional checking + is performed in intrinsic.c(sort_actual), because ALLOCATED + has two mutually exclusive non-optional arguments. */ + bool gfc_check_allocated (gfc_expr *array) { Index: gcc/fortran/intrinsic.c =================================================================== --- gcc/fortran/intrinsic.c (revision 273950) +++ gcc/fortran/intrinsic.c (working copy) @@ -4180,6 +4180,40 @@ sort_actual (const char *name, gfc_actual_arglist **ap if (f == NULL && a == NULL) /* No arguments */ return true; + /* ALLOCATED has two mutually exclusive keywords, but only one + can be present at time and neither is optional. */ + if (strcmp (name, "allocated") == 0 && a->name) + { + if (strcmp (a->name, "scalar") == 0) + { + if (a->next) + goto whoops; + if (a->expr->rank != 0) + { + gfc_error ("Scalar entity required at %L", &a->expr->where); + return false; + } + return true; + } + else if (strcmp (a->name, "array") == 0) + { + if (a->next) + goto whoops; + if (a->expr->rank == 0) + { + gfc_error ("Array entity required at %L", &a->expr->where); + return false; + } + return true; + } + else + { + gfc_error ("Invalid keyword %qs in %qs intrinsic function at %L", + a->name, name, @a->expr->where); + return false; + } + } + for (;;) { /* Put the nonkeyword arguments in a 1:1 correspondence */ if (f == NULL) @@ -4199,6 +4233,7 @@ sort_actual (const char *name, gfc_actual_arglist **ap if (a == NULL) goto do_sort; +whoops: gfc_error ("Too many arguments in call to %qs at %L", name, where); return false; Index: gcc/testsuite/gfortran.dg/allocated_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/allocated_1.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/allocated_1.f90 (working copy) @@ -0,0 +1,24 @@ +! { dg-do run } +program foo + + implicit none + + integer, allocatable :: x + integer, allocatable :: a(:) + + logical a1, a2 + + a1 = allocated(scalar=x) + if (a1 .neqv. .false.) stop 1 + a2 = allocated(array=a) + if (a2 .neqv. .false.) stop 2 + + allocate(x) + allocate(a(2)) + + a1 = allocated(scalar=x) + if (a1 .neqv. .true.) stop 3 + a2 = allocated(array=a) + if (a2 .neqv. .true.) stop 4 + +end program foo Index: gcc/testsuite/gfortran.dg/allocated_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/allocated_2.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/allocated_2.f90 (working copy) @@ -0,0 +1,16 @@ +! { dg-do compile } +program foo + + implicit none + + integer, allocatable :: x + integer, allocatable :: a(:) + + logical a1, a2 + + a1 = allocated(scalar=a) ! { dg-error "Scalar entity required" } + a2 = allocated(array=x) ! { dg-error "Array entity required" } + a1 = allocated(scalar=x, array=a) ! { dg-error "Too many arguments" } + a1 = allocated(array=a, scalar=x) ! { dg-error "Too many arguments" } + +end program foo