Skip to content

R
riscv-gcc-1
Commit fd253dbf by Paul Thomas
Options

ISO_Fortran_binding_2.f90: Remove because of reports of ICEs. 

2019-01-12  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/ISO_Fortran_binding_2.f90 : Remove because of
	reports of ICEs.
	* gfortran.dg/ISO_Fortran_binding_2.c : Ditto.

From-SVN: r267884
parent 43d168a4
Showing with 16 additions and 309 deletions
gcc/testsuite/ChangeLog
2019-01-12 Paul Thomas <pault@gcc.gnu.org>
* 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 <pault@gcc.gnu.org>
* 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 <kargl@gcc.gnu.org>
PR fortran/35031
......@@ -19,7 +34,7 @@
2019-01-11 Tobias Burnus <burnus@net-b.de>
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 <jakub@redhat.com>
......
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.c deleted 100644 → 0
/* Test F2018 18.5: ISO_Fortran_binding.h functions. */
#include <ISO_Fortran_binding.h>
#include <stdio.h>
#include <stdlib.h>
#include <complex.h>
/* 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 *)&section, NULL, CFI_attribute_other,
CFI_type_float, 0, 1, NULL);
if (ind) return -1.0;
ind = CFI_section((CFI_cdesc_t *)&section, 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;
}
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.f90 deleted 100644 → 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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment