From patchwork Tue Apr 9 10:18:11 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: 1082101 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-499003-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="knH56BsY"; dkim=fail reason="signature verification failed" (2048-bit key; unprotected) header.d=gmail.com header.i=@gmail.com header.b="PhbwvsRg"; 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 44djtf3C7vz9sRd for ; Tue, 9 Apr 2019 20:18:43 +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 :mime-version:from:date:message-id:subject:to:cc:content-type; q=dns; s=default; b=JfbX8mOpetAh3PIiPmQSh1hzI1Ss/Lc2tJ4mpXaHVpt pVYze/CXC4vfgLq7tQyb9jQeJyMoUt53isYdwey75nmQfYdxuvVvsRJyWECMEtMs Ruh0MXlzvE5RQ6KeIEeNuOYj+WkYzXWfRb9wx6yFjdRfk4KxoCFaydxXNsKk4c2k = 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=VuncLgxfZUFWR30xB/NXdUhAwMI=; b=knH56BsYxJtqaQY+/ yM52cjURQKAao7fGhplY9EFb0nYpj8vqqsRwL/g/Mlgygt2ygig+ixQjfOiRnZ40 q4Qy6wzcwg+TQ0ol4oACMKSVjPyDI8Ikm/mv7lzbuF8b39fHtvvOFhmYQA+0t/3/ WDnTRSjxVPMD2nVa8wYyqBJ6Pc= Received: (qmail 80392 invoked by alias); 9 Apr 2019 10:18: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 79805 invoked by uid 89); 9 Apr 2019 10:18:30 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-3.7 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=D*jp, flexible, Play, 2* X-HELO: mail-lj1-f181.google.com Received: from mail-lj1-f181.google.com (HELO mail-lj1-f181.google.com) (209.85.208.181) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Tue, 09 Apr 2019 10:18:25 +0000 Received: by mail-lj1-f181.google.com with SMTP id l7so13930586ljg.6; Tue, 09 Apr 2019 03:18:25 -0700 (PDT) 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=PSc+R9Ed4oe0GCe21oCWrVUg57Lzx1plkVZD4fXajZc=; b=PhbwvsRg4/XTMXd0+z64YoWOvvEgq+3DA+Y4v3uiAdDNLu55CCliqBjym8q1K8OzS+ MqmEq/l30sselh8lx0qGhrf/yyGro64VcxRSn203vym8cbNGJc8jkdLfUF0FHYKFihkf bofSXaYQ4so5/AaMmsqL9e8Q2m6eunJ0n8IM8vxF0QQzLGXvwLnQmd7pvvnaOl9/NBkt 0bdEDhR4oIoL/kOk+oW2aDZTRo4u9wD4BoIOc+VLvPvxq5TpyAgZW4sQM5FO/f5RP9Fx 7m6WA6RYQ9wDDfBzfqu3dnUkgp+AciZQeMIjbaAZvdkqsK3xHfi2hAML1MA8mlC6GG9x edpA== MIME-Version: 1.0 From: Paul Richard Thomas Date: Tue, 9 Apr 2019 11:18:11 +0100 Message-ID: Subject: [Patch, fortran] PRs 89843 and 90022 - C Fortran Interop fixes. To: "fortran@gcc.gnu.org" , gcc-patches Cc: "Bader, Reinhold" , Gilles Gouaillardet The most part of this patch is concerned with implementing calls from C of of fortran bind c procedures with assumed shape or assumed rank dummies to completely fix PR89843. The conversion of the descriptors from CFI to gfc occur on entry to and reversed on exit from the procedure. This patch is safe for trunk, even at this late stage, because its effects are barricaded behind the tests for CFI descriptors. I believe that it appropriately rewards the bug reporters to have this feature work as well as possible at release. Between comments and the ChangeLogs, this patch is self explanatory. Bootstrapped and regtested on FC29/x86_64 - OK for trunk? Paul 2019-04-09 Paul Thomas PR fortran/89843 * trans-decl.c (gfc_get_symbol_decl): Assumed shape and assumed rank dummies of bind C procs require deferred initialization. (convert_CFI_desc): New procedure to convert incoming CFI descriptors to gfc types and back again. (gfc_trans_deferred_vars): Call it. * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Null the CFI descriptor pointer. Free the descriptor in all cases. PR fortran/90022 * trans-decl.c (gfc_get_symbol_decl): Make sure that the se expression is a pointer type before converting it to the symbol backend_decl type. 2019-04-09 Paul Thomas PR fortran/89843 * gfortran.dg/ISO_Fortran_binding_4.f90: Modify the value of x in ctg. Test the conversion of the descriptor types in the main program. * gfortran.dg/ISO_Fortran_binding_10.f90: New test. * gfortran.dg/ISO_Fortran_binding_10.c: Called by it. PR fortran/90022 * gfortran.dg/ISO_Fortran_binding_1.c: Correct the indexing for the computation of 'ans'. Also, change the expected results for CFI_is_contiguous to comply with standard. * gfortran.dg/ISO_Fortran_binding_1.f90: Correct the expected results for CFI_is_contiguous to comply with standard. * gfortran.dg/ISO_Fortran_binding_9.f90: New test. * gfortran.dg/ISO_Fortran_binding_9.c: Called by it. 2019-04-09 Paul Thomas PR fortran/89843 * runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Only return immediately if the source pointer is null. Bring forward the extraction of the gfc type. Extract the kind so that the element size can be correctly computed for sections and components of derived type arrays. Remove the free of the CFI descriptor since this is now done in trans-expr.c. (gfc_desc_to_cfi_desc): Only allocate the CFI descriptor if it is not null. (CFI_section): Normalise the difference between the upper and lower bounds by the stride to correctly calculate the extents of the section. PR fortran/90022 * runtime/ISO_Fortran_binding.c (CFI_is_contiguous) : Return 1 for true and 0 otherwise to comply with the standard. Correct the contiguity check for rank 3 and greater by using the stride measure of the lower dimension rather than the element length. Index: gcc/fortran/trans-decl.c =================================================================== *** gcc/fortran/trans-decl.c (revision 270149) --- gcc/fortran/trans-decl.c (working copy) *************** gfc_get_symbol_decl (gfc_symbol * sym) *** 1494,1499 **** --- 1494,1506 ---- && sym->attr.dummy) gfc_defer_symbol_init (sym); + if (sym->attr.dummy + && sym->ns->proc_name->attr.is_bind_c + && sym->attr.dimension + && (sym->as->type == AS_ASSUMED_SHAPE + || sym->as->type == AS_ASSUMED_RANK)) + gfc_defer_symbol_init (sym); + /* All deferred character length procedures need to retain the backend decl, which is a pointer to the character length in the caller's namespace and to declare a local character length. */ *************** gfc_null_and_pass_deferred_len (gfc_symb *** 4268,4273 **** --- 4275,4353 ---- } + /* Convert CFI descriptor dummies into gfc types and back again. */ + static void + convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym) + { + tree gfc_desc; + tree gfc_desc_ptr; + tree CFI_desc; + tree CFI_desc_ptr; + tree dummy_ptr; + tree tmp; + tree incoming; + tree outgoing; + stmtblock_t tmpblock; + + /* dummy_ptr will be the pointer to the passed array descriptor, + while CFI_desc is the descriptor itself. */ + dummy_ptr = sym->backend_decl; + CFI_desc = sym->backend_decl; + if (POINTER_TYPE_P (TREE_TYPE (CFI_desc))) + CFI_desc = build_fold_indirect_ref_loc (input_location, CFI_desc); + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (CFI_desc))) + { + if (DECL_LANG_SPECIFIC (sym->backend_decl)) + CFI_desc = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl); + else + CFI_desc = NULL; + dummy_ptr = CFI_desc; + } + + if (CFI_desc) + { + if (POINTER_TYPE_P (TREE_TYPE (CFI_desc))) + CFI_desc = build_fold_indirect_ref_loc (input_location, CFI_desc); + + /* The compiler will have given CFI_desc the correct gfortran + type. Use this new variable to store the converted + descriptor. */ + gfc_desc = gfc_create_var (TREE_TYPE (CFI_desc), "gfc_desc"); + tmp = build_pointer_type (TREE_TYPE (gfc_desc)); + gfc_desc_ptr = gfc_create_var (tmp, "gfc_desc_ptr"); + CFI_desc_ptr = gfc_create_var (pvoid_type_node, "CFI_desc_ptr"); + + gfc_init_block (&tmpblock); + /* Pointer to the gfc descriptor. */ + gfc_add_modify (&tmpblock, gfc_desc_ptr, + gfc_build_addr_expr (NULL, gfc_desc)); + /* Store the pointer to the CFI descriptor. */ + gfc_add_modify (&tmpblock, CFI_desc_ptr, + fold_convert (pvoid_type_node, dummy_ptr)); + tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr); + /* Convert the CFI descriptor. */ + incoming = build_call_expr_loc (input_location, + gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp); + gfc_add_expr_to_block (&tmpblock, incoming); + /* Set the dummy pointer to point to the gfc_descriptor. */ + gfc_add_modify (&tmpblock, dummy_ptr, + fold_convert (TREE_TYPE (dummy_ptr), gfc_desc_ptr)); + incoming = gfc_finish_block (&tmpblock); + + gfc_init_block (&tmpblock); + /* Convert the gfc descriptor back to the CFI type before going + out of scope. */ + tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr); + outgoing = build_call_expr_loc (input_location, + gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr); + gfc_add_expr_to_block (&tmpblock, outgoing); + outgoing = gfc_finish_block (&tmpblock); + + /* Add the lot to the procedure init and finally blocks. */ + gfc_add_init_cleanup (block, incoming, outgoing); + } + } + /* Get the result expression for a procedure. */ static tree *************** gfc_trans_deferred_vars (gfc_symbol * pr *** 4844,4849 **** --- 4924,4940 ---- } else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type) gcc_unreachable (); + + /* Assumed shape and assumed rank arrays are passed to BIND(C) procedures + as ISO Fortran Interop descriptors. These have to be converted to + gfortran descriptors and back again. This has to be done here so that + the conversion occurs at the start of the init block. */ + if (sym->attr.dummy + && sym->ns->proc_name->attr.is_bind_c + && sym->attr.dimension + && (sym->as->type == AS_ASSUMED_SHAPE + || sym->as->type == AS_ASSUMED_RANK)) + convert_CFI_desc (block, sym); } gfc_init_block (&tmpblock); Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (revision 270149) --- gcc/fortran/trans-expr.c (working copy) *************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p *** 4990,4997 **** --- 4990,4999 ---- tree ptr = NULL_TREE; tree size; tree type; + tree cond; int attribute; symbol_attribute attr = gfc_expr_attr (e); + stmtblock_t block; /* If this is a full array or a scalar, the allocatable and pointer attributes can be passed. Otherwise it is 'CFI_attribute_other'*/ *************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p *** 5135,5140 **** --- 5137,5144 ---- /* Variables to point to the gfc and CFI descriptors. */ gfc_desc_ptr = parmse->expr; cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi"); + gfc_add_modify (&parmse->pre, cfi_desc_ptr, + build_int_cst (pvoid_type_node, 0)); /* Allocate the CFI descriptor and fill the fields. */ tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr); *************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p *** 5147,5154 **** if (ptr) { ! /* Free both the temporary data and the CFI descriptor for ! INTENT(IN) arrays. */ tmp = gfc_call_free (ptr); gfc_prepend_expr_to_block (&parmse->post, tmp); tmp = gfc_call_free (cfi_desc_ptr); --- 5151,5157 ---- if (ptr) { ! /* Free the temporary data for INTENT(IN) arrays. */ tmp = gfc_call_free (ptr); gfc_prepend_expr_to_block (&parmse->post, tmp); tmp = gfc_call_free (cfi_desc_ptr); *************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p *** 5156,5162 **** return; } ! /* Transfer values back to gfc descriptor and free the CFI descriptor. */ tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr); tmp = build_call_expr_loc (input_location, gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp); --- 5159,5177 ---- return; } ! /* Free the CFI descriptor. */ ! gfc_init_block (&block); ! cond = fold_build2_loc (input_location, NE_EXPR, ! logical_type_node, cfi_desc_ptr, ! build_int_cst (TREE_TYPE (cfi_desc_ptr), 0)); ! tmp = gfc_call_free (cfi_desc_ptr); ! gfc_add_expr_to_block (&block, tmp); ! tmp = build3_v (COND_EXPR, cond, ! gfc_finish_block (&block), ! build_empty_stmt (input_location)); ! gfc_prepend_expr_to_block (&parmse->post, tmp); ! ! /* Transfer values back to gfc descriptor. */ tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr); tmp = build_call_expr_loc (input_location, gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp); Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c =================================================================== *** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c (revision 270149) --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c (working copy) *************** float section_c(int *std_case, CFI_cdesc *** 105,111 **** CFI_index_t idx[CFI_MAX_RANK], lower[CFI_MAX_RANK], strides[CFI_MAX_RANK], upper[CFI_MAX_RANK]; CFI_CDESC_T(1) section; ! int ind, size; float *ret_addr; float ans = 0.0; --- 105,111 ---- CFI_index_t idx[CFI_MAX_RANK], lower[CFI_MAX_RANK], strides[CFI_MAX_RANK], upper[CFI_MAX_RANK]; CFI_CDESC_T(1) section; ! int ind; float *ret_addr; float ans = 0.0; *************** float section_c(int *std_case, CFI_cdesc *** 121,129 **** if (ind) return -2.0; /* Sum over the section */ ! size = (section.dim[0].extent - 1) ! * section.elem_len/section.dim[0].sm + 1; ! for (idx[0] = 0; idx[0] < size; idx[0]++) ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx); return ans; } --- 121,127 ---- if (ind) return -2.0; /* Sum over the section */ ! for (idx[0] = 0; idx[0] < section.dim[0].extent; idx[0]++) ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx); return ans; } *************** float section_c(int *std_case, CFI_cdesc *** 143,151 **** if (ind) return -2.0; /* Sum over the section */ ! size = (section.dim[0].extent - 1) ! * section.elem_len/section.dim[0].sm + 1; ! for (idx[0] = 0; idx[0] < size; idx[0]++) ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx); return ans; } --- 141,147 ---- if (ind) return -2.0; /* Sum over the section */ ! for (idx[0] = 0; idx[0] < section.dim[0].extent; idx[0]++) ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx); return ans; } *************** int setpointer_c(CFI_cdesc_t * ptr, int *** 191,205 **** int assumed_size_c(CFI_cdesc_t * desc) { ! int ierr; ! ierr = CFI_is_contiguous(desc); ! if (ierr) return 1; if (desc->rank) ! ierr = 2 * (desc->dim[desc->rank-1].extent != (CFI_index_t)(long long)(-1)); else ! ierr = 3; ! return ierr; } --- 187,201 ---- int assumed_size_c(CFI_cdesc_t * desc) { ! int res; ! res = CFI_is_contiguous(desc); ! if (!res) return 1; if (desc->rank) ! res = 2 * (desc->dim[desc->rank-1].extent != (CFI_index_t)(long long)(-1)); else ! res = 3; ! return res; } Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 (revision 270149) --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 (working copy) *************** end subroutine test_CFI_address *** 170,185 **** integer, dimension (2,*) :: arg character(4), dimension(2) :: chr ! These are contiguous ! if (c_contiguous (arg) .ne. 0) stop 20 if (.not.allocated (x)) allocate (x(2, 2)) ! if (c_contiguous (x) .ne. 0) stop 22 deallocate (x) ! if (c_contiguous (chr) .ne. 0) stop 23 ! These are not contiguous ! if (c_contiguous (der%i) .eq. 0) stop 24 ! if (c_contiguous (arg(1:1,1:2)) .eq. 0) stop 25 ! if (c_contiguous (d(4:2:-2, 1:3:2)) .eq. 0) stop 26 ! if (c_contiguous (chr(:)(2:3)) .eq. 0) stop 27 end subroutine test_CFI_contiguous subroutine test_CFI_section (arg) --- 170,185 ---- integer, dimension (2,*) :: arg character(4), dimension(2) :: chr ! These are contiguous ! if (c_contiguous (arg) .ne. 1) stop 20 if (.not.allocated (x)) allocate (x(2, 2)) ! if (c_contiguous (x) .ne. 1) stop 22 deallocate (x) ! if (c_contiguous (chr) .ne. 1) stop 23 ! These are not contiguous ! if (c_contiguous (der%i) .eq. 1) stop 24 ! if (c_contiguous (arg(1:1,1:2)) .eq. 1) stop 25 ! if (c_contiguous (d(4:2:-2, 1:3:2)) .eq. 1) stop 26 ! if (c_contiguous (chr(:)(2:3)) .eq. 1) stop 27 end subroutine test_CFI_contiguous subroutine test_CFI_section (arg) Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c =================================================================== *** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c (nonexistent) --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c (working copy) *************** *** 0 **** --- 1,73 ---- + /* Test the fix of PR89843. */ + + /* Contributed by Reinhold Bader */ + + #include "../../../libgfortran/ISO_Fortran_binding.h" + #include + #include + #include + + void sa(CFI_cdesc_t *, int, int *); + + void si(CFI_cdesc_t *this, int flag, int *status) + { + int value, sum; + bool err; + CFI_CDESC_T(1) that; + CFI_index_t lb[] = { 0, 0 }; + CFI_index_t ub[] = { 4, 1 }; + CFI_index_t st[] = { 2, 0 }; + int chksum[] = { 9, 36, 38 }; + + if (flag == 1) + { + lb[0] = 0; lb[1] = 2; + ub[0] = 2; ub[1] = 2; + st[0] = 1; st[1] = 0; + } + else if (flag == 2) + { + lb[0] = 1; lb[1] = 0; + ub[0] = 1; ub[1] = 3; + st[0] = 0; st[1] = 1; + } + + CFI_establish((CFI_cdesc_t *) &that, NULL, CFI_attribute_other, + CFI_type_float, 0, 1, NULL); + + *status = CFI_section((CFI_cdesc_t *) &that, this, lb, ub, st); + + if (*status != CFI_SUCCESS) + { + printf("FAIL C: status is %i\n",status); + return; + } + + value = CFI_is_contiguous((CFI_cdesc_t *) &that); + err = ((flag == 0 && value != 0) + || (flag == 1 && value != 1) + || (flag == 2 && value != 0)); + + if (err) + { + printf("FAIL C: contiguity for flag value %i - is %i\n",flag, value); + *status = 10; + return; + } + + sum = 0; + for (int i = 0; i < that.dim[0].extent; i++) + { + CFI_index_t idx[] = {i}; + sum += (int)(*(float *)CFI_address ((CFI_cdesc_t *)&that, idx)); + } + + if (sum != chksum[flag]) + { + printf ("FAIL C: check sum = %d(%d)\n", sum, chksum[flag]); + *status = 11; + return; + } + + sa((CFI_cdesc_t *) &that, flag, status); + } Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.f90 =================================================================== *** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.f90 (working copy) *************** *** 0 **** --- 1,99 ---- + ! { dg-do run { target c99_runtime } } + ! { dg-additional-sources ISO_Fortran_binding_10.c } + ! + ! Test the fix of PR89843. + ! + ! Contributed by Reinhold Bader + ! + module mod_section_01 + use, intrinsic :: iso_c_binding + implicit none + interface + subroutine si(this, flag, status) bind(c) + import :: c_float, c_int + real(c_float) :: this(:,:) + integer(c_int), value :: flag + integer(c_int) :: status + end subroutine si + end interface + contains + subroutine sa(this, flag, status) bind(c) + real(c_float) :: this(:) + integer(c_int), value :: flag + integer(c_int) :: status + + status = 0 + + select case (flag) + case (0) + if (is_contiguous(this)) then + write(*,*) 'FAIL 1:' + status = status + 1 + end if + if (size(this,1) /= 3) then + write(*,*) 'FAIL 2:',size(this) + status = status + 1 + goto 10 + end if + if (maxval(abs(this - [ 1.0, 3.0, 5.0 ])) > 1.0e-6) then + write(*,*) 'FAIL 3:',this + status = status + 1 + end if + 10 continue + case (1) + if (size(this,1) /= 3) then + write(*,*) 'FAIL 4:',size(this) + status = status + 1 + goto 20 + end if + if (maxval(abs(this - [ 11.0, 12.0, 13.0 ])) > 1.0e-6) then + write(*,*) 'FAIL 5:',this + status = status + 1 + end if + 20 continue + case (2) + if (size(this,1) /= 4) then + write(*,*) 'FAIL 6:',size(this) + status = status + 1 + goto 30 + end if + if (maxval(abs(this - [ 2.0, 7.0, 12.0, 17.0 ])) > 1.0e-6) then + write(*,*) 'FAIL 7:',this + status = status + 1 + end if + 30 continue + end select + + ! if (status == 0) then + ! write(*,*) 'OK' + ! end if + end subroutine sa + end module mod_section_01 + + program section_01 + use mod_section_01 + implicit none + real(c_float) :: v(5,4) + integer :: i + integer :: status + + v = reshape( [ (real(i), i = 1, 20) ], [ 5, 4 ] ) + call si(v, 0, status) + if (status .ne. 0) stop 1 + + call sa(v(1:5:2, 1), 0, status) + if (status .ne. 0) stop 2 + + call si(v, 1, status) + if (status .ne. 0) stop 3 + + call sa(v(1:3, 3), 1, status) + if (status .ne. 0) stop 4 + + call si(v, 2, status) + if (status .ne. 0) stop 5 + + call sa(v(2,1:4), 2, status) + if (status .ne. 0) stop 6 + + end program section_01 Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 =================================================================== *** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 (revision 270149) --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 (working copy) *************** contains *** 10,18 **** --- 10,20 ---- if (any(abs(x - [2.,4.,6.]) > 1.e-6)) then write(*,*) 'FAIL' + stop 1 else write(*,*) 'OK' end if + x = [2.,4.,6.]*10.0 end subroutine end module program p *************** program p *** 23,27 **** x = [ (real(i), i=1, size(x)) ] call ctg(x(2::2)) ! end program --- 25,29 ---- x = [ (real(i), i=1, size(x)) ] call ctg(x(2::2)) ! if (any (abs (x - [1.,20.,3.,40.,5.,60.]) > 1.e-6)) stop 2 end program Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.c =================================================================== *** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.c (nonexistent) --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.c (working copy) *************** *** 0 **** --- 1,14 ---- + /* Test fix of a problem with CFI_is_contiguous. */ + + /* Contributed by Gilles Gouaillardet */ + + #include "../../../libgfortran/ISO_Fortran_binding.h" + #include + + int cdesc_c(CFI_cdesc_t* x, long *expected) + { + int res; + res = CFI_is_contiguous (x); + if (x->base_addr != (void *)*expected) res = 0; + return res; + } \ No newline at end of file Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.f90 =================================================================== *** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.f90 (working copy) *************** *** 0 **** --- 1,28 ---- + ! { dg-do run { target c99_runtime } } + ! { dg-additional-sources ISO_Fortran_binding_9.c } + ! + ! Fix a problem with CFI_is_contiguous + ! + ! Contributed by Gilles Gouaillardet + ! + module cdesc + interface + function cdesc_f08(buf, expected) result (res) BIND(C, name="cdesc_c") + USE, INTRINSIC :: ISO_C_BINDING + implicit none + INTEGER(C_INT) :: res + type(*), dimension(..), INTENT(INOUT) :: buf + integer(kind=8),INTENT(IN) :: expected + end function cdesc_f08 + end interface + end module + + program cdesc_test + use cdesc + implicit none + integer :: a0, a1(10), a2(10,10), a3(10,10,10) + if (cdesc_f08(a0, LOC(a0)) .ne. 1) stop 1 + if (cdesc_f08(a1, LOC(a1(1))) .ne. 1) stop 2 + if (cdesc_f08(a2, LOC(a2(1,1))) .ne. 1) stop 3 + if (cdesc_f08(a3, LOC(a3(1,1,1))) .ne. 1) stop 4 + end program Index: libgfortran/runtime/ISO_Fortran_binding.c =================================================================== *** libgfortran/runtime/ISO_Fortran_binding.c (revision 270149) --- libgfortran/runtime/ISO_Fortran_binding.c (working copy) *************** void *** 37,59 **** cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr) { int n; CFI_cdesc_t *s = *s_ptr; ! /* If not a full pointer or allocatable array free the descriptor ! and return. */ ! if (!s || s->attribute == CFI_attribute_other) ! goto finish; GFC_DESCRIPTOR_DATA (d) = s->base_addr; - - if (!s->rank || s->dim[0].sm == (CFI_index_t)s->elem_len) - GFC_DESCRIPTOR_SIZE (d) = s->elem_len; - else - GFC_DESCRIPTOR_SIZE (d) = (index_type)s->dim[0].sm; - - d->dtype.version = s->version; - GFC_DESCRIPTOR_RANK (d) = (signed char)s->rank; GFC_DESCRIPTOR_TYPE (d) = (signed char)(s->type & CFI_type_mask); /* Correct the unfortunate difference in order with types. */ if (GFC_DESCRIPTOR_TYPE (d) == BT_CHARACTER) --- 37,51 ---- cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr) { int n; + index_type kind; CFI_cdesc_t *s = *s_ptr; ! if (!s) ! return; GFC_DESCRIPTOR_DATA (d) = s->base_addr; GFC_DESCRIPTOR_TYPE (d) = (signed char)(s->type & CFI_type_mask); + kind = (index_type)((s->type - (s->type & CFI_type_mask)) >> CFI_type_kind_shift); /* Correct the unfortunate difference in order with types. */ if (GFC_DESCRIPTOR_TYPE (d) == BT_CHARACTER) *************** cfi_desc_to_gfc_desc (gfc_array_void *d, *** 61,72 **** else if (GFC_DESCRIPTOR_TYPE (d) == BT_DERIVED) GFC_DESCRIPTOR_TYPE (d) = BT_CHARACTER; d->dtype.attribute = (signed short)s->attribute; if (s->rank) d->span = (index_type)s->dim[0].sm; - /* On the other hand, CFI_establish can change the bounds. */ d->offset = 0; for (n = 0; n < GFC_DESCRIPTOR_RANK (d); n++) { --- 53,73 ---- else if (GFC_DESCRIPTOR_TYPE (d) == BT_DERIVED) GFC_DESCRIPTOR_TYPE (d) = BT_CHARACTER; + if (!s->rank || s->dim[0].sm == (CFI_index_t)s->elem_len) + GFC_DESCRIPTOR_SIZE (d) = s->elem_len; + else if (GFC_DESCRIPTOR_TYPE (d) != BT_DERIVED) + GFC_DESCRIPTOR_SIZE (d) = kind; + else + GFC_DESCRIPTOR_SIZE (d) = s->elem_len; + + d->dtype.version = s->version; + GFC_DESCRIPTOR_RANK (d) = (signed char)s->rank; + d->dtype.attribute = (signed short)s->attribute; if (s->rank) d->span = (index_type)s->dim[0].sm; d->offset = 0; for (n = 0; n < GFC_DESCRIPTOR_RANK (d); n++) { *************** cfi_desc_to_gfc_desc (gfc_array_void *d, *** 76,86 **** GFC_DESCRIPTOR_STRIDE(d, n) = (index_type)(s->dim[n].sm / s->elem_len); d->offset -= GFC_DESCRIPTOR_STRIDE(d, n) * GFC_DESCRIPTOR_LBOUND(d, n); } - - finish: - if (s) - free (s); - s = NULL; } extern void gfc_desc_to_cfi_desc (CFI_cdesc_t **, const gfc_array_void *); --- 77,82 ---- *************** gfc_desc_to_cfi_desc (CFI_cdesc_t **d_pt *** 95,102 **** /* Play it safe with allocation of the flexible array member 'dim' by setting the length to CFI_MAX_RANK. This should not be necessary but valgrind complains accesses after the allocated block. */ ! d = malloc (sizeof (CFI_cdesc_t) + (CFI_type_t)(CFI_MAX_RANK * sizeof (CFI_dim_t))); d->base_addr = GFC_DESCRIPTOR_DATA (s); d->elem_len = GFC_DESCRIPTOR_SIZE (s); --- 91,101 ---- /* Play it safe with allocation of the flexible array member 'dim' by setting the length to CFI_MAX_RANK. This should not be necessary but valgrind complains accesses after the allocated block. */ ! if (*d_ptr == NULL) ! d = malloc (sizeof (CFI_cdesc_t) + (CFI_type_t)(CFI_MAX_RANK * sizeof (CFI_dim_t))); + else + d = *d_ptr; d->base_addr = GFC_DESCRIPTOR_DATA (s); d->elem_len = GFC_DESCRIPTOR_SIZE (s); *************** gfc_desc_to_cfi_desc (CFI_cdesc_t **d_pt *** 115,121 **** d->type = (CFI_type_t)(d->type + ((CFI_type_t)d->elem_len << CFI_type_kind_shift)); ! /* Full pointer or allocatable arrays have zero lower_bound. */ for (n = 0; n < GFC_DESCRIPTOR_RANK (s); n++) { if (d->attribute != CFI_attribute_other) --- 114,120 ---- d->type = (CFI_type_t)(d->type + ((CFI_type_t)d->elem_len << CFI_type_kind_shift)); ! /* Full pointer or allocatable arrays retain their lower_bounds. */ for (n = 0; n < GFC_DESCRIPTOR_RANK (s); n++) { if (d->attribute != CFI_attribute_other) *************** gfc_desc_to_cfi_desc (CFI_cdesc_t **d_pt *** 134,140 **** d->dim[n].sm = (CFI_index_t)(GFC_DESCRIPTOR_STRIDE(s, n) * s->span); } ! *d_ptr = d; } void *CFI_address (const CFI_cdesc_t *dv, const CFI_index_t subscripts[]) --- 133,140 ---- d->dim[n].sm = (CFI_index_t)(GFC_DESCRIPTOR_STRIDE(s, n) * s->span); } ! if (*d_ptr == NULL) ! *d_ptr = d; } void *CFI_address (const CFI_cdesc_t *dv, const CFI_index_t subscripts[]) *************** int CFI_is_contiguous (const CFI_cdesc_t *** 416,422 **** if (dv == NULL) { fprintf (stderr, "CFI_is_contiguous: C descriptor is NULL.\n"); ! return CFI_INVALID_DESCRIPTOR; } /* Base address must not be NULL. */ --- 416,422 ---- if (dv == NULL) { fprintf (stderr, "CFI_is_contiguous: C descriptor is NULL.\n"); ! return 0; } /* Base address must not be NULL. */ *************** int CFI_is_contiguous (const CFI_cdesc_t *** 424,430 **** { fprintf (stderr, "CFI_is_contiguous: Base address of C Descriptor " "is already NULL.\n"); ! return CFI_ERROR_BASE_ADDR_NULL; } /* Must be an array. */ --- 424,430 ---- { fprintf (stderr, "CFI_is_contiguous: Base address of C Descriptor " "is already NULL.\n"); ! return 0; } /* Must be an array. */ *************** int CFI_is_contiguous (const CFI_cdesc_t *** 432,444 **** { fprintf (stderr, "CFI_is_contiguous: C Descriptor must describe an " "array (0 < dv->rank = %d).\n", dv->rank); ! return CFI_INVALID_RANK; } } /* Assumed size arrays are always contiguous. */ if (dv->rank > 0 && dv->dim[dv->rank - 1].extent == -1) ! return CFI_SUCCESS; /* If an array is not contiguous the memory stride is different to the element * length. */ --- 432,444 ---- { fprintf (stderr, "CFI_is_contiguous: C Descriptor must describe an " "array (0 < dv->rank = %d).\n", dv->rank); ! return 0; } } /* Assumed size arrays are always contiguous. */ if (dv->rank > 0 && dv->dim[dv->rank - 1].extent == -1) ! return 1; /* If an array is not contiguous the memory stride is different to the element * length. */ *************** int CFI_is_contiguous (const CFI_cdesc_t *** 447,461 **** if (i == 0 && dv->dim[i].sm == (CFI_index_t)dv->elem_len) continue; else if (i > 0 ! && dv->dim[i].sm == (CFI_index_t)(dv->elem_len * dv->dim[i - 1].extent)) continue; ! return CFI_FAILURE; } /* Array sections are guaranteed to be contiguous by the previous test. */ ! return CFI_SUCCESS; } --- 447,461 ---- if (i == 0 && dv->dim[i].sm == (CFI_index_t)dv->elem_len) continue; else if (i > 0 ! && dv->dim[i].sm == (CFI_index_t)(dv->dim[i - 1].sm * dv->dim[i - 1].extent)) continue; ! return 0; } /* Array sections are guaranteed to be contiguous by the previous test. */ ! return 1; } *************** int CFI_section (CFI_cdesc_t *result, co *** 670,676 **** } int idx = i - aux; result->dim[idx].lower_bound = lower[i]; ! result->dim[idx].extent = upper[i] - lower[i] + 1; result->dim[idx].sm = stride[i] * source->dim[i].sm; /* Adjust 'lower' for the base address offset. */ lower[idx] = lower[idx] - source->dim[i].lower_bound; --- 670,676 ---- } int idx = i - aux; result->dim[idx].lower_bound = lower[i]; ! result->dim[idx].extent = 1 + (upper[i] - lower[i])/stride[i]; result->dim[idx].sm = stride[i] * source->dim[i].sm; /* Adjust 'lower' for the base address offset. */ lower[idx] = lower[idx] - source->dim[i].lower_bound;