From patchwork Sun Nov 3 18:36:59 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 1188603 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=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-512279-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=fail (p=none dis=none) header.from=gmail.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="Gtnos+Xq"; dkim=fail reason="signature verification failed" (2048-bit key; unprotected) header.d=gmail.com header.i=@gmail.com header.b="ucpm4fB3"; 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 475l5w4MlDz9sP6 for ; Mon, 4 Nov 2019 05:37:22 +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 :mime-version:from:date:message-id:subject:to:cc:content-type; q=dns; s=default; b=w/ptdQyoUf1Zn2oYzhQU4zjNWMNgkriVfgxEB4Z4G89 uyTk9Al5jfv5DpFkkOdOADpqba0jfaG6I8DDk9MAj+G9purU9R/3Khcm2LTWTSQb 25pQKzY7OvK1/ik8/QO7EDoH8x4XT/gveSZIgUBG3DVVYQiKt9oxEnvDfG9676go = 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 :mime-version:from:date:message-id:subject:to:cc:content-type; s=default; bh=XgnvzZ8BxtjZscun56lbEPqfd8A=; b=Gtnos+XqCwZ46kPec Fu4r/VqNGiDERzvA9vRzDbkciYDVwhZUoJ3O5Dj9iyED3dHnDr0+8RhJ+vihQDsK U0rn8UU75r9AubZB1v4AVB/L+Yk89mBbnPaYtwziItJL81v+WECl6mxVK0P5r6ZC YE8qsicXd21jXZXJWYS9VHF9Wo= Received: (qmail 90034 invoked by alias); 3 Nov 2019 18:37:15 -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 90018 invoked by uid 89); 3 Nov 2019 18:37:15 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-4.0 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, GIT_PATCH_2, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.1 spammy=EXIT_FAILURE, exit_failure, match_no, MATCH_NO X-HELO: mail-lf1-f43.google.com Received: from mail-lf1-f43.google.com (HELO mail-lf1-f43.google.com) (209.85.167.43) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Sun, 03 Nov 2019 18:37:13 +0000 Received: by mail-lf1-f43.google.com with SMTP id f5so10594301lfp.1; Sun, 03 Nov 2019 10:37:12 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=mime-version:from:date:message-id:subject:to:cc; bh=bZMjR5BJ1FE02PRVcci1cfiyV4SAoFJVsLTpbg6+k8Y=; b=ucpm4fB3ZyUtCL2F/4ROK0WdifLKZgQDdguTVxDc3g4h8WkC1LbX57IBwvAlmln4lO bX+LpoNNWtkujPiIlwkQote87VqgsKi3lbEHfaw+9XaGNI6CTFqj8qKqkh7RFv3EqHXx 1HzxAkHIiRhjHlRK4+L1FYuTPKOICuyC7UzjfDw0LyAVqpL74tGDpJGfz/V1jRQkviIM Sn7NPSGTIS3wduzliUVrYdi0PzvT/CjvDyjwShvi+GByiiF3BfLTXpO3ipAMDtowPMFu 7k+TXsidxuL70zOSUPOZusf7iWu1EPbCl2y2jZBe4nPqAAkamUwZ/ciuVMEGdPjaD8ye 1hDQ== MIME-Version: 1.0 From: Paul Richard Thomas Date: Sun, 3 Nov 2019 18:36:59 +0000 Message-ID: Subject: [patch, fortran] PR92123 - [F2018/array-descriptor] Scalar allocatable/pointer with array descriptor (via bind(C)): ICE with select rank or error scalar variable with POINTER or ALLOCATABLE in procedure with BIND(C) is not yet supported To: "fortran@gcc.gnu.org" , gcc-patches Cc: Tobias Burnus , Vipul Parekh The attached patch is verging on the obvious. Thanks to Tobias for spotting Vipul's messages on the J3 list. Regtests on FC30/x86_64 - OK for trunk and 9-branch? Paul 2019-11-03 Paul Thomas PR fortran/92123 *decl.c (gfc_verify_c_interop_param): Remove error asserting that pointer or allocatable variables in a bind C procedure are not supported. Delete some trailing spaces. * trans-stmt.c (trans_associate_var): Correct the attempt to treat scalar pointer or allocatable temporaries as if they are array descriptors. 2019-11-03 Paul Thomas PR fortran/92123 * gfortran.dg/bind_c_procs_3.f90 : New test. * gfortran.dg/ISO_Fortran_binding_15.c : New test. * gfortran.dg/ISO_Fortran_binding_15.f90 : Additional source. Index: gcc/fortran/decl.c =================================================================== *** gcc/fortran/decl.c (revision 277531) --- gcc/fortran/decl.c (working copy) *************** gfc_verify_c_interop_param (gfc_symbol * *** 1560,1574 **** sym->ns->proc_name->name)) retval = false; - if ((sym->attr.allocatable || sym->attr.pointer) && !sym->as) - { - gfc_error ("Scalar variable %qs at %L with POINTER or " - "ALLOCATABLE in procedure %qs with BIND(C) is not yet" - " supported", sym->name, &(sym->declared_at), - sym->ns->proc_name->name); - retval = false; - } - if (sym->attr.optional == 1 && sym->attr.value) { gfc_error ("Variable %qs at %L cannot have both the OPTIONAL " --- 1560,1565 ---- *************** gfc_match_entry (void) *** 7547,7553 **** entry->attr.is_bind_c = 0; loc = entry->old_symbol != NULL ! ? entry->old_symbol->declared_at : gfc_current_locus; gfc_error_now ("BIND(C) attribute at %L can only be used for " "variables or common blocks", &loc); } --- 7538,7544 ---- entry->attr.is_bind_c = 0; loc = entry->old_symbol != NULL ! ? entry->old_symbol->declared_at : gfc_current_locus; gfc_error_now ("BIND(C) attribute at %L can only be used for " "variables or common blocks", &loc); } *************** gfc_match_derived_decl (void) *** 10288,10294 **** } /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX. ! But, we need to simply return for TYPE(. */ if (m == MATCH_NO && gfc_current_form == FORM_FREE) { char c = gfc_peek_ascii_char (); --- 10279,10285 ---- } /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX. ! But, we need to simply return for TYPE(. */ if (m == MATCH_NO && gfc_current_form == FORM_FREE) { char c = gfc_peek_ascii_char (); Index: gcc/fortran/trans-stmt.c =================================================================== *** gcc/fortran/trans-stmt.c (revision 277531) --- gcc/fortran/trans-stmt.c (working copy) *************** trans_associate_var (gfc_symbol *sym, gf *** 1841,1850 **** if (rank > 0) copy_descriptor (&se.post, se.expr, desc, rank); else ! { ! tmp = gfc_conv_descriptor_data_get (desc); ! gfc_conv_descriptor_data_set (&se.post, se.expr, tmp); ! } /* The dynamic type could have changed too. */ if (sym->ts.type == BT_CLASS) --- 1841,1847 ---- if (rank > 0) copy_descriptor (&se.post, se.expr, desc, rank); else ! gfc_conv_descriptor_data_set (&se.post, se.expr, desc); /* The dynamic type could have changed too. */ if (sym->ts.type == BT_CLASS) Index: gcc/testsuite/gfortran.dg/bind_c_procs_3.f90 =================================================================== *** gcc/testsuite/gfortran.dg/bind_c_procs_3.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/bind_c_procs_3.f90 (working copy) *************** *** 0 **** --- 1,25 ---- + ! { dg-do run } + ! + ! Test the fix for PR92123, in which 'dat' caused an error with the message + ! "Scalar variable 'dat' at ?? with POINTER or ALLOCATABLE in procedure Fsub + ! with BIND(C) is not yet supported." + ! + ! Contributed by Vipul Parekh + ! + module m + use, intrinsic :: iso_c_binding, only : c_int + contains + subroutine Fsub( dat ) bind(C, name="Fsub") + !.. Argument list + integer(c_int), allocatable, intent(out) :: dat + dat = 42 + return + end subroutine + end module m + + use, intrinsic :: iso_c_binding, only : c_int + use m, only : Fsub + integer(c_int), allocatable :: x + call Fsub( x ) + if (x .ne. 42) stop 1 + end Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.c =================================================================== *** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.c (nonexistent) --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.c (working copy) *************** *** 0 **** --- 1,41 ---- + /* Test the fix for PR92123. */ + + /* Contributed by Vipul Parekh */ + + #include + #include + #include "../../../libgfortran/ISO_Fortran_binding.h" + + // Prototype for Fortran functions + extern void Fsub(CFI_cdesc_t *); + + int main() + { + CFI_CDESC_T(0) dat; + int irc = 0; + + irc = CFI_establish((CFI_cdesc_t *)&dat, NULL, + CFI_attribute_allocatable, + CFI_type_int, 0, (CFI_rank_t)0, NULL); + if (irc != CFI_SUCCESS) + { + printf("CFI_establish failed: irc = %d.\n", irc); + return EXIT_FAILURE; + } + + Fsub((CFI_cdesc_t *)&dat); + if (*(int *)dat.base_addr != 42) + { + printf("Fsub returned = %d.\n", *(int *)dat.base_addr); + return EXIT_FAILURE; + } + + irc = CFI_deallocate((CFI_cdesc_t *)&dat); + if (irc != CFI_SUCCESS) + { + printf("CFI_deallocate for dat failed: irc = %d.\n", irc); + return EXIT_FAILURE; + } + + return EXIT_SUCCESS; + } Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.f90 =================================================================== *** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.f90 (working copy) *************** *** 0 **** --- 1,20 ---- + ! { dg-do run { target c99_runtime } } + ! { dg-additional-sources ISO_Fortran_binding_15.c } + ! + ! Test the fix for PR921233. The additional source is the main program. + ! + ! Contributed by Vipul Parekh + ! + module m + use, intrinsic :: iso_c_binding, only : c_int + contains + subroutine Fsub( dat ) bind(C, name="Fsub") + integer(c_int), allocatable, intent(out) :: dat(..) + select rank (dat) + rank (0) + allocate( dat ) + dat = 42 + end select + return + end subroutine + end module m