From: Paul Thomas Date: Sat, 12 Jan 2019 18:34:30 +0000 (+0000) Subject: ISO_Fortran_binding_2.f90: Remove because of reports of ICEs. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=fd253dbf3e876639bd235943c24fbbdbe6425de0;p=gcc.git ISO_Fortran_binding_2.f90: Remove because of reports of ICEs. 2019-01-12 Paul Thomas * gfortran.dg/ISO_Fortran_binding_2.f90 : Remove because of reports of ICEs. * gfortran.dg/ISO_Fortran_binding_2.c : Ditto. From-SVN: r267884 --- diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8b8ebc8156d..3d74b63c85b 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,18 @@ +2019-01-12 Paul Thomas + + * gfortran.dg/ISO_Fortran_binding_2.f90 : Remove because of + reports of ICEs. + * gfortran.dg/ISO_Fortran_binding_2.c : Ditto. + +2019-01-12 Paul Thomas + + * gfortran.dg/ISO_Fortran_binding_1.f90 : New test. + * gfortran.dg/ISO_Fortran_binding_1.c : Auxilliary file for test. + * gfortran.dg/ISO_Fortran_binding_2.f90 : New test. + * gfortran.dg/ISO_Fortran_binding_2.c : Auxilliary file for test. + * gfortran.dg/bind_c_array_params_2.f90 : Change search string + for dump tree scan. + 2019-01-11 Steven G. Kargl PR fortran/35031 @@ -19,7 +34,7 @@ 2019-01-11 Tobias Burnus PR C++/88114 - * g++.dg/cpp0x/defaulted61.C: New + * g++.dg/cpp0x/defaulted61.C: New * g++.dg/cpp0x/defaulted62.C: New. 2019-01-11 Jakub Jelinek diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.c deleted file mode 100644 index 1c1af2070b3..00000000000 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.c +++ /dev/null @@ -1,115 +0,0 @@ -/* Test F2018 18.5: ISO_Fortran_binding.h functions. */ - -#include -#include -#include -#include - -/* Test the example in F2018 C.12.9: Processing assumed-shape arrays in C, - modified to use CFI_address instead of pointer arithmetic. */ - -int address_c(CFI_cdesc_t * a_desc, const int idx[]) -{ - int *res_addr; - CFI_index_t CFI_idx[1]; - - CFI_idx[0] = (CFI_index_t)idx[0]; - - res_addr = CFI_address (a_desc, CFI_idx); - if (res_addr == NULL) - return -1; - return *res_addr; -} - - -int deallocate_c(CFI_cdesc_t * dd) -{ - return CFI_deallocate(dd); -} - - -int allocate_c(CFI_cdesc_t * da, CFI_index_t lower[], CFI_index_t upper[]) -{ - return CFI_allocate(da, lower, upper, 0); -} - -int establish_c(CFI_cdesc_t * desc, int *rank, int *attr) -{ - typedef struct {double x; double _Complex y;} t; - int err; - CFI_index_t idx[1], extent[1]; - void *ptr; - - extent[0] = 1; - ptr = malloc ((size_t)(extent[0] * sizeof(t))); - err = CFI_establish((CFI_cdesc_t *)desc, - ptr, - (CFI_attribute_t)*attr, - CFI_type_struct, - sizeof(t), (CFI_rank_t)*rank, extent); - free (ptr); - return err; -} - -int contiguous_c(CFI_cdesc_t * desc) -{ - return CFI_is_contiguous(desc); -} - -float section_c(int *std_case, CFI_cdesc_t * source, int *low, int *str) -{ - 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; - - if (*std_case == 1) - { - lower[0] = (CFI_index_t)low[0]; - strides[0] = (CFI_index_t)str[0]; - ind = CFI_establish((CFI_cdesc_t *)§ion, NULL, CFI_attribute_other, - CFI_type_float, 0, 1, NULL); - if (ind) return -1.0; - ind = CFI_section((CFI_cdesc_t *)§ion, source, lower, NULL, strides); - if (ind) return (float)ind; - } - - return 0.0; -} - - -int select_part_c (CFI_cdesc_t * source) -{ - typedef struct - { - double x; - double _Complex y; - } t; - CFI_CDESC_T(2) component; - CFI_cdesc_t * comp_cdesc = (CFI_cdesc_t *)&component; - CFI_index_t extent[] = {10,10}; - CFI_index_t idx[] = {4,0}; - int res; - - res = CFI_establish(comp_cdesc, NULL, CFI_attribute_other, - CFI_type_double_Complex, sizeof(double _Complex), - 2, extent); - if (res) - return res; - - res = CFI_select_part(comp_cdesc, source, offsetof(t,y), 0); - - return res; -} - - -int setpointer_c(CFI_cdesc_t * ptr1, CFI_cdesc_t * ptr2, int lbounds[]) -{ - CFI_index_t lower_bounds[] = {lbounds[0],lbounds[1]}; - int ind; - - ind = CFI_setpointer(ptr1, ptr2, lower_bounds); - return ind; -} diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.f90 deleted file mode 100644 index 2670045e1fa..00000000000 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.f90 +++ /dev/null @@ -1,193 +0,0 @@ -! { dg-do run } -! { dg-additional-sources ISO_Fortran_binding_2.c } -! { dg-options "-fbounds-check" } -! -! Test F2018 18.5: ISO_Fortran_binding.h function errors. -! - USE, INTRINSIC :: ISO_C_BINDING - - TYPE, BIND(C) :: T - REAL(C_DOUBLE) :: X - complex(C_DOUBLE_COMPLEX) :: Y - END TYPE - - type :: mytype - integer :: i - integer :: j - end type - - INTERFACE - FUNCTION c_address(a, idx) BIND(C, NAME="address_c") RESULT(err) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER(C_INT) :: err - INTEGER(C_INT), dimension(1) :: idx - type(*), DIMENSION(..) :: a - END FUNCTION c_address - - FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER(C_INT) :: err - type(*), DIMENSION(..) :: a - END FUNCTION c_deallocate - - FUNCTION c_allocate(a, lower, upper) BIND(C, NAME="allocate_c") RESULT(err) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER(C_INT) :: err - type(*), DIMENSION(..) :: a - integer(C_INTPTR_T), DIMENSION(15) :: lower, upper - END FUNCTION c_allocate - - FUNCTION c_establish(a, rank, attr) BIND(C, NAME="establish_c") RESULT(err) - USE, INTRINSIC :: ISO_C_BINDING - import - INTEGER(C_INT) :: err - INTEGER(C_INT) :: rank, attr - type (T), DIMENSION(..), intent(out) :: a - END FUNCTION c_establish - - FUNCTION c_contiguous(a) BIND(C, NAME="contiguous_c") RESULT(err) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER(C_INT) :: err - type(*), DIMENSION(..) :: a - END FUNCTION c_contiguous - - FUNCTION c_section(std_case, a, lower, strides) BIND(C, NAME="section_c") RESULT(ans) - USE, INTRINSIC :: ISO_C_BINDING - real(C_FLOAT) :: ans - INTEGER(C_INT) :: std_case - INTEGER(C_INT), dimension(15) :: lower - INTEGER(C_INT), dimension(15) :: strides - type(*), DIMENSION(..) :: a - END FUNCTION c_section - - FUNCTION c_select_part(a) BIND(C, NAME="select_part_c") RESULT(ans) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER(C_INT) :: ans - type(*), DIMENSION(..) :: a - END FUNCTION c_select_part - - FUNCTION c_setpointer(a, b, lbounds) BIND(C, NAME="setpointer_c") RESULT(err) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER(C_INT) :: err - INTEGER(C_INT), dimension(2) :: lbounds - type(*), DIMENSION(..) :: a, b - END FUNCTION c_setpointer - END INTERFACE - - integer(C_INTPTR_T), dimension(15) :: lower, upper - - call test_CFI_address - call test_CFI_deallocate - call test_CFI_allocate - call test_CFI_establish - call test_CFI_contiguous - call test_CFI_section - call test_CFI_select_part - call test_CFI_setpointer - -contains - subroutine test_CFI_address - integer, dimension(:), allocatable :: a - allocate (a, source = [1,2,3]) - if (c_address (a, [2]) .ne. 3) stop 1 ! OK - if (c_address (a, [3]) .ne. -1) stop 2 ! "subscripts[0], is out of bounds" - if (c_address (a, [-1]) .ne. -1) stop 3 ! "subscripts[0], is out of bounds" - deallocate (a) - if (c_address (a, [2]) .ne. -1) stop 4 ! "C Descriptor must not be NULL" - end subroutine test_CFI_address - - subroutine test_CFI_deallocate - integer, dimension(:), allocatable :: a - integer, dimension(2,2) :: b - if (c_deallocate (a) .ne. 2) stop 5 ! "Base address is already NULL" - allocate (a(2)) - if (c_deallocate (a) .ne. 0) stop 6 ! OK - if (c_deallocate (b) .ne. 7) stop 7 ! "must describe a pointer or allocatable" - end subroutine test_CFI_deallocate - - subroutine test_CFI_allocate - integer, dimension(:,:), allocatable :: a - integer, dimension(2,2) :: b - lower(1:2) = [2,2] - upper(1:2) = [10,10] - allocate (a(1,1)) - if (c_allocate (a, lower, upper) .ne. 3) stop 8 ! "C descriptor must be NULL" - if (allocated (a)) deallocate (a) - if (c_allocate (a, lower, upper) .ne. 0) stop 9 ! OK - if (c_allocate (b, lower, upper) .ne. 7) STOP 10 ! "must describe a pointer or allocatable" - end subroutine test_CFI_allocate - - subroutine test_CFI_establish - type(T), allocatable :: a(:) - INTEGER(C_INT) :: rank - INTEGER(C_INT) :: attr - attr = 0 ! establish a pointer - rank = 16 - if (c_establish (a, rank, attr) .ne. 5) stop 11 ! "Rank must be between 0 and 15" - rank = 1 - if (c_establish (a, rank, attr) .ne. 0) stop 12 ! OK - if (allocated (a)) deallocate (a) - if (c_establish (a, rank, attr) .ne. 0) Stop 13 ! OK the first time - if (c_establish (a, rank, attr) .ne. 10) Stop 14 ! "its base address must be NULL" - if (allocated (a)) deallocate (a) - attr = 1 ! establish an allocatable - if (c_establish (a, rank, attr) .ne. 7) Stop 15 ! "is for a nonallocatable entity" - end subroutine test_CFI_establish - - subroutine test_CFI_contiguous - integer, allocatable :: a - if (c_contiguous (a) .ne. 2) stop 16 ! "Descriptor is already NULL" - allocate (a) - if (c_contiguous (a) .ne. 5) stop 17 ! "must describe an array" - end subroutine test_CFI_contiguous - - subroutine test_CFI_section - real, allocatable, dimension (:) :: a - integer, dimension(15) :: lower, strides - integer :: i - real :: b - lower(1) = 10 - strides(1) = 5 - if (int (c_section (1, a, lower, strides)) .ne. 2) & - stop 18 ! "Base address of source must not be NULL" - allocate (a(100)) - if (int (c_section (1, a, lower, strides)) .ne. 0) & - stop 19 ! OK - if (int (c_section (1, b, lower, strides)) .ne. 5) & - stop 20 ! "Source must describe an array" - strides(1) = 0 - if (int (c_section (1, a, lower, strides)) .ne. 5) & - stop 21 ! "Rank of result must be equal to the rank of source" - strides(1) = 5 - lower(1) = -1 - if (int (c_section (1, a, lower, strides)) .ne. 12) & - stop 22 ! "Lower bounds must be within the bounds of the fortran array" - lower(1) = 100 - if (int (c_section (1, a, lower, strides)) .ne. 12) & - stop 23 ! "Lower bounds must be within the bounds of the fortran array" - end subroutine test_CFI_section - - subroutine test_CFI_select_part - type(t), allocatable, dimension(:) :: a - type(t) :: src - allocate (a(1), source = src) - if (c_select_part (a) .ne. 5) stop 24 ! "Source and result must have the same rank" - deallocate (a) - if (c_select_part (a) .ne. 2) stop 25 ! "source must not be NULL" - end subroutine test_CFI_select_part - - subroutine test_CFI_setpointer - integer, dimension(2,2), target :: tgt1 - integer, dimension(:,:), pointer :: src - type (t), dimension(2), target :: tgt2 - type (t), dimension(:), pointer :: res - type (t), dimension(2, 2), target, save :: tgt3 - type (t), dimension(:, :), pointer :: src1 - integer, dimension(2) :: lbounds = [-1, -2] - src => tgt1 - res => tgt2 - if (c_setpointer (res, src, lbounds) .ne. 4) stop 26 ! "Element lengths" - src1 => tgt3 - if (c_setpointer (res, src1, lbounds) .ne. 5) stop 27 ! "Ranks of result" - end subroutine test_CFI_setpointer -end