+++ /dev/null
-/* 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 *)§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;
-}
+++ /dev/null
-! { 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
projects / gcc.git / commitdiff