From patchwork Thu Aug 20 22:49:05 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa?= X-Patchwork-Id: 1348643 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=vWTDkf1g; 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 4BXfwF48TZz9sPf for ; Fri, 21 Aug 2020 08:49:16 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id AB5DD386EC3F; Thu, 20 Aug 2020 22:49:11 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org AB5DD386EC3F DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1597963751; bh=3n5uO9vEn22E/c5YvJmBW4xwVaT1SadAfT00evD1CSI=; h=To:Subject:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=vWTDkf1gDt+cqXnUHzEABFkXMoQncpVsFhX6yjujMkuDv0FqUHBCKyleJrfGwnbzD mW15bwRRsinxNc8urN3FEmpDQwmNCKQ2xof/Y+mU12U5NZrfIIyc3MTtDQLW/4ieXU ozfsiTcmrXOuPJf7dky29i8Va8Biv7QkdZiYUeJY= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42d.google.com (mail-wr1-x42d.google.com [IPv6:2a00:1450:4864:20::42d]) by sourceware.org (Postfix) with ESMTPS id A22C03857C4D; Thu, 20 Aug 2020 22:49:08 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org A22C03857C4D Received: by mail-wr1-x42d.google.com with SMTP id p20so219799wrf.0; Thu, 20 Aug 2020 15:49:08 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:to:from:subject:message-id:date:user-agent :mime-version:content-language; bh=3n5uO9vEn22E/c5YvJmBW4xwVaT1SadAfT00evD1CSI=; b=hUKI5Dx0VYYf/rfH8Zx6+DzAUE+FTxeiPxfZKlzDHzK5AMpBP/HmWKPf+tPTox3ikJ 1E3vdUf9HNwEKueASvwhCxn2LxyYg4kXffMSdaWPCn2Il/4tc9m2//zWfC8G1XWp7KtT zRWr8VwbxitMChiE9laFYV9dVLKkiPkitWxFmSSx2r0nv9L45GGquAoDyfvG4th9CR+h HPSc25OVckVso9ZgV/Bmb49Pq42qff1TalRyxL9FPQPS/F0JE41f0FjmFE04KRGvygRc 6hT5rfOyGkVYFwNQG0SoTmFXrJSeB4U6LDORf3EerLo44HDtmE+VIfc6EgHZiKbI2YJZ vdaw== X-Gm-Message-State: AOAM532aHP0/0T0PM5ku1DmU6N2c3d8jNtODwnk2kKFjsbECIo+zLxjl 79evGcUaGa33ax8Y96Yt4ktFR25jcHg= X-Google-Smtp-Source: ABdhPJxc2o4CBsMI8BO4sa65cj5wCqM9XsMQ1gRkUwkONqoM2dLL1VoZ+EN//VtPaGkhw4HmwKvr0w== X-Received: by 2002:adf:ff8a:: with SMTP id j10mr704400wrr.323.1597963747305; Thu, 20 Aug 2020 15:49:07 -0700 (PDT) Received: from ?IPv6:2001:8a0:7d62:e100:4cef:4d87:afd4:5cc9? ([2001:8a0:7d62:e100:4cef:4d87:afd4:5cc9]) by smtp.googlemail.com with ESMTPSA id q3sm275130wmq.12.2020.08.20.15.49.05 (version=TLS1_3 cipher=TLS_AES_128_GCM_SHA256 bits=128/128); Thu, 20 Aug 2020 15:49:06 -0700 (PDT) To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [Patch, fortran] PR fortran/94110 - Passing an assumed-size to an assumed-shape argument should be rejected Message-ID: <53fca461-da65-2681-46b3-cf8461f032db@gmail.com> Date: Thu, 20 Aug 2020 22:49:05 +0000 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.10.0 MIME-Version: 1.0 Content-Language: en-US X-Spam-Status: No, score=-10.9 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, 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: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa_via_Gcc-patches?= From: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa?= Reply-To: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa?= Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" Hi all! Proposed patch to PR94110 - Passing an assumed-size to an assumed-shape argument should be rejected. Patch tested only on x86_64-pc-linux-gnu. Add code to also check for deferred-shape and assumed-rank pointer (allocatable arguments are checked elsewhere) dummy arguments being passed an assumed-size array formal argument when raising an error. Thank you very much. Best regards, José Rui 2020-8-20 José Rui Faustino de Sousa PR fortran/94110 * interface.c (gfc_compare_actual_formal): Add code to also raise the actual argument cannot be an assumed-size array error when the dummy arguments are deferred-shape or assumed-rank pointer. 2020-8-20 José Rui Faustino de Sousa PR fortran/94110 * PR94110.f90: New test. diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 7985fc7..020cdd7 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -3303,7 +3303,10 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, return false; } - if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE + if (f->sym->as + && (f->sym->as->type == AS_ASSUMED_SHAPE + || f->sym->as->type == AS_DEFERRED + || (f->sym->as->type == AS_ASSUMED_RANK && f->sym->attr.pointer)) && a->expr->expr_type == EXPR_VARIABLE && a->expr->symtree->n.sym->as && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE diff --git a/gcc/testsuite/gfortran.dg/PR94110.f90 b/gcc/testsuite/gfortran.dg/PR94110.f90 new file mode 100644 index 0000000..9ec70ec --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR94110.f90 @@ -0,0 +1,88 @@ +! { dg-do compile } +! +! Test the fix for PR94110 +! + +program asa_p + + implicit none + + integer, parameter :: n = 7 + + integer :: p(n) + integer :: s + + p = 1 + s = sumf_as(p) + if (s/=n) stop 1 + s = sumf_ar(p) + if (s/=n) stop 2 + stop + +contains + + function sumf_as(a) result(s) + integer, target, intent(in) :: a(*) + + integer :: s + + s = sum_as(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" } + s = sum_p_ds(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" } + s = sum_p_ar(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" } + return + end function sumf_as + + function sumf_ar(a) result(s) + integer, target, intent(in) :: a(..) + + integer :: s + + select rank(a) + rank(*) + s = sum_as(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" } + s = sum_p_ds(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" } + s = sum_p_ar(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" } + rank default + stop 3 + end select + return + end function sumf_ar + + function sum_as(a) result(s) + integer, intent(in) :: a(:) + + integer :: s + + s = sum(a) + return + end function sum_as + + function sum_p_ds(a) result(s) + integer, pointer, intent(in) :: a(:) + + integer :: s + + s = -1 + if(associated(a))& + s = sum(a) + return + end function sum_p_ds + + function sum_p_ar(a) result(s) + integer, pointer, intent(in) :: a(..) + + integer :: s + + s = -1 + select rank(a) + rank(1) + if(associated(a))& + s = sum(a) + rank default + stop 4 + end select + return + end function sum_p_ar + +end program asa_p +