Index: Fortran/gfortran/regression/ISO_Fortran_binding_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_1.c @@ -0,0 +1,232 @@ +/* Test F2008 18.5: ISO_Fortran_binding.h functions. */ + +#include +#include +#include +#include +#include + +/* Test the example in F2008 C.12.9: Processing assumed-shape arrays in C, + modified to use CFI_address instead of pointer arithmetic. */ + +int elemental_mult_c(CFI_cdesc_t * a_desc, CFI_cdesc_t * b_desc, + CFI_cdesc_t * c_desc) +{ + CFI_index_t idx[2]; + int *res_addr; + int err = 1; /* this error code represents all errors */ + + if (a_desc->rank == 0) + { + err = *(int*)a_desc->base_addr; + *(int*)a_desc->base_addr = 0; + return err; + } + + if (a_desc->type != CFI_type_int + || b_desc->type != CFI_type_int + || c_desc->type != CFI_type_int) + return err; + + /* Only support two dimensions. */ + if (a_desc->rank != 2 + || b_desc->rank != 2 + || c_desc->rank != 2) + return err; + + if (a_desc->attribute == CFI_attribute_other) + { + assert (a_desc->dim[0].lower_bound == 0); + assert (a_desc->dim[1].lower_bound == 0); + for (idx[0] = 0; idx[0] < a_desc->dim[0].extent; idx[0]++) + for (idx[1] = 0; idx[1] < a_desc->dim[1].extent; idx[1]++) + { + res_addr = CFI_address (a_desc, idx); + *res_addr = *(int*)CFI_address (b_desc, idx) + * *(int*)CFI_address (c_desc, idx); + } + } + else + { + assert (a_desc->attribute == CFI_attribute_allocatable + || a_desc->attribute == CFI_attribute_pointer); + for (idx[0] = a_desc->dim[0].lower_bound; + idx[0] < a_desc->dim[0].extent + a_desc->dim[0].lower_bound; + idx[0]++) + for (idx[1] = a_desc->dim[1].lower_bound; + idx[1] < a_desc->dim[1].extent + a_desc->dim[1].lower_bound; + idx[1]++) + { + res_addr = CFI_address (a_desc, idx); + *res_addr = *(int*)CFI_address (b_desc, idx) + * *(int*)CFI_address (c_desc, idx); + } + } + + return 0; +} + + +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[]) +{ + int err = 1; + CFI_index_t idx[2]; + int *res_addr; + + if (da->attribute == CFI_attribute_other) return err; + if (CFI_allocate(da, lower, upper, 0)) return err; + assert (da->dim[0].lower_bound == lower[0]); + assert (da->dim[1].lower_bound == lower[1]); + + for (idx[0] = lower[0]; idx[0] < da->dim[0].extent + lower[0]; idx[0]++) + for (idx[1] = lower[1]; idx[1] < da->dim[1].extent + lower[1]; idx[1]++) + { + res_addr = CFI_address (da, idx); + *res_addr = (int)(idx[0] * idx[1]); + } + + return 0; +} + +int establish_c(CFI_cdesc_t * desc) +{ + typedef struct {double x; double _Complex y;} t; + int err; + CFI_index_t idx[1], extent[1]; + t *res_addr; + double value = 1.0; + double complex z_value = 0.0 + 2.0 * I; + + extent[0] = 10; + err = CFI_establish((CFI_cdesc_t *)desc, + malloc ((size_t)(extent[0] * sizeof(t))), + CFI_attribute_pointer, + CFI_type_struct, + sizeof(t), 1, extent); + assert (desc->dim[0].lower_bound == 0); + for (idx[0] = 0; idx[0] < extent[0]; idx[0]++) + { + res_addr = (t*)CFI_address (desc, idx); + res_addr->x = value++; + res_addr->y = z_value * (idx[0] + 1); + } + 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; + float *ret_addr; + float ans = 0.0; + + /* Case (i) from F2018:18.5.5.7. */ + 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 -2.0; + + /* Sum over the section */ + for (idx[0] = section.dim[0].lower_bound; + idx[0] < section.dim[0].extent + section.dim[0].lower_bound; + idx[0]++) + ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx); + return ans; + } + else if (*std_case == 2) + { + int ind; + lower[0] = source->dim[0].lower_bound; + upper[0] = source->dim[0].lower_bound + source->dim[0].extent - 1; + strides[0] = str[0]; + lower[1] = upper[1] = source->dim[1].lower_bound + low[1] - 1; + strides[1] = 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, upper, strides); + assert (section.rank == 1); + if (ind) return -2.0; + + /* Sum over the section */ + for (idx[0] = section.dim[0].lower_bound; + idx[0] < section.dim[0].extent + section.dim[0].lower_bound; + idx[0]++) + ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx); + return ans; + } + + return 0.0; +} + + +double 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}; + double ans = 0.0; + int size; + + (void)CFI_establish(comp_cdesc, NULL, CFI_attribute_other, + CFI_type_double_Complex, sizeof(double _Complex), + 2, extent); + (void)CFI_select_part(comp_cdesc, source, offsetof(t,y), 0); + assert (comp_cdesc->dim[0].lower_bound == 0); + assert (comp_cdesc->dim[1].lower_bound == 0); + + /* Sum over comp_cdesc[4,:] */ + size = comp_cdesc->dim[1].extent; + for (idx[1] = 0; idx[1] < size; idx[1]++) + ans += cimag (*(double _Complex*)CFI_address ((CFI_cdesc_t*)comp_cdesc, + idx)); + return ans; +} + + +int setpointer_c(CFI_cdesc_t * ptr, int lbounds[]) +{ + CFI_index_t lower_bounds[] = {lbounds[0],lbounds[1]}; + int ind; + ind = CFI_setpointer(ptr, ptr, lower_bounds); + return ind; +} + + +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: Fortran/gfortran/regression/ISO_Fortran_binding_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_1.f90 @@ -0,0 +1,246 @@ +! { dg-do run { target c99_runtime } } +! { dg-additional-sources ISO_Fortran_binding_1.c } +! +! Test F2008 18.5: ISO_Fortran_binding.h functions. +! + 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 elemental_mult(a, b, c) BIND(C, NAME="elemental_mult_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + type(*), DIMENSION(..) :: a, b, c + END FUNCTION elemental_mult + + FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + INTEGER(C_INT), DIMENSION(..), allocatable :: 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 + INTEGER(C_INT), DIMENSION(..), allocatable :: a + integer(C_INTPTR_T), DIMENSION(15) :: lower, upper + END FUNCTION c_allocate + + FUNCTION c_establish(a) BIND(C, NAME="establish_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + import + INTEGER(C_INT) :: err + type (T), pointer, 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 + real(C_DOUBLE) :: ans + type(*), DIMENSION(..) :: a + END FUNCTION c_select_part + + FUNCTION c_setpointer(a, lbounds) BIND(C, NAME="setpointer_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + INTEGER(C_INT), dimension(2) :: lbounds + INTEGER(C_INT), DIMENSION(..), pointer :: a + END FUNCTION c_setpointer + + FUNCTION c_assumed_size(a) BIND(C, NAME="assumed_size_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + type(*), DIMENSION(..) :: a + END FUNCTION c_assumed_size + + END INTERFACE + + integer, dimension(:,:), allocatable :: x, y, z + integer, dimension(2,2) :: a, b, c + integer, dimension(4,4) :: d + integer :: i = 42, j, k + integer(C_INTPTR_T), dimension(15) :: lower, upper + real, dimension(10,10) :: arg + type (mytype), dimension(2,2) :: der + + allocate (x, source = reshape ([4,3,2,1], [2,2])) + allocate (y, source = reshape ([2,3,4,5], [2,2])) + allocate (z, source = reshape ([0,0,0,0], [2,2])) + + call test_CFI_address + call test_CFI_deallocate + call test_CFI_allocate + call test_CFI_establish + call test_CFI_contiguous (a) + call test_CFI_section (arg) + call test_CFI_select_part + call test_CFI_setpointer + call test_assumed_size (a) +contains + subroutine test_CFI_address +! Basic test that CFI_desc_t can be passed and that CFI_address works + if (elemental_mult (z, x, y) .ne. 0) stop 1 + if (any (z .ne. reshape ([8,9,8,5], [2,2]))) stop 2 + + a = reshape ([4,3,2,1], [2,2]) + b = reshape ([2,3,4,5], [2,2]) + c = 0 +! Verify that components of arrays of derived types are OK. + der%j = a +! Check that non-pointer/non-allocatable arguments are OK + if (elemental_mult (c, der%j, b) .ne. 0) stop 3 + if (any (c .ne. reshape ([8,9,8,5], [2,2]))) stop 4 + +! Check array sections + d = 0 + d(4:2:-2, 1:3:2) = b + if (elemental_mult (c, a, d(4:2:-2, 1:3:2)) .ne. 0) stop 5 + if (any (c .ne. reshape ([8,9,8,5], [2,2]))) stop 6 + +! If a scalar result is passed to 'elemental_mult' it is returned +! as the function result and then zeroed. This tests that scalars +! are correctly converted to CF_desc_t. + if ((elemental_mult (i, a, b) .ne. 42) & + .or. (i .ne. 0)) stop 7 + deallocate (y,z) +end subroutine test_CFI_address + + subroutine test_CFI_deallocate +! Test CFI_deallocate. + if (c_deallocate (x) .ne. 0) stop 8 + if (allocated (x)) stop 9 + end subroutine test_CFI_deallocate + + subroutine test_CFI_allocate +! Test CFI_allocate. + lower(1:2) = [2,2] + upper(1:2) = [10,10] + + if (c_allocate (x, lower, upper) .ne. 0) stop 10 + if (.not.allocated (x)) stop 11 + if (any (lbound (x) .ne. lower(1:2))) stop 12 + if (any (ubound (x) .ne. upper(1:2))) stop 13 + +! Elements are filled by 'c_allocate' with the product of the fortran indices + do j = lower(1) , upper(1) + do k = lower(2) , upper(2) + x(j,k) = x(j,k) - j * k + end do + end do + if (any (x .ne. 0)) stop 14 + deallocate (x) + end subroutine test_CFI_allocate + + subroutine test_CFI_establish +! Test CFI_establish. + type(T), pointer :: case2(:) => null() + if (c_establish(case2) .ne. 0) stop 14 + if (ubound(case2, 1) .ne. 9) stop 15 + if (.not.associated(case2)) stop 16 + if (sizeof(case2) .ne. 240) stop 17 + if (int (sum (case2%x)) .ne. 55) stop 18 + if (int (sum (imag (case2%y))) .ne. 110) stop 19 + deallocate (case2) + end subroutine test_CFI_establish + + subroutine test_CFI_contiguous (arg) + 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) + real, dimension (100) :: a + real, dimension (10,*) :: arg + integer, dimension(15) :: lower, strides + integer :: i + +! Case (i) from F2018:18.5.5.7. + a = [(real(i), i = 1, 100)] + lower(1) = 10 + strides(1) = 5 +! Remember, 'a' being non pointer, non-allocatable, the C descriptor +! lbounds are set to zero. + if (int (sum(a(lower(1)+1::strides(1))) & + - c_section(1, a, lower, strides)) .ne. 0) stop 28 +! Case (ii) from F2018:18.5.5.7. + arg(:,1:10) = reshape ([(real(i), i = 1, 100)], [10,10]) + lower(1) = 1 + lower(2) = 5 + strides(1) = 1 + strides(2) = 0 + if (int (sum(arg(:,5)) & + - c_section (2, arg, lower, strides)) .ne. 0) stop 29 + end subroutine test_CFI_section + + subroutine test_CFI_select_part +! Test the example from F2018:18.5.5.8. +! Modify to take rank 2 and sum the section type_t(5, :)%y%im +! Note that sum_z_5 = sum (type_t(5, :)%y%im) is broken on Darwin. +! + type (t), dimension(10, 10) :: type_t + real(kind(type_t%x)) :: v, sum_z_5 = 0.0 + complex(kind(type_t%y)) :: z +! Set the array 'type_t'. + do j = 1, 10 + do k = 1, 10 + v = dble (j * k) + z = cmplx (2 * v, 3 * v) + type_t(j, k) = t (v, z) + if (j .eq. 5) sum_z_5 = sum_z_5 + imag (z) + end do + end do +! Now do the test. + if (int (c_select_part (type_t) - sum_z_5) .ne. 0) stop 30 + end subroutine test_CFI_select_part + + subroutine test_CFI_setpointer +! Test the example from F2018:18.5.5.9. + integer, dimension(:,:), pointer :: ptr => NULL () + integer, dimension(2,2), target :: tgt + integer, dimension(2) :: lbounds = [-1, -2] +! The C-function resets the lbounds + ptr(1:, 1:) => tgt + if (c_setpointer (ptr, lbounds) .ne. 0) stop 31 + if (any (lbound(ptr) .ne. lbounds)) stop 32 + end subroutine test_CFI_setpointer + + subroutine test_assumed_size (arg) + integer, dimension(2,*) :: arg +! The C-function checks contiguousness and that extent[1] == -1. + if (c_assumed_size (arg) .ne. 0) stop 33 + end subroutine +end Index: Fortran/gfortran/regression/ISO_Fortran_binding_10.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_10.c @@ -0,0 +1,73 @@ +/* Test the fix of PR89843. */ + +/* Contributed by Reinhold Bader */ + +#include +#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, 0 }; + 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: Fortran/gfortran/regression/ISO_Fortran_binding_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_10.f90 @@ -0,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:',abs(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: Fortran/gfortran/regression/ISO_Fortran_binding_11.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_11.c @@ -0,0 +1,78 @@ +/* Test the fix of PR89846. + +Contributed by Reinhold Bader #include */ + +#include +#include +#include +#include + +typedef struct +{ + char n; + float r[2]; +} t1; + +typedef struct +{ + long int i; + t1 t1; +} t2; + + + +void ta0(CFI_cdesc_t *); +void ta1(CFI_cdesc_t *); + +void ti(CFI_cdesc_t *this, int flag) +{ + int status; + size_t dis; + CFI_CDESC_T(1) that; + t1 *ans; + + switch (flag) + { + case 0: + dis = offsetof(t2, t1); + status = CFI_establish((CFI_cdesc_t *) &that, NULL, CFI_attribute_other, + CFI_type_struct, sizeof(t1), 1, NULL); + if (status != CFI_SUCCESS) + { + printf("FAIL 1 establish: nonzero status %i\n",status); + exit(1); + } + status = CFI_select_part((CFI_cdesc_t *) &that, this, dis, 0); + if (status != CFI_SUCCESS) + { + printf("FAIL C1: nonzero status %i\n",status); + exit(1); + } + break; + + case 1: + dis = offsetof(t2, i); + status = CFI_establish((CFI_cdesc_t *) &that, NULL, CFI_attribute_other, + CFI_type_long, 0, 1, NULL); + if (status != CFI_SUCCESS) + { + printf("FAIL 2 establish: nonzero status %i\n",status); + exit(1); + } + status = CFI_select_part((CFI_cdesc_t *) &that, this, dis, 0); + if (status != CFI_SUCCESS) + { + printf("FAIL C2: nonzero status %i\n",status); + exit(1); + } + } + + if (CFI_is_contiguous((CFI_cdesc_t *) &that)) + { + printf("FAIL C: contiguity for flag value %i - is %i\n",flag, + CFI_is_contiguous((CFI_cdesc_t *) &that)); + } + + if (flag == 0) ta0((CFI_cdesc_t *) &that); + if (flag == 1) ta1((CFI_cdesc_t *) &that); +} Index: Fortran/gfortran/regression/ISO_Fortran_binding_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_11.f90 @@ -0,0 +1,81 @@ +! { dg-do run { target c99_runtime } } +! { dg-additional-sources ISO_Fortran_binding_11.c } +! +! Test the fix of PR89846. +! +! Contributed by Reinhold Bader +! +module mod_subobj_01 + use, intrinsic :: iso_c_binding + implicit none + integer, parameter :: nelem = 5 + type, bind(c) :: t1 + character(c_char) :: n + real(c_float) :: r(2) + end type t1 + type, bind(c) :: t2 + integer(c_long) :: i + type(t1) :: t1 + end type t2 + interface + subroutine ti(this, flag) bind(c) + import :: t2, c_int + type(t2) :: this(:) + integer(c_int), value :: flag + end subroutine ti + end interface +contains + subroutine ta0(this) bind(c) + type(t1) :: this(:) + integer :: i, iw, status + status = 0 + if (size(this) /= nelem) then + write(*,*) 'FAIL 1: ',size(this) + status = status + 1 + end if + iw = 0 + do i=1, nelem + if (this(i)%n /= char(i,c_char) .or. this(i)%r(1) /= real(i,c_float) .or. & + this(i)%r(2) /= real(i+1,c_float)) then + iw = iw + 1 + end if + end do + if (iw > 0) then + write(*,*) 'FAIL 2: ' ,this + status = status + 1 + end if + if (status /= 0) stop 1 + end subroutine ta0 + subroutine ta1(this) bind(c) + integer(c_long) :: this(:) + integer :: i, status + status = 0 + if (size(this) /= nelem) then + write(*,*) 'FAIL 3: ',size(this) + status = status + 1 + end if + if (maxval(abs(this - [ (int(i,c_long),i=1,nelem) ])) > 0) then + write(*,*) 'FAIL 4: ' ,this + status = status + 1 + end if + if (status /= 0) stop 2 + end subroutine ta1 +end module mod_subobj_01 +program subobj_01 + use mod_subobj_01 + implicit none + integer :: i + + type(t2), allocatable :: o_t2(:) + + allocate(o_t2(nelem)) + do i=1, nelem + o_t2(i)%t1 = t1( char(i,c_char), [ real(i,c_float), real(i+1,c_float) ] ) + o_t2(i)%i = int(i,c_long) + end do + + call ti(o_t2,0) + call ti(o_t2,1) + +end program subobj_01 + Index: Fortran/gfortran/regression/ISO_Fortran_binding_12.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_12.c @@ -0,0 +1,29 @@ +/* Test the fix for PR90093. */ + +#include +#include +#include + +/* Contributed by Reinhold Bader */ + +void foo_opt(CFI_cdesc_t *, float *, int *, int); +void write_res(); + +float x[34]; + +int main() { + CFI_CDESC_T(1) xd; + CFI_index_t ext[] = {34}; + int sz; + + CFI_establish((CFI_cdesc_t *) &xd, &x, CFI_attribute_other, + CFI_type_float, 0, 1, ext); + + foo_opt((CFI_cdesc_t *) &xd, NULL, NULL, 0); + sz = 12; + foo_opt(NULL, &x[11], &sz, 1); + + write_res(); + + return 0; +} Index: Fortran/gfortran/regression/ISO_Fortran_binding_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_12.f90 @@ -0,0 +1,53 @@ +! { dg-do run { target c99_runtime } } +! { dg-additional-sources ISO_Fortran_binding_12.c } +! +! Test the fix for PR90093. The additional source is the main program. +! +! Contributed by Reinhold Bader +! +module mod_optional + use, intrinsic :: iso_c_binding + implicit none + integer :: status = 0 + +contains + + subroutine foo_opt(this, that, sz, flag) bind(c) + real(c_float), optional :: this(:) + real(c_float), optional :: that(*) + integer(c_int), optional :: sz + integer(c_int), value :: flag + if (flag == 0) then + if (.not. present(this) .or. present(that) .or. present(sz)) then + write(*,*) 'FAIL 1', present(this), present(that), present(sz) + status = status + 1 + end if + else if (flag == 1) then + if (present(this) .or. .not. present(that) .or. .not. present(sz)) then + write(*,*) 'FAIL 2', present(this), present(that), present(sz) + status = status + 1 + end if + if (sz /= 12) then + write(*,*) 'FAIL 3' + status = status + 1 + end if + else if (flag == 2) then + if (present(this) .or. present(that) .or. present(sz)) then + write(*,*) 'FAIL 4', present(this), present(that), present(sz) + status = status + 1 + end if + end if + end subroutine foo_opt + + subroutine write_res() BIND(C) +! Add a check that the fortran missing optional is accepted by the +! bind(C) procedure. + call foo_opt (flag = 2) + if (status == 0) then + write(*,*) 'OK' + else + stop 1 + end if + end subroutine + +end module mod_optional Index: Fortran/gfortran/regression/ISO_Fortran_binding_13.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_13.c @@ -0,0 +1,12 @@ +/* Test the fix for PR91926. */ + +/* Contributed by José Rui Faustino de Sousa */ + +#include + +int ifb_echo(void*); + +int ifb_echo(void *this) +{ + return this == NULL ? 1 : 2; +} Index: Fortran/gfortran/regression/ISO_Fortran_binding_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_13.f90 @@ -0,0 +1,39 @@ +! { dg-do run { target c99_runtime } } +! { dg-additional-sources ISO_Fortran_binding_13.c } +! +! Test the fix for PR91926. The additional source is the main program. +! +! Contributed by José Rui Faustino de Sousa +! +program ifb_p + + implicit none + + integer :: i = 42 + + interface + integer function ifb_echo_aux(this) bind(c, name="ifb_echo") + implicit none + type(*), dimension(..), & ! removing assumed rank solves segmentation fault + optional, intent(in) :: this + end function ifb_echo_aux + end interface + + if (ifb_echo_aux() .ne. 1) STOP 1 ! worked + if (ifb_echo() .ne. 1) stop 2 ! segmentation fault + if (ifb_echo_aux(i) .ne. 2) stop 3 ! worked + if (ifb_echo(i) .ne. 2) stop 4 ! worked + + stop + +contains + + integer function ifb_echo(this) + type(*), dimension(..), & + optional, intent(in) :: this + + ifb_echo = ifb_echo_aux(this) + return + end function ifb_echo + +end program ifb_p Index: Fortran/gfortran/regression/ISO_Fortran_binding_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_14.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! +! Correct an error in the eveluation of the CFI descriptor attribute for +! the case where the bind_C formal argument is not an assumed shape array +! and not allocatable or pointer. +! +! Contributed by Gilles Gouaillardet +! +MODULE FOO +INTERFACE +SUBROUTINE dummy(buf) BIND(C, name="clock") +type(*), dimension(..) :: buf +END SUBROUTINE +END INTERFACE +END MODULE + +PROGRAM main + USE FOO + IMPLICIT NONE + integer(8) :: before, after + + INTEGER, parameter :: n = 1 + + INTEGER, ALLOCATABLE :: buf(:) + INTEGER :: buf2(n) + INTEGER :: i + + ALLOCATE(buf(n)) + before = LOC(buf(1)) + CALL dummy (buf) + after = LOC(buf(1)) + + if (before .NE. after) stop 1 + + before = LOC(buf2(1)) + CALL dummy (buf) + after = LOC(buf2(1)) + + if (before .NE. after) stop 2 + +END PROGRAM Index: Fortran/gfortran/regression/ISO_Fortran_binding_15.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_15.c @@ -0,0 +1,43 @@ +/* Test the fix for PR92123. */ + +/* Contributed by Vipul Parekh */ + +#include +#include +#include + +// Prototype for Fortran functions +extern void Fsub(CFI_cdesc_t *); + +int main() +{ +/* Note: ISO C forbids zero-size array 'dim' [-Wpedantic] + Therefore, even though 'dat' represents a scalar, it is set rank 1/ */ + CFI_CDESC_T(1) 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: Fortran/gfortran/regression/ISO_Fortran_binding_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_15.f90 @@ -0,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 Index: Fortran/gfortran/regression/ISO_Fortran_binding_16.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_16.c @@ -0,0 +1,40 @@ +/* Test the fix for PR92142. */ + +#include + +#include + +int c_setpointer(CFI_cdesc_t *); + +int c_setpointer(CFI_cdesc_t *ip) +{ + CFI_cdesc_t *yp = NULL; + void *auxp = ip->base_addr; + int ierr; + int status; + + /* Setting up the pointer */ + ierr = 1; + yp = malloc(sizeof(*ip)); + if (yp == NULL) return ierr; + status = CFI_establish(yp, NULL, CFI_attribute_pointer, ip->type, ip->elem_len, ip->rank, NULL); + if (status != CFI_SUCCESS) return ierr; + if (yp->attribute != CFI_attribute_pointer) return ierr; + /* Set the pointer to ip */ + ierr = 2; + status = CFI_setpointer(yp, ip, NULL); + if (status != CFI_SUCCESS) return ierr; + if (yp->attribute != CFI_attribute_pointer) return ierr; + /* Set the pointer to NULL */ + ierr = 3; + status = CFI_setpointer(yp, NULL, NULL); + if (status != CFI_SUCCESS) return ierr; + if (yp->attribute != CFI_attribute_pointer) return ierr; + /* "Set" the ip variable to yp (should not be possible) */ + ierr = 4; + status = CFI_setpointer(ip, yp, NULL); + if (status != CFI_INVALID_ATTRIBUTE) return ierr; + if (ip->attribute != CFI_attribute_other) return ierr; + if (ip->base_addr != auxp) return ierr; + return 0; +} Index: Fortran/gfortran/regression/ISO_Fortran_binding_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_16.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-additional-options "-fbounds-check" } +! { dg-additional-sources ISO_Fortran_binding_16.c } +! +! Test the fix for PR92142. +! + use, intrinsic :: iso_c_binding, only: c_int + + implicit none + + interface + function c_setpointer(ip) result(ierr) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + type(*), dimension(..), target :: ip + integer(c_int) :: ierr + end function c_setpointer + end interface + + integer(c_int) :: it = 1 + + if (c_setpointer(it) /= 0) stop 1 + +end + +! { dg-output "CFI_setpointer: Result shall be the address of a C descriptor for a Fortran pointer." } Index: Fortran/gfortran/regression/ISO_Fortran_binding_17.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_17.c @@ -0,0 +1,25 @@ +/* PR fortran/92470 - to be used with ISO_Fortran_binding_17.f90 */ + +#include +#include +#include + +void Csub(const CFI_cdesc_t *, size_t, CFI_index_t invalid); + +void Csub(const CFI_cdesc_t * dv, size_t locd, CFI_index_t invalid) { + + CFI_index_t lb[1]; + lb[0] = dv->dim[0].lower_bound; + size_t ld = (size_t)CFI_address(dv, lb); + + if (ld != locd) + printf ("In C function: CFI_address of dv = %I64x\n", ld); + assert( ld == locd ); + + lb[0] = invalid; + /* Shall return NULL and produce stderr diagnostic with -fcheck=array. */ + ld = (size_t)CFI_address(dv, lb); + assert (ld == 0); + + return; +} Index: Fortran/gfortran/regression/ISO_Fortran_binding_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_17.f90 @@ -0,0 +1,77 @@ +! { dg-do run } +! { dg-additional-sources ISO_Fortran_binding_17.c } +! { dg-options "-fcheck=all" } +! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 } +! +! PR fortran/92470 +! +! https://github.com/j3-fortran/fortran_proposals/issues/57#issuecomment-552680503 +! +! Unit Test #: Test-1.F2018-2.7.5 +! Author : FortranFan +! Reference : The New Features of Fortran 2018, John Reid, August 2, 2018 +! ISO/IEC JTC1/SC22/WG5 N2161 +! Description: +! Test item 2.7.5 Fortran subscripting +! void *CFI_address(const CFI_cdesc_t *dv, const CFI_index_t subscripts[]); +! that returns the C address of a scalar or of an element of an array using +! Fortran sub-scripting. +! + use, intrinsic :: iso_c_binding, only: c_int, c_size_t, c_loc + implicit none + + integer, parameter :: LB_A = -2 + integer, parameter :: UB_A = 1 + character(len=*), parameter :: fmtg = "(*(g0,1x))" + character(len=*), parameter :: fmth = "(g0,1x,z0)" + + blk1: block + interface + subroutine Csub(a, loc_a_1, invalid_idx) bind(C, name="Csub") + import :: c_size_t + type(*), intent(in) :: a(:) + integer(c_size_t), intent(in), value :: loc_a_1, invalid_idx + end subroutine + end interface + + integer(c_int), target :: a( LB_A:UB_A ) + integer(c_size_t) :: loc_a + + print fmtg, "Block 1" + + loc_a = transfer( c_loc(a(lbound(a,dim=1))), mold=loc_a) + print fmth, "Address of a: ", loc_a + + call Csub(a, loc_a, -1_c_size_t) ! LB starts at 0 + call Csub(a, loc_a, 5_c_size_t) ! 4 elements + 1 + print * + end block blk1 + + blk2: block + interface + subroutine Csub(a, loc_a_1, invalid_idx) bind(C, name="Csub") + import :: c_int, c_size_t + integer(kind=c_int), allocatable, intent(in) :: a(:) + integer(c_size_t), intent(in), value :: loc_a_1, invalid_idx + end subroutine + end interface + + integer(c_int), allocatable, target :: a(:) + integer(c_size_t) :: loc_a + + print fmtg, "Block 2" + + allocate( a( LB_A:UB_A ) ) + loc_a = transfer( c_loc(a(lbound(a,dim=1))), mold=loc_a ) + print fmth, "Address of a: ", loc_a + + call Csub(a, loc_a, LB_A-1_c_size_t) + call Csub(a, loc_a, UB_A+1_c_size_t) + print * + end block blk2 +end + +! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = -1, lower_bound = 0, upper bound = 4, extent = 4(\r*\n+)" } +! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = 5, lower_bound = 0, upper bound = 4, extent = 4(\r*\n+).*" } +! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = -3, lower_bound = -2, upper bound = 6, extent = 4(\r*\n+)" } +! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = 2, lower_bound = -2, upper bound = 6, extent = 4(\r*\n+)" } Index: Fortran/gfortran/regression/ISO_Fortran_binding_18.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_18.c @@ -0,0 +1,27 @@ +#include +#include +#include + + +extern int do_loop(CFI_cdesc_t* array); + +int main(int argc, char ** argv) +{ + int nx = 9; + int ny = 10; + int nz = 2; + + int arr[nx*ny*nz]; + memset(arr,0,sizeof(int)*nx*ny*nz); + CFI_index_t shape[3]; + shape[0] = nz; + shape[1] = ny; + shape[2] = nx; + + CFI_CDESC_T(3) farr; + int rc = CFI_establish((CFI_cdesc_t*)&farr, arr, CFI_attribute_other, CFI_type_int, 0, (CFI_rank_t)3, (const CFI_index_t *)shape); + if (rc != CFI_SUCCESS) abort(); + int result = do_loop((CFI_cdesc_t*)&farr); + if (result != nx*ny*nz) abort(); + return 0; +} Index: Fortran/gfortran/regression/ISO_Fortran_binding_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_18.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-additional-sources ISO_Fortran_binding_18.c } + +module fortran_binding_test_18 + use iso_c_binding + implicit none +contains + + subroutine test(array) + integer(c_int) :: array(:) + array = 1 + end subroutine + + function do_loop(array) result(the_sum) bind(c) + integer(c_int), intent(in out) :: array(:,:,:) + integer(c_int) :: the_sum, i, j + + the_sum = 0 + array = 0 + do i=1,size(array,3) + do j=1,size(array,2) + call test(array(:,j,i)) + end do + end do + the_sum = sum(array) + end function + +end module Index: Fortran/gfortran/regression/ISO_Fortran_binding_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_19.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! This testcase failed before with optimization as +! allocatef's CFI descriptor argument 'x' failed with -fstrict-alias due to +! internally alising with the GFC descriptor +! + +program testit + use iso_c_binding + implicit none (external, type) + type, bind (c) :: m + integer(C_INT) :: i, j + end type + type(m), allocatable :: a(:) + + call testf (a) + +contains + subroutine allocatef (x) bind (c) + type(m), allocatable :: x(:) + allocate (x(5:15)) + end subroutine + + subroutine testf (y) + type(m), allocatable, target :: y(:) + call allocatef (y) + if (.not. allocated (y)) stop 1 + end subroutine +end program Index: Fortran/gfortran/regression/ISO_Fortran_binding_3.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_3.c @@ -0,0 +1,32 @@ +#include +#include +#include + +/* Part of the test for the fix of PR88929 - see ISO_Fortran_binding_3.f90. */ + +int c_test (CFI_cdesc_t * a_desc) +{ + CFI_index_t idx[2]; + int *res_addr; + int err = 1; /* this error code represents all errors */ + + if (a_desc->rank != 2) + return err; + + if (a_desc->type != CFI_type_int) + return err; + + err = 0; + for (idx[0] = 0; idx[0] < a_desc->dim[0].extent; idx[0]++) + for (idx[1] = 0; idx[1] < a_desc->dim[1].extent; idx[1]++) + { + res_addr = CFI_address (a_desc, idx); + err += *res_addr; + *res_addr = *res_addr + 1; + } + + if (err != 10) return 1; + + return 0; +} + Index: Fortran/gfortran/regression/ISO_Fortran_binding_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_3.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-additional-sources ISO_Fortran_binding_3.c } +! +! Test the fix for PR88929. +! + integer, dimension (:,:), allocatable :: actual + integer, dimension(2,2) :: src = reshape ([1,2,3,4], [2,2]) + + allocate (actual, source = src) + + ier = test1 (actual) + if (ier .ne. 0) stop 1 + if (any (actual .ne. src + 1)) stop 2 + +contains + + function test1 (arg) RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + type(*), dimension(..), intent(inout) :: arg + interface + function test_c (a) BIND(C, NAME="c_test") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + type(*), dimension(..), intent(inout) :: a + INTEGER(C_INT) :: err + end function + end interface + + err = test_c (arg) ! This used to ICE + + end function test1 +end Index: Fortran/gfortran/regression/ISO_Fortran_binding_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_4.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! PR fortran/89384 - this used to give a wrong results +! with contiguous. +! The subroutine substr is a test to check a problem found while +! debugging PR90355. +! +! Test case by Reinhold Bader. +! +module mod_ctg + implicit none + +contains + + subroutine ctg(x) BIND(C) + real, contiguous :: x(:) + if (any(abs(x - [2.,4.,6.]) > 1.e-6)) stop 1 + x = [2.,4.,6.]*10.0 + end subroutine + + subroutine substr(str) BIND(C) + character(*) :: str(:) + if (str(1) .ne. "bcd") stop 2 + if (str(2) .ne. "ghi") stop 3 + str = ['uvw','xyz'] + end subroutine + + subroutine substr4(str4) BIND(C) + character(*, kind=4) :: str4(:) + print *, str4(1) + print *, str4(2) + if (str4(1) .ne. 4_"bcd") stop 4 + if (str4(2) .ne. 4_"ghi") stop 5 + str4 = [4_'uvw', 4_'xyz'] + end subroutine + +end module + +program p + use mod_ctg + implicit none + real :: x(6) + character(5) :: str(2) = ['abcde', 'fghij'] + character(5, kind=4) :: str4(2) = [4_'abcde', 4_'fghij'] + integer :: i + + 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 3 + + !call substr(str(:)(2:4)) + !if (any (str .ne. ['auvwe','fxyzj'])) stop 4 + + call substr4(str4(:)(2:4)) + if (any (str4 .ne. [4_'auvwe', 4_'fxyzj'])) stop 4 +end program Index: Fortran/gfortran/regression/ISO_Fortran_binding_5.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_5.c @@ -0,0 +1,83 @@ +/* Test fix for PR89385. */ + +/* Contributed by Reinhold Bader */ + +#include +#include +#include + +typedef struct { + int i; + float r[2]; +} cstruct; + + +void Psub(CFI_cdesc_t *this, CFI_cdesc_t *that, int *ierr) { + int status = 0; + cstruct *cu; + float *ct; + CFI_dim_t *dim; + if (this->elem_len != sizeof(float)) { + printf("FAIL: this->elem_len %i\n",(int) this->elem_len); + status++; + } + if (this->type != CFI_type_float) { + printf("FAIL: this->type\n"); + status++; + } + if (this->rank != 2) { + printf("FAIL: this->rank %i\n",this->rank); + status++; + } + if (this->attribute != CFI_attribute_allocatable) { + printf("FAIL: this->attribute\n"); + status++; + } + dim = this->dim; + if (dim[0].lower_bound != 3 || dim[0].extent != 4) { + printf("FAIL: dim[0] %d %d\n", dim[0].lower_bound, dim[0].extent); + status++; + } + if (dim[1].lower_bound != 1 || dim[1].extent != 5) { + printf("FAIL: dim[1] %d %d\n", dim[1].lower_bound, dim[1].extent); + status++; + } + + if (that->elem_len != sizeof(cstruct)) { + printf("FAIL: that->elem_len\n"); + status++; + } + if (that->type != CFI_type_struct) { + printf("FAIL: that->type %d %d\n", that->type, CFI_type_struct); + status++; + } + if (that->rank != 1) { + printf("FAIL: that->rank\n"); + status++; + } + if (that->attribute != CFI_attribute_allocatable) { + printf("FAIL: that->attribute\n"); + status++; + } + dim = that->dim; + if (dim[0].lower_bound != 1 || dim[0].extent != 1) { + printf("FAIL: dim[0] %d %d\n" , dim[0].lower_bound, dim[0].extent); + status++; + } + cu = (cstruct *) ((CFI_cdesc_t *) that)->base_addr; + if (cu->i != 4 || fabs(cu->r[1] - 2.2) > 1.0e-6) { + printf("FAIL: value of that %i %f %f\n",cu->i,cu->r[1],cu->r[2]); + status++; + } + + ct = (float *) ((CFI_cdesc_t *) this)->base_addr; + if ( fabs(ct[5] + 2.0) > 1.0e-6) { + printf("FAIL: value of this %f\n",ct[5]); + status++; + } + + + *ierr = status; + +} + Index: Fortran/gfortran/regression/ISO_Fortran_binding_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_5.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-additional-sources ISO_Fortran_binding_5.c } +! +! Test fix of PR89385. +! +! Contributed by Reinhold Bader +! +program allocatable_01 + use, intrinsic :: iso_c_binding + implicit none + type, bind(c) :: cstruct + integer(c_int) :: i + real(c_float) :: r(2) + end type cstruct + interface + subroutine psub(this, that, ierr) bind(c, name='Psub') + import :: c_float, cstruct, c_int + real(c_float), allocatable :: this(:,:) + type(cstruct), allocatable :: that(:) + integer(c_int), intent(inout) :: ierr + end subroutine psub + end interface + + real(c_float), allocatable :: t(:,:) + type(cstruct), allocatable :: u(:) + integer(c_int) :: ierr + + allocate(t(3:6,5)) + t = 0.0 + t(4,2) = -2.0 + allocate(u(1), source=[ cstruct( 4, [1.1,2.2] ) ] ) + call psub(t, u, ierr) + + deallocate(t,u) + if (ierr .ne. 0) stop ierr +end program allocatable_01 Index: Fortran/gfortran/regression/ISO_Fortran_binding_6.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_6.c @@ -0,0 +1,23 @@ +/* Test fix for PR89366. */ + +/* Contributed by Reinhold Bader */ + +#include +#include +#include + +#define DEBUG 0 + +void process_string(CFI_cdesc_t *this, int *ierr) { + char *cstr; + cstr = (char *) this->base_addr; + *ierr = 0; + if (this->rank != 0) { + *ierr = 1; + return; + } + if (DEBUG == 1) { + printf("elem_len member has value %i %s\n",this->elem_len, cstr); + } + +} Index: Fortran/gfortran/regression/ISO_Fortran_binding_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_6.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! { dg-additional-sources ISO_Fortran_binding_6.c } +! +! Test fix of PR89366. +! +! Contributed by Reinhold Bader +! +program assumed_length_01 + use, intrinsic :: iso_c_binding + implicit none + integer, parameter :: strlen = 12 + integer(c_int) :: ierr(3) + character(kind=c_char,len=strlen) :: s1 + character(kind=c_char,len=:), allocatable :: s2 + character(kind=c_char,len=:), pointer :: s3 +! +! invoke a C function that processes an assumed length string + interface + subroutine process_string(this, ierr) BIND(C) + import :: c_char, c_int + character(kind=c_char,len=*), intent(in) :: this(..) + integer(c_int), intent(inout) :: ierr + end subroutine process_string + end interface +! +! + ierr = 0 + s1 = c_char_'wrzlprmft' // c_null_char + call process_string(s1, ierr(1)) + if (ierr(1) /= 0) stop 1 + s2 = c_char_'wrzlprmft' // c_null_char + allocate(s3, source=trim(s1)) + call process_string(s2, ierr(2)) + if (ierr(2) /= 0) stop 2 + call process_string(s3, ierr(3)) + if (ierr(3) /= 0) stop 3 + if (sum(abs(ierr)) == 0) write(*,*) 'OK' + + deallocate(s2,s3) + +end program assumed_length_01 Index: Fortran/gfortran/regression/ISO_Fortran_binding_7.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_7.c @@ -0,0 +1,102 @@ +/* Test the fix for PR89841. */ + +/* Contributed by Reinhold Bader */ + +#include +#include +#include +#include + +typedef struct + { + int i; + float r[2]; + } cstruct; + + +int Psuba(CFI_cdesc_t *this, CFI_cdesc_t *that, int Dcase) { + int status = 0; + cstruct *cu; + float *ct; + CFI_dim_t *dim; + if (this->elem_len != sizeof(float)) + { + printf("FAIL: Dcase %i - this->elem_len %i\n",Dcase, (int) this->elem_len); + status++; + } + if (this->type != CFI_type_float) + { + printf("FAIL: Dcase %i - this->type\n", Dcase); + status++; + } + if (this->rank != 2) + { + printf("FAIL: Dcase %i - this->rank %i\n",Dcase,this->rank); + status++; + } + if (this->attribute != CFI_attribute_other) + { + printf("FAIL: Dcase %i - this->attribute\n", Dcase); + status++; + } + + dim = this->dim; + if (dim[0].lower_bound != 0 || dim[0].extent != 3) + { + printf("FAIL: Dcase %i - dim[0] %i %i %i\n",Dcase, (int) dim[0].lower_bound, + (int)dim[0].extent,(int)dim[0].sm); + status++; + } + if (dim[1].lower_bound != 0 || dim[1].extent != 7) + { + printf("FAIL: Dcase %i - dim[1] %i %i %i\n",Dcase,(int) dim[1].lower_bound, + (int) dim[1].extent,(int) dim[1].sm); + status++; + } + + if (that->elem_len != sizeof(cstruct)) + { + printf("FAIL: Dcase %i - that->elem_len\n", Dcase); + status++; + } + if (that->type != CFI_type_struct) + { + printf("FAIL: Dcase %i - that->type\n",Dcase); + status++; + } + if (that->rank != 1) + { + printf("FAIL: Dcase %i - that->rank\n", Dcase); + status++; + } + if (that->attribute != CFI_attribute_other) + { + printf("FAIL: Dcase %i - that->attribute %i\n",Dcase,that->attribute); + status++; + } + + dim = that->dim; + if (dim[0].lower_bound != 0 || dim[0].extent != 1) + { + printf("FAIL: Dcase %i - dim[0] %i %i\n",Dcase,(int)dim[0].lower_bound,dim[0].extent); + status++; + } + + cu = (cstruct *) ((CFI_cdesc_t *) that)->base_addr; + if (cu->i != 4 || fabs(cu->r[1] - 2.2) > 1.0e-6) + { + printf("FAIL: Dcase %i - value of that %i %f %f\n",Dcase,cu->i,cu->r[0],cu->r[1]); + status++; + } + + ct = (float *) ((CFI_cdesc_t *) this)->base_addr; + if ( fabs(ct[5] + 2.0) > 1.0e-6) + { + printf("FAIL: Dcase %i - value of this %f\n",Dcase,ct[5]); + status++; + } + + return status; +} + + Index: Fortran/gfortran/regression/ISO_Fortran_binding_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_7.f90 @@ -0,0 +1,42 @@ +! { dg-do run { target c99_runtime } } +! { dg-additional-sources ISO_Fortran_binding_7.c } +! +! Test the fix for PR89841. +! +! Contributed by Reinhold Bader +! +program assumed_shape_01 + use, intrinsic :: iso_c_binding + implicit none + type, bind(c) :: cstruct + integer(c_int) :: i + real(c_float) :: r(2) + end type cstruct + interface + function psub(this, that, case) bind(c, name='Psuba') result(status) + import :: c_float, c_int, cstruct + real(c_float) :: this(:,:) + type(cstruct) :: that(:) + integer(c_int), value :: case + integer(c_int) :: status + end function psub + end interface + + real(c_float) :: t(3,7) + type(cstruct), pointer :: u(:) + type(cstruct), allocatable :: v(:) + integer(c_int) :: st + + allocate(u(1), source=[cstruct( 4, [1.1,2.2] ) ]) + allocate(v(1), source=[cstruct( 4, [1.1,2.2] ) ]) + t = 0.0 + t(3,2) = -2.0 + st = psub(t, u, 1) + if (st .ne. 0) stop 1 + st = psub(t, v, 2) + if (st .ne. 0) stop 2 + deallocate (u) + deallocate (v) + +end program assumed_shape_01 + Index: Fortran/gfortran/regression/ISO_Fortran_binding_8.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_8.c @@ -0,0 +1,37 @@ +/* Test the fix for PR89841. */ + +/* Contributed by Reinhold Bader */ + +#include +#include + +float Cxgl[] = { 1.1, 2.3, 5.1, 4.2 }; + +void globalp(CFI_cdesc_t *this) +{ + int i, status; + float *pt; + CFI_index_t lb[] = { 3 }; + CFI_index_t ub[] = { 6 }; + + if (this->base_addr == NULL) + { + status = CFI_allocate(this, lb, ub, 0); + } + else + { + printf("FAIL C: already allocated.\n"); + return; + } + + if (status != CFI_SUCCESS) + { + printf("FAIL C: status is %i\n",status); + } + + pt = (float *) this->base_addr; + for (i=0; i<4; i++) + { + pt[i] = Cxgl[i]; + } +} Index: Fortran/gfortran/regression/ISO_Fortran_binding_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_8.f90 @@ -0,0 +1,50 @@ +! { dg-do run { target c99_runtime } } +! { dg-additional-sources ISO_Fortran_binding_8.c } +! +! Test the fix for PR89842. +! +! Contributed by Reinhold Bader +! +module mod_alloc_01 + use, intrinsic :: iso_c_binding + implicit none + + interface + subroutine globalp(this) bind(c) + import :: c_float + real(c_float), allocatable :: this(:) + end subroutine globalp + end interface +end module mod_alloc_01 + +program alloc_01 + use mod_alloc_01 + implicit none + + real(c_float), allocatable :: myp(:) + integer :: status + + status = 0 + call globalp(myp) + +! write(*,*) 'globalp done' + if (.not. allocated(myp)) then + write(*,*) 'FAIL 1' + stop 1 + end if + if (lbound(myp,1) /= 3 .or. size(myp,1) /= 4) then + write(*,*) 'FAIL 2: ', lbound(myp), size(myp,1) + status = status + 1 + else +! write(*,*) 'Now checking data', myp(3) + if (maxval(abs(myp - [1.1, 2.3, 5.1, 4.2])) > 1.0e-6) then + write(*,*) 'FAIL 3: ', myp + status = status + 1 + end if + end if + + if (status .ne. 0) then + stop status + end if +end program alloc_01 + Index: Fortran/gfortran/regression/ISO_Fortran_binding_9.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_9.c @@ -0,0 +1,14 @@ +/* Test fix of a problem with CFI_is_contiguous. */ + +/* Contributed by Gilles Gouaillardet */ + +#include +#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: Fortran/gfortran/regression/ISO_Fortran_binding_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ISO_Fortran_binding_9.f90 @@ -0,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(IN) :: buf + integer(kind=kind(loc(res))),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: Fortran/gfortran/regression/PR100029.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100029.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! Test the fix for PR100029 +! + +program foo_p + implicit none + + type :: foo_t + end type foo_t + + class(foo_t), allocatable :: pout + + call foo_s(pout) + +contains + + subroutine foo_s(that) + class(foo_t), allocatable, intent(out) :: that(..) + end subroutine foo_s + +end program foo_p Index: Fortran/gfortran/regression/PR100040.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100040.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! Test the fix for PR100040 +! + +program foo_p + implicit none + + integer, parameter :: n = 11 + + type :: foo_t + integer :: i + end type foo_t + + type(foo_t), parameter :: a = foo_t(n) + + class(foo_t), allocatable :: pout + + call foo_s(pout) + if(.not.allocated(pout)) stop 1 + if(pout%i/=n) stop 2 + +contains + + subroutine foo_s(that) + class(foo_t), allocatable, intent(out) :: that(..) + + select rank(that) + rank(0) + that = a + rank default + stop 3 + end select + end subroutine foo_s + +end program foo_p Index: Fortran/gfortran/regression/PR100094.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100094.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! Test the fix for PR100094 +! + +program foo_p + + implicit none + + integer, parameter :: n = 11 + + integer, pointer :: pout(:) + integer, target :: a(n) + integer :: i + + a = [(i, i=1,n)] + call foo(pout) + if(.not.associated(pout)) stop 1 + if(.not.associated(pout, a)) stop 2 + if(any(pout/=a)) stop 3 + stop + +contains + + subroutine foo(that) + integer, pointer, intent(out) :: that(..) + + select rank(that) + rank(1) + that => a + rank default + stop 4 + end select + return + end subroutine foo + +end program foo_p Index: Fortran/gfortran/regression/PR100097.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100097.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR100097 +! + +program main_p + implicit none + + class(*), pointer :: bar_p(:) + class(*), allocatable :: bar_a(:) + + call foo_p(bar_p) + call foo_a(bar_a) + +contains + + subroutine foo_p(that) + class(*), pointer, intent(out) :: that(..) + + select rank(that) + rank(1) + rank default + stop 1 + end select + end subroutine foo_p + + subroutine foo_a(that) + class(*), allocatable, intent(out) :: that(..) + + select rank(that) + rank(1) + rank default + stop 2 + end select + end subroutine foo_a + +end program main_p + +! { dg-final { scan-tree-dump "bar_a._data.dtype = \\{.* .rank=1,.*\\}" "original" } } +! { dg-final { scan-tree-dump "bar_p._data.dtype = \\{.* .rank=1,.*\\}" "original" } } Index: Fortran/gfortran/regression/PR100098.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100098.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR100098 +! + +program main_p + implicit none + + type :: foo_t + integer :: i + end type foo_t + + class(foo_t), pointer :: bar_p(:) + class(foo_t), allocatable :: bar_a(:) + + call foo_p(bar_p) + call foo_a(bar_a) + +contains + + subroutine foo_p(that) + class(foo_t), pointer, intent(out) :: that(..) + + select rank(that) + rank(1) + rank default + stop 1 + end select + end subroutine foo_p + + subroutine foo_a(that) + class(foo_t), allocatable, intent(out) :: that(..) + + select rank(that) + rank(1) + rank default + stop 2 + end select + end subroutine foo_a + +end program main_p + +! { dg-final { scan-tree-dump "bar_a._data.dtype = \\{.* .rank=1,.*\\}" "original" } } +! { dg-final { scan-tree-dump "bar_p._data.dtype = \\{.* .rank=1,.*\\}" "original" } } Index: Fortran/gfortran/regression/PR100103.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100103.f90 @@ -0,0 +1,76 @@ +! { dg-do run } +! +! Test the fix for PR100103 +! + +program main_p + implicit none + + integer :: i + integer, parameter :: n = 11 + + type :: foo_t + integer :: i + end type foo_t + + type(foo_t), parameter :: a(*) = [(foo_t(i), i=1,n)] + + type(foo_t), allocatable :: bar_d(:) + class(foo_t), allocatable :: bar_p(:) + class(*), allocatable :: bar_u(:) + + + call foo_d(bar_d) + if(.not.allocated(bar_d)) stop 1 + if(any(bar_d%i/=a%i)) stop 2 + deallocate(bar_d) + call foo_p(bar_p) + if(.not.allocated(bar_p)) stop 3 + if(any(bar_p%i/=a%i)) stop 4 + deallocate(bar_p) + call foo_u(bar_u) + if(.not.allocated(bar_u)) stop 5 + select type(bar_u) + type is(foo_t) + if(any(bar_u%i/=a%i)) stop 6 + class default + stop 7 + end select + deallocate(bar_u) + +contains + + subroutine foo_d(that) + type(foo_t), allocatable, intent(out) :: that(..) + + select rank(that) + rank(1) + that = a + rank default + stop 8 + end select + end subroutine foo_d + + subroutine foo_p(that) + class(foo_t), allocatable, intent(out) :: that(..) + + select rank(that) + rank(1) + that = a + rank default + stop 9 + end select + end subroutine foo_p + + subroutine foo_u(that) + class(*), allocatable, intent(out) :: that(..) + + select rank(that) + rank(1) + that = a + rank default + stop 10 + end select + end subroutine foo_u + +end program main_p Index: Fortran/gfortran/regression/PR100120.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100120.f90 @@ -0,0 +1,198 @@ +! { dg-do run } +! +! Tests fix for PR100120 +! + +program main_p + + implicit none + + integer, parameter :: n = 11 + integer, parameter :: m = 7 + integer, parameter :: c = 63 + + type :: foo_t + integer :: i + end type foo_t + + type, extends(foo_t) :: bar_t + integer :: j(n) + end type bar_t + + integer, target :: ain(n) + character, target :: ac1(n) + character(len=m), target :: acn(n) + type(foo_t), target :: afd(n) + type(bar_t), target :: abd(n) + ! + class(foo_t), pointer :: spf + class(foo_t), pointer :: apf(:) + class(bar_t), pointer :: spb + class(bar_t), pointer :: apb(:) + class(*), pointer :: spu + class(*), pointer :: apu(:) + integer :: i, j + + ain = [(i, i=1,n)] + ac1 = [(achar(i+c), i=1,n)] + do i = 1, n + do j = 1, m + acn(i)(j:j) = achar(i*m+j+c-m) + end do + end do + afd%i = ain + abd%i = ain + do i = 1, n + abd(i)%j = 2*i*ain + end do + ! + spf => afd(n) + if(.not.associated(spf)) stop 1 + if(.not.associated(spf, afd(n))) stop 2 + if(spf%i/=n) stop 3 + apf => afd + if(.not.associated(apf)) stop 4 + if(.not.associated(apf, afd)) stop 5 + if(any(apf%i/=afd%i)) stop 6 + ! + spf => abd(n) + if(.not.associated(spf)) stop 7 + if(.not.associated(spf, abd(n))) stop 8 + if(spf%i/=n) stop 9 + select type(spf) + type is(bar_t) + if(any(spf%j/=2*n*ain)) stop 10 + class default + stop 11 + end select + apf => abd + if(.not.associated(apf)) stop 12 + if(.not.associated(apf, abd)) stop 13 + if(any(apf%i/=abd%i)) stop 14 + select type(apf) + type is(bar_t) + do i = 1, n + if(any(apf(i)%j/=2*i*ain)) stop 15 + end do + class default + stop 16 + end select + ! + spb => abd(n) + if(.not.associated(spb)) stop 17 + if(.not.associated(spb, abd(n))) stop 18 + if(spb%i/=n) stop 19 + if(any(spb%j/=2*n*ain)) stop 20 + apb => abd + if(.not.associated(apb)) stop 21 + if(.not.associated(apb, abd)) stop 22 + if(any(apb%i/=abd%i)) stop 23 + do i = 1, n + if(any(apb(i)%j/=2*i*ain)) stop 24 + end do + ! + spu => ain(n) + if(.not.associated(spu)) stop 25 + if(.not.associated(spu, ain(n))) stop 26 + select type(spu) + type is(integer) + if(spu/=n) stop 27 + class default + stop 28 + end select + apu => ain + if(.not.associated(apu)) stop 29 + if(.not.associated(apu, ain)) stop 30 + select type(apu) + type is(integer) + if(any(apu/=ain)) stop 31 + class default + stop 32 + end select + ! + spu => ac1(n) + if(.not.associated(spu)) stop 33 + if(.not.associated(spu, ac1(n))) stop 34 + select type(spu) + type is(character(len=*)) + if(len(spu)/=1) stop 35 + if(spu/=ac1(n)) stop 36 + class default + stop 37 + end select + apu => ac1 + if(.not.associated(apu)) stop 38 + if(.not.associated(apu, ac1)) stop 39 + select type(apu) + type is(character(len=*)) + if(len(apu)/=1) stop 40 + if(any(apu/=ac1)) stop 41 + class default + stop 42 + end select + ! + spu => acn(n) + if(.not.associated(spu)) stop 43 + if(.not.associated(spu, acn(n))) stop 44 + select type(spu) + type is(character(len=*)) + if(len(spu)/=m) stop 45 + if(spu/=acn(n)) stop 46 + class default + stop 47 + end select + apu => acn + if(.not.associated(apu)) stop 48 + if(.not.associated(apu, acn)) stop 49 + select type(apu) + type is(character(len=*)) + if(len(apu)/=m) stop 50 + if(any(apu/=acn)) stop 51 + class default + stop 52 + end select + ! + spu => afd(n) + if(.not.associated(spu)) stop 53 + if(.not.associated(spu, afd(n))) stop 54 + select type(spu) + type is(foo_t) + if(spu%i/=n) stop 55 + class default + stop 56 + end select + apu => afd + if(.not.associated(apu)) stop 57 + if(.not.associated(apu, afd)) stop 58 + select type(apu) + type is(foo_t) + if(any(apu%i/=afd%i)) stop 59 + class default + stop 60 + end select + ! + spu => abd(n) + if(.not.associated(spu)) stop 61 + if(.not.associated(spu, abd(n))) stop 62 + select type(spu) + type is(bar_t) + if(spu%i/=n) stop 63 + if(any(spu%j/=2*n*ain)) stop 64 + class default + stop 65 + end select + apu => abd + if(.not.associated(apu)) stop 66 + if(.not.associated(apu, abd)) stop 67 + select type(apu) + type is(bar_t) + if(any(apu%i/=abd%i)) stop 68 + do i = 1, n + if(any(apu(i)%j/=2*i*ain)) stop 69 + end do + class default + stop 70 + end select + stop + +end program main_p Index: Fortran/gfortran/regression/PR100132.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100132.f90 @@ -0,0 +1,75 @@ +! { dg-do run } +! +! Test the fix for PR100132 +! + +module main_m + implicit none + + private + + public :: & + foo_t + + public :: & + set, & + get + + type :: foo_t + integer :: i + end type foo_t + + type(foo_t), save, pointer :: data => null() + +contains + + subroutine set(this) + class(foo_t), pointer, intent(in) :: this + + if(associated(data)) stop 1 + data => this + end subroutine set + + subroutine get(this) + type(foo_t), pointer, intent(out) :: this + + if(.not.associated(data)) stop 4 + this => data + nullify(data) + end subroutine get + +end module main_m + +program main_p + + use :: main_m, only: & + foo_t, set, get + + implicit none + + integer, parameter :: n = 1000 + + type(foo_t), pointer :: ps + type(foo_t), target :: s + integer :: i, j, yay, nay + + yay = 0 + nay = 0 + do i = 1, n + s%i = i + call set(s) + call get(ps) + if(.not.associated(ps)) stop 13 + j = ps%i + if(i/=j) stop 14 + if(i/=s%i) stop 15 + if(ps%i/=s%i) stop 16 + if(associated(ps, s))then + yay = yay + 1 + else + nay = nay + 1 + end if + end do + if((yay/=n).or.(nay/=0)) stop 17 + +end program main_p Index: Fortran/gfortran/regression/PR100136.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100136.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-options "-fcheck=pointer" } +! { dg-shouldfail "Argument not allocated" } +! { dg-output "Fortran runtime error: Allocatable actual argument 'c_init2' is not allocated" } +! +! Tests fix for PR100136 +! +! Test cut down from PR58586 +! + +module test_pr58586_mod + implicit none + + type :: a + end type + + type :: c + type(a), allocatable :: a + end type + +contains + + subroutine add_class_c (d) + class(c), value :: d + end subroutine + + class(c) function c_init2() + allocatable :: c_init2 + end function + +end module test_pr58586_mod + +program test_pr58586 + use test_pr58586_mod + + ! This needs to execute, to see whether the segfault at runtime is resolved + call add_class_c(c_init2()) + +end program Index: Fortran/gfortran/regression/PR10018.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR10018.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +subroutine foo(that) + implicit none + class(*), target, intent(in) :: this + class(*), pointer, intent(out) :: that + + that => this + return +end subroutine foo +! { dg-error "Symbol at \\\(1\\\) is not a DUMMY variable" "" { target "*-*-*" } 5 } Index: Fortran/gfortran/regression/PR100245.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100245.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! Test the fix for PR100245 +! + +program main_p + + implicit none + + type :: foo_t + integer :: a + end type foo_t + + integer, parameter :: a = 42 + + class(foo_t), allocatable :: val + class(foo_t), allocatable :: rs1 + type(foo_t), allocatable :: rs2 + + allocate(val, source=foo_t(42)) + if (val%a/=a) stop 1 + rs1 = val + if (rs1%a/=a) stop 2 + rs2 = val + if (rs2%a/=a) stop 3 + deallocate(val, rs1, rs2) + +end program main_p Index: Fortran/gfortran/regression/PR100906.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100906.c @@ -0,0 +1,169 @@ +/* Test the fix for PR100906 */ + +#include +#include +#include +#include +/* #include */ + +#include + +#define _CFI_type_mask 0xFF +#define _CFI_type_kind_shift 8 + +#define _CFI_decode_type(NAME) (signed char)((NAME) & CFI_type_mask) +#define _CFI_decode_kind(NAME) (signed char)(((NAME) >> CFI_type_kind_shift) & CFI_type_mask) + +#define _CFI_encode_type(TYPE, KIND) (int16_t)\ +((((KIND) & CFI_type_mask) << CFI_type_kind_shift)\ + | ((TYPE) & CFI_type_mask)) + +#define N 11 +#define M 7 + +typedef char c_char; +/* typedef char32_t c_ucs4_char; */ +typedef uint32_t char32_t; +typedef uint32_t c_ucs4_char; + +bool charcmp (char *, char, size_t); + +bool ucharcmp (char32_t *, char32_t, size_t); + +bool c_vrfy_c_char (const CFI_cdesc_t *restrict, const size_t); + +bool c_vrfy_c_ucs4_char (const CFI_cdesc_t *restrict, const size_t); + +bool c_vrfy_character (const CFI_cdesc_t *restrict, const size_t); + +void check_tk (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t); + +bool +charcmp (char *c, char v, size_t n) +{ + bool res = true; + char b = (char)'A'; + size_t i; + + for (i=0; ((ibase_addr); + assert (auxp->elem_len>0); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + assert (ex==N); + sz = (size_t)auxp->elem_len / sizeof (c_char); + assert (sz==len); + ub = ex + lb - 1; + ip = (c_char*)auxp->base_addr; + for (i=0; ibase_addr); + assert (auxp->elem_len>0); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + assert (ex==N); + sz = (size_t)auxp->elem_len / sizeof (c_ucs4_char); + assert (sz==len); + ub = ex + lb - 1; + ip = (c_ucs4_char*)auxp->base_addr; + for (i=0; itype); + kind = _CFI_decode_kind(auxp->type); + assert (type == CFI_type_Character); + switch (kind) + { + case 1: + return c_vrfy_c_char (auxp, len); + break; + case 4: + return c_vrfy_c_ucs4_char (auxp, len); + break; + default: + assert (false); + } + return true; +} + +void +check_tk (const CFI_cdesc_t *restrict auxp, const CFI_type_t type, const signed char kind, const size_t elem_len, const size_t nelem) +{ + signed char ityp, iknd; + + assert (auxp); + assert (auxp->elem_len==elem_len*nelem); + assert (auxp->rank==1); + assert (auxp->dim[0].sm>0); + assert ((size_t)auxp->dim[0].sm==elem_len*nelem); + /* */ + assert (auxp->type==type); + ityp = _CFI_decode_type(auxp->type); + assert (ityp == CFI_type_Character); + iknd = _CFI_decode_kind(auxp->type); + assert (_CFI_decode_type(type)==ityp); + assert (kind==iknd); + assert (c_vrfy_character (auxp, nelem)); + return; +} + +// Local Variables: +// mode: C +// End: Index: Fortran/gfortran/regression/PR100906.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100906.f90 @@ -0,0 +1,1699 @@ +! { dg-do run } +! { dg-additional-sources PR100906.c } +! +! Test the fix for PR100906 +! + +module isof_m + + use, intrinsic :: iso_c_binding, only: & + c_signed_char, c_int16_t + + implicit none + + private + + public :: & + CFI_type_character + + public :: & + CFI_type_char, & + CFI_type_ucs4_char + + public :: & + check_tk_as, & + check_tk_ar + + + public :: & + cfi_encode_type + + integer, parameter :: CFI_type_t = c_int16_t + + integer(kind=c_int16_t), parameter :: CFI_type_mask = int(z"FF", kind=c_int16_t) + integer(kind=c_int16_t), parameter :: CFI_type_kind_shift = 8_c_int16_t + + ! Intrinsic types. Their kind number defines their storage size. */ + integer(kind=c_signed_char), parameter :: CFI_type_Character = 5 + + ! C-Fortran Interoperability types. + integer(kind=cfi_type_t), parameter :: CFI_type_char = & + ior(int(CFI_type_Character, kind=c_int16_t), shiftl(1_c_int16_t, CFI_type_kind_shift)) + integer(kind=cfi_type_t), parameter :: CFI_type_ucs4_char = & + ior(int(CFI_type_Character, kind=c_int16_t), shiftl(4_c_int16_t, CFI_type_kind_shift)) + + interface + subroutine check_tk_as(a, t, k, e, n) & + bind(c, name="check_tk") + use, intrinsic :: iso_c_binding, only: & + c_int16_t, c_signed_char, c_size_t + implicit none + type(*), intent(in) :: a(:) + integer(c_int16_t), value, intent(in) :: t + integer(c_signed_char), value, intent(in) :: k + integer(c_size_t), value, intent(in) :: e + integer(c_size_t), value, intent(in) :: n + end subroutine check_tk_as + subroutine check_tk_ar(a, t, k, e, n) & + bind(c, name="check_tk") + use, intrinsic :: iso_c_binding, only: & + c_int16_t, c_signed_char, c_size_t + implicit none + type(*), intent(in) :: a(..) + integer(c_int16_t), value, intent(in) :: t + integer(c_signed_char), value, intent(in) :: k + integer(c_size_t), value, intent(in) :: e + integer(c_size_t), value, intent(in) :: n + end subroutine check_tk_ar + end interface + +contains + + elemental function cfi_encode_type(type, kind) result(itype) + integer(kind=c_signed_char), intent(in) :: type + integer(kind=c_signed_char), intent(in) :: kind + + integer(kind=c_int16_t) :: itype, ikind + + itype = int(type, kind=c_int16_t) + itype = iand(itype, CFI_type_mask) + ikind = int(kind, kind=c_int16_t) + ikind = iand(ikind, CFI_type_mask) + ikind = shiftl(ikind, CFI_type_kind_shift) + itype = ior(ikind, itype) + return + end function cfi_encode_type + +end module isof_m + +module iso_check_m + + use, intrinsic :: iso_c_binding, only: & + c_signed_char, c_int16_t, c_size_t + + use, intrinsic :: iso_c_binding, only: & + c_char + + use :: isof_m, only: & + CFI_type_character + + use :: isof_m, only: & + CFI_type_char, & + CFI_type_ucs4_char + + use :: isof_m, only: & + check_tk_as, & + check_tk_ar + + use :: isof_m, only: & + cfi_encode_type + + implicit none + + private + + public :: & + check_c_char_l1, & + check_c_char_lm, & + check_c_ucs4_char_l1, & + check_c_ucs4_char_lm + + integer :: i + integer(kind=c_size_t), parameter :: b = 8 + integer, parameter :: n = 11 + integer, parameter :: m = 7 + + integer, parameter :: c_ucs4_char = 4 + + character(kind=c_char, len=1), parameter :: ref_c_char_l1(*) = & + [(achar(i+iachar("A")-1, kind=c_char), i=1,n)] + character(kind=c_char, len=m), parameter :: ref_c_char_lm(*) = & + [(repeat(achar(i+iachar("A")-1, kind=c_char), m), i=1,n)] + character(kind=c_ucs4_char, len=1), parameter :: ref_c_ucs4_char_l1(*) = & + [(achar(i+iachar("A")-1, kind=c_ucs4_char), i=1,n)] + character(kind=c_ucs4_char, len=m), parameter :: ref_c_ucs4_char_lm(*) = & + [(repeat(achar(i+iachar("A")-1, kind=c_ucs4_char), m), i=1,n)] + +contains + + subroutine check_c_char_l1() + character(kind=c_char, len=1), target :: a(n) + ! + character(kind=c_char, len=:), pointer :: p(:) + ! + a = ref_c_char_l1 + call f_check_c_char_c1_as(a) + if(any(a/=ref_c_char_l1)) stop 1 + a = ref_c_char_l1 + call c_check_c_char_c1_as(a) + if(any(a/=ref_c_char_l1)) stop 2 + a = ref_c_char_l1 + call f_check_c_char_c1_ar(a) + if(any(a/=ref_c_char_l1)) stop 3 + a = ref_c_char_l1 + call c_check_c_char_c1_ar(a) + if(any(a/=ref_c_char_l1)) stop 4 + a = ref_c_char_l1 + call f_check_c_char_a1_as(a) + if(any(a/=ref_c_char_l1)) stop 5 + a = ref_c_char_l1 + call c_check_c_char_a1_as(a) + if(any(a/=ref_c_char_l1)) stop 6 + a = ref_c_char_l1 + call f_check_c_char_a1_ar(a) + if(any(a/=ref_c_char_l1)) stop 7 + a = ref_c_char_l1 + call c_check_c_char_a1_ar(a) + if(any(a/=ref_c_char_l1)) stop 8 + a = ref_c_char_l1 + p => a + call f_check_c_char_d1_as(p) + if(.not.associated(p)) stop 9 + if(.not.associated(p, a)) stop 10 + if(any(p/=ref_c_char_l1)) stop 11 + if(any(a/=ref_c_char_l1)) stop 12 + a = ref_c_char_l1 + p => a + call c_check_c_char_d1_as(p) + if(.not.associated(p)) stop 13 + if(.not.associated(p, a)) stop 14 + if(any(p/=ref_c_char_l1)) stop 15 + if(any(a/=ref_c_char_l1)) stop 16 + a = ref_c_char_l1 + p => a + call f_check_c_char_d1_ar(p) + if(.not.associated(p)) stop 17 + if(.not.associated(p, a)) stop 18 + if(any(p/=ref_c_char_l1)) stop 19 + if(any(a/=ref_c_char_l1)) stop 20 + a = ref_c_char_l1 + p => a + call c_check_c_char_d1_ar(p) + if(.not.associated(p)) stop 21 + if(.not.associated(p, a)) stop 22 + if(any(p/=ref_c_char_l1)) stop 23 + if(any(a/=ref_c_char_l1)) stop 24 + return + end subroutine check_c_char_l1 + + subroutine f_check_c_char_c1_as(a) + character(kind=c_char, len=1), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 25 + if(k/=1_c_signed_char) stop 26 + if(n/=1) stop 27 + if(int(k, kind=c_size_t)/=e) stop 28 + if(t/=CFI_type_char) stop 29 + if(any(a/=ref_c_char_l1)) stop 30 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_l1)) stop 31 + return + end subroutine f_check_c_char_c1_as + + subroutine c_check_c_char_c1_as(a) bind(c) + character(kind=c_char, len=1), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 32 + if(k/=1_c_signed_char) stop 33 + if(n/=1) stop 34 + if(int(k, kind=c_size_t)/=e) stop 35 + if(t/=CFI_type_char) stop 36 + if(any(a/=ref_c_char_l1)) stop 37 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_l1)) stop 38 + return + end subroutine c_check_c_char_c1_as + + subroutine f_check_c_char_c1_ar(a) + character(kind=c_char, len=1), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 39 + if(k/=1_c_signed_char) stop 40 + if(n/=1) stop 41 + if(int(k, kind=c_size_t)/=e) stop 42 + if(t/=CFI_type_char) stop 43 + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 44 + rank default + stop 45 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 46 + rank default + stop 47 + end select + return + end subroutine f_check_c_char_c1_ar + + subroutine c_check_c_char_c1_ar(a) bind(c) + character(kind=c_char, len=1), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 48 + if(k/=1_c_signed_char) stop 49 + if(n/=1) stop 50 + if(int(k, kind=c_size_t)/=e) stop 51 + if(t/=CFI_type_char) stop 52 + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 53 + rank default + stop 54 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 55 + rank default + stop 56 + end select + return + end subroutine c_check_c_char_c1_ar + + subroutine f_check_c_char_a1_as(a) + character(kind=c_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 57 + if(k/=1_c_signed_char) stop 58 + if(n/=1) stop 59 + if(int(k, kind=c_size_t)/=e) stop 60 + if(t/=CFI_type_char) stop 61 + if(any(a/=ref_c_char_l1)) stop 62 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_l1)) stop 63 + return + end subroutine f_check_c_char_a1_as + + subroutine c_check_c_char_a1_as(a) bind(c) + character(kind=c_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 64 + if(k/=1_c_signed_char) stop 65 + if(n/=1) stop 66 + if(int(k, kind=c_size_t)/=e) stop 67 + if(t/=CFI_type_char) stop 68 + if(any(a/=ref_c_char_l1)) stop 69 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_l1)) stop 70 + return + end subroutine c_check_c_char_a1_as + + subroutine f_check_c_char_a1_ar(a) + character(kind=c_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 71 + if(k/=1_c_signed_char) stop 72 + if(n/=1) stop 73 + if(int(k, kind=c_size_t)/=e) stop 74 + if(t/=CFI_type_char) stop 75 + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 76 + rank default + stop 77 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 78 + rank default + stop 79 + end select + return + end subroutine f_check_c_char_a1_ar + + subroutine c_check_c_char_a1_ar(a) bind(c) + character(kind=c_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 80 + if(k/=1_c_signed_char) stop 81 + if(n/=1) stop 82 + if(int(k, kind=c_size_t)/=e) stop 83 + if(t/=CFI_type_char) stop 84 + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 85 + rank default + stop 86 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 87 + rank default + stop 88 + end select + return + end subroutine c_check_c_char_a1_ar + + subroutine f_check_c_char_d1_as(a) + character(kind=c_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 89 + if(k/=1_c_signed_char) stop 90 + if(n/=1) stop 91 + if(int(k, kind=c_size_t)/=e) stop 92 + if(t/=CFI_type_char) stop 93 + if(any(a/=ref_c_char_l1)) stop 94 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_l1)) stop 95 + return + end subroutine f_check_c_char_d1_as + + subroutine c_check_c_char_d1_as(a) bind(c) + character(kind=c_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 96 + if(k/=1_c_signed_char) stop 97 + if(n/=1) stop 98 + if(int(k, kind=c_size_t)/=e) stop 99 + if(t/=CFI_type_char) stop 100 + if(any(a/=ref_c_char_l1)) stop 101 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_l1)) stop 102 + return + end subroutine c_check_c_char_d1_as + + subroutine f_check_c_char_d1_ar(a) + character(kind=c_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 103 + if(k/=1_c_signed_char) stop 104 + if(n/=1) stop 105 + if(int(k, kind=c_size_t)/=e) stop 106 + if(t/=CFI_type_char) stop 107 + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 108 + rank default + stop 109 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 110 + rank default + stop 111 + end select + return + end subroutine f_check_c_char_d1_ar + + subroutine c_check_c_char_d1_ar(a) bind(c) + character(kind=c_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 112 + if(k/=1_c_signed_char) stop 113 + if(n/=1) stop 114 + if(int(k, kind=c_size_t)/=e) stop 115 + if(t/=CFI_type_char) stop 116 + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 117 + rank default + stop 118 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 119 + rank default + stop 120 + end select + return + end subroutine c_check_c_char_d1_ar + + subroutine check_c_char_lm() + character(kind=c_char, len=m), target :: a(n) + ! + character(kind=c_char, len=:), pointer :: p(:) + ! + a = ref_c_char_lm + call f_check_c_char_cm_as(a) + if(any(a/=ref_c_char_lm)) stop 121 + a = ref_c_char_lm + call c_check_c_char_cm_as(a) + if(any(a/=ref_c_char_lm)) stop 122 + a = ref_c_char_lm + call f_check_c_char_cm_ar(a) + if(any(a/=ref_c_char_lm)) stop 123 + a = ref_c_char_lm + call c_check_c_char_cm_ar(a) + if(any(a/=ref_c_char_lm)) stop 124 + a = ref_c_char_lm + call f_check_c_char_am_as(a) + if(any(a/=ref_c_char_lm)) stop 125 + a = ref_c_char_lm + call c_check_c_char_am_as(a) + if(any(a/=ref_c_char_lm)) stop 126 + a = ref_c_char_lm + call f_check_c_char_am_ar(a) + if(any(a/=ref_c_char_lm)) stop 127 + a = ref_c_char_lm + call c_check_c_char_am_ar(a) + if(any(a/=ref_c_char_lm)) stop 128 + a = ref_c_char_lm + p => a + call f_check_c_char_dm_as(p) + if(.not.associated(p)) stop 129 + if(.not.associated(p, a)) stop 130 + if(any(p/=ref_c_char_lm)) stop 131 + if(any(a/=ref_c_char_lm)) stop 132 + a = ref_c_char_lm + p => a + call c_check_c_char_dm_as(p) + if(.not.associated(p)) stop 133 + if(.not.associated(p, a)) stop 134 + if(any(p/=ref_c_char_lm)) stop 135 + if(any(a/=ref_c_char_lm)) stop 136 + a = ref_c_char_lm + p => a + call f_check_c_char_dm_ar(p) + if(.not.associated(p)) stop 137 + if(.not.associated(p, a)) stop 138 + if(any(p/=ref_c_char_lm)) stop 139 + if(any(a/=ref_c_char_lm)) stop 140 + a = ref_c_char_lm + p => a + call c_check_c_char_dm_ar(p) + if(.not.associated(p)) stop 141 + if(.not.associated(p, a)) stop 142 + if(any(p/=ref_c_char_lm)) stop 143 + if(any(a/=ref_c_char_lm)) stop 144 + return + end subroutine check_c_char_lm + + subroutine f_check_c_char_cm_as(a) + character(kind=c_char, len=m), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 145 + if(k/=1_c_signed_char) stop 146 + if(n/=m) stop 147 + if(int(k, kind=c_size_t)/=e) stop 148 + if(t/=CFI_type_char) stop 149 + if(any(a/=ref_c_char_lm)) stop 150 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_lm)) stop 151 + return + end subroutine f_check_c_char_cm_as + + subroutine c_check_c_char_cm_as(a) bind(c) + character(kind=c_char, len=m), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 152 + if(k/=1_c_signed_char) stop 153 + if(n/=m) stop 154 + if(int(k, kind=c_size_t)/=e) stop 155 + if(t/=CFI_type_char) stop 156 + if(any(a/=ref_c_char_lm)) stop 157 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_lm)) stop 158 + return + end subroutine c_check_c_char_cm_as + + subroutine f_check_c_char_cm_ar(a) + character(kind=c_char, len=m), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 159 + if(k/=1_c_signed_char) stop 160 + if(n/=m) stop 161 + if(int(k, kind=c_size_t)/=e) stop 162 + if(t/=CFI_type_char) stop 163 + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 164 + rank default + stop 165 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 166 + rank default + stop 167 + end select + return + end subroutine f_check_c_char_cm_ar + + subroutine c_check_c_char_cm_ar(a) bind(c) + character(kind=c_char, len=m), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 168 + if(k/=1_c_signed_char) stop 169 + if(n/=m) stop 170 + if(int(k, kind=c_size_t)/=e) stop 171 + if(t/=CFI_type_char) stop 172 + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 173 + rank default + stop 174 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 175 + rank default + stop 176 + end select + return + end subroutine c_check_c_char_cm_ar + + subroutine f_check_c_char_am_as(a) + character(kind=c_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 177 + if(k/=1_c_signed_char) stop 178 + if(n/=m) stop 179 + if(int(k, kind=c_size_t)/=e) stop 180 + if(t/=CFI_type_char) stop 181 + if(any(a/=ref_c_char_lm)) stop 182 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_lm)) stop 183 + return + end subroutine f_check_c_char_am_as + + subroutine c_check_c_char_am_as(a) bind(c) + character(kind=c_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 184 + if(k/=1_c_signed_char) stop 185 + if(n/=m) stop 186 + if(int(k, kind=c_size_t)/=e) stop 187 + if(t/=CFI_type_char) stop 188 + if(any(a/=ref_c_char_lm)) stop 189 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_lm)) stop 190 + return + end subroutine c_check_c_char_am_as + + subroutine f_check_c_char_am_ar(a) + character(kind=c_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 191 + if(k/=1_c_signed_char) stop 192 + if(n/=m) stop 193 + if(int(k, kind=c_size_t)/=e) stop 194 + if(t/=CFI_type_char) stop 195 + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 196 + rank default + stop 197 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 198 + rank default + stop 199 + end select + return + end subroutine f_check_c_char_am_ar + + subroutine c_check_c_char_am_ar(a) bind(c) + character(kind=c_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 200 + if(k/=1_c_signed_char) stop 201 + if(n/=m) stop 202 + if(int(k, kind=c_size_t)/=e) stop 203 + if(t/=CFI_type_char) stop 204 + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 205 + rank default + stop 206 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 207 + rank default + stop 208 + end select + return + end subroutine c_check_c_char_am_ar + + subroutine f_check_c_char_dm_as(a) + character(kind=c_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 209 + if(k/=1_c_signed_char) stop 210 + if(n/=m) stop 211 + if(int(k, kind=c_size_t)/=e) stop 212 + if(t/=CFI_type_char) stop 213 + if(any(a/=ref_c_char_lm)) stop 214 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_lm)) stop 215 + return + end subroutine f_check_c_char_dm_as + + subroutine c_check_c_char_dm_as(a) bind(c) + character(kind=c_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 216 + if(k/=1_c_signed_char) stop 217 + if(n/=m) stop 218 + if(int(k, kind=c_size_t)/=e) stop 219 + if(t/=CFI_type_char) stop 220 + if(any(a/=ref_c_char_lm)) stop 221 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_lm)) stop 222 + return + end subroutine c_check_c_char_dm_as + + subroutine f_check_c_char_dm_ar(a) + character(kind=c_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 223 + if(k/=1_c_signed_char) stop 224 + if(n/=m) stop 225 + if(int(k, kind=c_size_t)/=e) stop 226 + if(t/=CFI_type_char) stop 227 + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 228 + rank default + stop 229 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 230 + rank default + stop 231 + end select + return + end subroutine f_check_c_char_dm_ar + + subroutine c_check_c_char_dm_ar(a) bind(c) + character(kind=c_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 232 + if(k/=1_c_signed_char) stop 233 + if(n/=m) stop 234 + if(int(k, kind=c_size_t)/=e) stop 235 + if(t/=CFI_type_char) stop 236 + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 237 + rank default + stop 238 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 239 + rank default + stop 240 + end select + return + end subroutine c_check_c_char_dm_ar + + subroutine check_c_ucs4_char_l1() + character(kind=c_ucs4_char, len=1), target :: a(n) + ! + character(kind=c_ucs4_char, len=:), pointer :: p(:) + ! + a = ref_c_ucs4_char_l1 + call f_check_c_ucs4_char_c1_as(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 241 + a = ref_c_ucs4_char_l1 + call c_check_c_ucs4_char_c1_as(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 242 + a = ref_c_ucs4_char_l1 + call f_check_c_ucs4_char_c1_ar(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 243 + a = ref_c_ucs4_char_l1 + call c_check_c_ucs4_char_c1_ar(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 244 + a = ref_c_ucs4_char_l1 + call f_check_c_ucs4_char_a1_as(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 245 + a = ref_c_ucs4_char_l1 + call c_check_c_ucs4_char_a1_as(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 246 + a = ref_c_ucs4_char_l1 + call f_check_c_ucs4_char_a1_ar(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 247 + a = ref_c_ucs4_char_l1 + call c_check_c_ucs4_char_a1_ar(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 248 + a = ref_c_ucs4_char_l1 + p => a + call f_check_c_ucs4_char_d1_as(p) + if(.not.associated(p)) stop 249 + if(.not.associated(p, a)) stop 250 + if(any(p/=ref_c_ucs4_char_l1)) stop 251 + if(any(a/=ref_c_ucs4_char_l1)) stop 252 + a = ref_c_ucs4_char_l1 + p => a + call c_check_c_ucs4_char_d1_as(p) + if(.not.associated(p)) stop 253 + if(.not.associated(p, a)) stop 254 + if(any(p/=ref_c_ucs4_char_l1)) stop 255 + if(any(a/=ref_c_ucs4_char_l1)) stop 256 + a = ref_c_ucs4_char_l1 + p => a + call f_check_c_ucs4_char_d1_ar(p) + if(.not.associated(p)) stop 257 + if(.not.associated(p, a)) stop 258 + if(any(p/=ref_c_ucs4_char_l1)) stop 259 + if(any(a/=ref_c_ucs4_char_l1)) stop 260 + a = ref_c_ucs4_char_l1 + p => a + call c_check_c_ucs4_char_d1_ar(p) + if(.not.associated(p)) stop 261 + if(.not.associated(p, a)) stop 262 + if(any(p/=ref_c_ucs4_char_l1)) stop 263 + if(any(a/=ref_c_ucs4_char_l1)) stop 264 + return + end subroutine check_c_ucs4_char_l1 + + subroutine f_check_c_ucs4_char_c1_as(a) + character(kind=c_ucs4_char, len=1), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 265 + if(k/=4_c_signed_char) stop 266 + if(n/=1) stop 267 + if(int(k, kind=c_size_t)/=e) stop 268 + if(t/=CFI_type_ucs4_char) stop 269 + if(any(a/=ref_c_ucs4_char_l1)) stop 270 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_l1)) stop 271 + return + end subroutine f_check_c_ucs4_char_c1_as + + subroutine c_check_c_ucs4_char_c1_as(a) bind(c) + character(kind=c_ucs4_char, len=1), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 272 + if(k/=4_c_signed_char) stop 273 + if(n/=1) stop 274 + if(int(k, kind=c_size_t)/=e) stop 275 + if(t/=CFI_type_ucs4_char) stop 276 + if(any(a/=ref_c_ucs4_char_l1)) stop 277 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_l1)) stop 278 + return + end subroutine c_check_c_ucs4_char_c1_as + + subroutine f_check_c_ucs4_char_c1_ar(a) + character(kind=c_ucs4_char, len=1), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 279 + if(k/=4_c_signed_char) stop 280 + if(n/=1) stop 281 + if(int(k, kind=c_size_t)/=e) stop 282 + if(t/=CFI_type_ucs4_char) stop 283 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 284 + rank default + stop 285 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 286 + rank default + stop 287 + end select + return + end subroutine f_check_c_ucs4_char_c1_ar + + subroutine c_check_c_ucs4_char_c1_ar(a) bind(c) + character(kind=c_ucs4_char, len=1), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 288 + if(k/=4_c_signed_char) stop 289 + if(n/=1) stop 290 + if(int(k, kind=c_size_t)/=e) stop 291 + if(t/=CFI_type_ucs4_char) stop 292 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 293 + rank default + stop 294 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 295 + rank default + stop 296 + end select + return + end subroutine c_check_c_ucs4_char_c1_ar + + subroutine f_check_c_ucs4_char_a1_as(a) + character(kind=c_ucs4_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 297 + if(k/=4_c_signed_char) stop 298 + if(n/=1) stop 299 + if(int(k, kind=c_size_t)/=e) stop 300 + if(t/=CFI_type_ucs4_char) stop 301 + if(any(a/=ref_c_ucs4_char_l1)) stop 302 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_l1)) stop 303 + return + end subroutine f_check_c_ucs4_char_a1_as + + subroutine c_check_c_ucs4_char_a1_as(a) bind(c) + character(kind=c_ucs4_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 304 + if(k/=4_c_signed_char) stop 305 + if(n/=1) stop 306 + if(int(k, kind=c_size_t)/=e) stop 307 + if(t/=CFI_type_ucs4_char) stop 308 + if(any(a/=ref_c_ucs4_char_l1)) stop 309 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_l1)) stop 310 + return + end subroutine c_check_c_ucs4_char_a1_as + + subroutine f_check_c_ucs4_char_a1_ar(a) + character(kind=c_ucs4_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 311 + if(k/=4_c_signed_char) stop 312 + if(n/=1) stop 313 + if(int(k, kind=c_size_t)/=e) stop 314 + if(t/=CFI_type_ucs4_char) stop 315 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 316 + rank default + stop 317 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 318 + rank default + stop 319 + end select + return + end subroutine f_check_c_ucs4_char_a1_ar + + subroutine c_check_c_ucs4_char_a1_ar(a) bind(c) + character(kind=c_ucs4_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 320 + if(k/=4_c_signed_char) stop 321 + if(n/=1) stop 322 + if(int(k, kind=c_size_t)/=e) stop 323 + if(t/=CFI_type_ucs4_char) stop 324 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 325 + rank default + stop 326 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 327 + rank default + stop 328 + end select + return + end subroutine c_check_c_ucs4_char_a1_ar + + subroutine f_check_c_ucs4_char_d1_as(a) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 329 + if(k/=4_c_signed_char) stop 330 + if(n/=1) stop 331 + if(int(k, kind=c_size_t)/=e) stop 332 + if(t/=CFI_type_ucs4_char) stop 333 + if(any(a/=ref_c_ucs4_char_l1)) stop 334 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_l1)) stop 335 + return + end subroutine f_check_c_ucs4_char_d1_as + + subroutine c_check_c_ucs4_char_d1_as(a) bind(c) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 336 + if(k/=4_c_signed_char) stop 337 + if(n/=1) stop 338 + if(int(k, kind=c_size_t)/=e) stop 339 + if(t/=CFI_type_ucs4_char) stop 340 + if(any(a/=ref_c_ucs4_char_l1)) stop 341 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_l1)) stop 342 + return + end subroutine c_check_c_ucs4_char_d1_as + + subroutine f_check_c_ucs4_char_d1_ar(a) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 343 + if(k/=4_c_signed_char) stop 344 + if(n/=1) stop 345 + if(int(k, kind=c_size_t)/=e) stop 346 + if(t/=CFI_type_ucs4_char) stop 347 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 348 + rank default + stop 349 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 350 + rank default + stop 351 + end select + return + end subroutine f_check_c_ucs4_char_d1_ar + + subroutine c_check_c_ucs4_char_d1_ar(a) bind(c) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 352 + if(k/=4_c_signed_char) stop 353 + if(n/=1) stop 354 + if(int(k, kind=c_size_t)/=e) stop 355 + if(t/=CFI_type_ucs4_char) stop 356 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 357 + rank default + stop 358 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 359 + rank default + stop 360 + end select + return + end subroutine c_check_c_ucs4_char_d1_ar + + subroutine check_c_ucs4_char_lm() + character(kind=c_ucs4_char, len=m), target :: a(n) + ! + character(kind=c_ucs4_char, len=:), pointer :: p(:) + ! + a = ref_c_ucs4_char_lm + call f_check_c_ucs4_char_cm_as(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 361 + a = ref_c_ucs4_char_lm + call c_check_c_ucs4_char_cm_as(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 362 + a = ref_c_ucs4_char_lm + call f_check_c_ucs4_char_cm_ar(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 363 + a = ref_c_ucs4_char_lm + call c_check_c_ucs4_char_cm_ar(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 364 + a = ref_c_ucs4_char_lm + call f_check_c_ucs4_char_am_as(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 365 + a = ref_c_ucs4_char_lm + call c_check_c_ucs4_char_am_as(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 366 + a = ref_c_ucs4_char_lm + call f_check_c_ucs4_char_am_ar(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 367 + a = ref_c_ucs4_char_lm + call c_check_c_ucs4_char_am_ar(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 368 + a = ref_c_ucs4_char_lm + p => a + call f_check_c_ucs4_char_dm_as(p) + if(.not.associated(p)) stop 369 + if(.not.associated(p, a)) stop 370 + if(any(p/=ref_c_ucs4_char_lm)) stop 371 + if(any(a/=ref_c_ucs4_char_lm)) stop 372 + a = ref_c_ucs4_char_lm + p => a + call c_check_c_ucs4_char_dm_as(p) + if(.not.associated(p)) stop 373 + if(.not.associated(p, a)) stop 374 + if(any(p/=ref_c_ucs4_char_lm)) stop 375 + if(any(a/=ref_c_ucs4_char_lm)) stop 376 + a = ref_c_ucs4_char_lm + p => a + call f_check_c_ucs4_char_dm_ar(p) + if(.not.associated(p)) stop 377 + if(.not.associated(p, a)) stop 378 + if(any(p/=ref_c_ucs4_char_lm)) stop 379 + if(any(a/=ref_c_ucs4_char_lm)) stop 380 + a = ref_c_ucs4_char_lm + p => a + call c_check_c_ucs4_char_dm_ar(p) + if(.not.associated(p)) stop 381 + if(.not.associated(p, a)) stop 382 + if(any(p/=ref_c_ucs4_char_lm)) stop 383 + if(any(a/=ref_c_ucs4_char_lm)) stop 384 + return + end subroutine check_c_ucs4_char_lm + + subroutine f_check_c_ucs4_char_cm_as(a) + character(kind=c_ucs4_char, len=m), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 385 + if(k/=4_c_signed_char) stop 386 + if(n/=m) stop 387 + if(int(k, kind=c_size_t)/=e) stop 388 + if(t/=CFI_type_ucs4_char) stop 389 + if(any(a/=ref_c_ucs4_char_lm)) stop 390 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_lm)) stop 391 + return + end subroutine f_check_c_ucs4_char_cm_as + + subroutine c_check_c_ucs4_char_cm_as(a) bind(c) + character(kind=c_ucs4_char, len=m), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 392 + if(k/=4_c_signed_char) stop 393 + if(n/=m) stop 394 + if(int(k, kind=c_size_t)/=e) stop 395 + if(t/=CFI_type_ucs4_char) stop 396 + if(any(a/=ref_c_ucs4_char_lm)) stop 397 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_lm)) stop 398 + return + end subroutine c_check_c_ucs4_char_cm_as + + subroutine f_check_c_ucs4_char_cm_ar(a) + character(kind=c_ucs4_char, len=m), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 399 + if(k/=4_c_signed_char) stop 400 + if(n/=m) stop 401 + if(int(k, kind=c_size_t)/=e) stop 402 + if(t/=CFI_type_ucs4_char) stop 403 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 404 + rank default + stop 405 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 406 + rank default + stop 407 + end select + return + end subroutine f_check_c_ucs4_char_cm_ar + + subroutine c_check_c_ucs4_char_cm_ar(a) bind(c) + character(kind=c_ucs4_char, len=m), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 408 + if(k/=4_c_signed_char) stop 409 + if(n/=m) stop 410 + if(int(k, kind=c_size_t)/=e) stop 411 + if(t/=CFI_type_ucs4_char) stop 412 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 413 + rank default + stop 414 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 415 + rank default + stop 416 + end select + return + end subroutine c_check_c_ucs4_char_cm_ar + + subroutine f_check_c_ucs4_char_am_as(a) + character(kind=c_ucs4_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 417 + if(k/=4_c_signed_char) stop 418 + if(n/=m) stop 419 + if(int(k, kind=c_size_t)/=e) stop 420 + if(t/=CFI_type_ucs4_char) stop 421 + if(any(a/=ref_c_ucs4_char_lm)) stop 422 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_lm)) stop 423 + return + end subroutine f_check_c_ucs4_char_am_as + + subroutine c_check_c_ucs4_char_am_as(a) bind(c) + character(kind=c_ucs4_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 424 + if(k/=4_c_signed_char) stop 425 + if(n/=m) stop 426 + if(int(k, kind=c_size_t)/=e) stop 427 + if(t/=CFI_type_ucs4_char) stop 428 + if(any(a/=ref_c_ucs4_char_lm)) stop 429 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_lm)) stop 430 + return + end subroutine c_check_c_ucs4_char_am_as + + subroutine f_check_c_ucs4_char_am_ar(a) + character(kind=c_ucs4_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 431 + if(k/=4_c_signed_char) stop 432 + if(n/=m) stop 433 + if(int(k, kind=c_size_t)/=e) stop 434 + if(t/=CFI_type_ucs4_char) stop 435 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 436 + rank default + stop 437 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 438 + rank default + stop 439 + end select + return + end subroutine f_check_c_ucs4_char_am_ar + + subroutine c_check_c_ucs4_char_am_ar(a) bind(c) + character(kind=c_ucs4_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 440 + if(k/=4_c_signed_char) stop 441 + if(n/=m) stop 442 + if(int(k, kind=c_size_t)/=e) stop 443 + if(t/=CFI_type_ucs4_char) stop 444 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 445 + rank default + stop 446 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 447 + rank default + stop 448 + end select + return + end subroutine c_check_c_ucs4_char_am_ar + + subroutine f_check_c_ucs4_char_dm_as(a) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 449 + if(k/=4_c_signed_char) stop 450 + if(n/=m) stop 451 + if(int(k, kind=c_size_t)/=e) stop 452 + if(t/=CFI_type_ucs4_char) stop 453 + if(any(a/=ref_c_ucs4_char_lm)) stop 454 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_lm)) stop 455 + return + end subroutine f_check_c_ucs4_char_dm_as + + subroutine c_check_c_ucs4_char_dm_as(a) bind(c) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 456 + if(k/=4_c_signed_char) stop 457 + if(n/=m) stop 458 + if(int(k, kind=c_size_t)/=e) stop 459 + if(t/=CFI_type_ucs4_char) stop 460 + if(any(a/=ref_c_ucs4_char_lm)) stop 461 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_lm)) stop 462 + return + end subroutine c_check_c_ucs4_char_dm_as + + subroutine f_check_c_ucs4_char_dm_ar(a) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 463 + if(k/=4_c_signed_char) stop 464 + if(n/=m) stop 465 + if(int(k, kind=c_size_t)/=e) stop 466 + if(t/=CFI_type_ucs4_char) stop 467 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 468 + rank default + stop 469 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 470 + rank default + stop 471 + end select + return + end subroutine f_check_c_ucs4_char_dm_ar + + subroutine c_check_c_ucs4_char_dm_ar(a) bind(c) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 472 + if(k/=4_c_signed_char) stop 473 + if(n/=m) stop 474 + if(int(k, kind=c_size_t)/=e) stop 475 + if(t/=CFI_type_ucs4_char) stop 476 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 477 + rank default + stop 478 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 479 + rank default + stop 480 + end select + return + end subroutine c_check_c_ucs4_char_dm_ar + +end module iso_check_m + +program main_p + + use :: iso_check_m, only: & + check_c_char_l1, & + check_c_char_lm, & + check_c_ucs4_char_l1, & + check_c_ucs4_char_lm + + implicit none + + call check_c_char_l1() + call check_c_char_lm() + ! See PR100907 + !call check_c_ucs4_char_l1() + !call check_c_ucs4_char_lm() + stop + +end program main_p + +!! Local Variables: +!! mode: f90 +!! End: + Index: Fortran/gfortran/regression/PR100911.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100911.c @@ -0,0 +1,82 @@ +/* Test the fix for PR100911 */ + +#include +#include +#include + +#include + +#define _CFI_type_mask 0xFF +#define _CFI_type_kind_shift 8 + +#define _CFI_decode_type(NAME) (signed char)((NAME) & CFI_type_mask) +#define _CFI_decode_kind(NAME) (signed char)(((NAME) >> CFI_type_kind_shift) & CFI_type_mask) + +#define _CFI_encode_type(TYPE, KIND) (int16_t)\ +((((KIND) & CFI_type_mask) << CFI_type_kind_shift)\ + | ((TYPE) & CFI_type_mask)) + +#define N 11 +#define M 7 + +#define CFI_type_Cptr CFI_type_cptr + +typedef int* c_ptr; + +bool c_vrfy_cptr (const CFI_cdesc_t *restrict); + +void check_tk (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t); + +bool +c_vrfy_cptr (const CFI_cdesc_t *restrict auxp) +{ + CFI_index_t i, lb, ub, ex; + size_t sz; + c_ptr *ip = NULL; + + assert (auxp); + assert (auxp->base_addr); + assert (auxp->elem_len>0); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + assert (ex==11); + sz = (size_t)auxp->elem_len / sizeof (c_ptr); + assert (sz==1); + ub = ex + lb - 1; + ip = (c_ptr*)auxp->base_addr; + for (i=0; ielem_len==elem_len*nelem); + assert (auxp->rank==1); + assert (auxp->dim[0].sm>0); + assert ((size_t)auxp->dim[0].sm==elem_len*nelem); + /* */ + assert (auxp->type==type); + ityp = _CFI_decode_type(auxp->type); + assert (ityp == CFI_type_cptr); + iknd = _CFI_decode_kind(auxp->type); + assert (_CFI_decode_type(type)==ityp); + assert (kind==iknd); + assert (c_vrfy_cptr (auxp)); + return; +} + +// Local Variables: +// mode: C +// End: Index: Fortran/gfortran/regression/PR100911.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100911.f90 @@ -0,0 +1,282 @@ +! { dg-do run } +! { dg-additional-sources PR100911.c } +! +! Test the fix for PR100911 +! + +module isof_m + + use, intrinsic :: iso_c_binding, only: & + c_signed_char, c_int16_t + + implicit none + + private + + public :: & + CFI_type_cptr + + public :: & + check_tk_as, & + check_tk_ar + + public :: & + cfi_encode_type + + integer, parameter :: CFI_type_t = c_int16_t + + integer(kind=c_int16_t), parameter :: CFI_type_mask = int(z"FF", kind=c_int16_t) + integer(kind=c_int16_t), parameter :: CFI_type_kind_shift = 8_c_int16_t + + ! Intrinsic types. Their kind number defines their storage size. */ + integer(kind=c_signed_char), parameter :: CFI_type_cptr = 7 + + interface + subroutine check_tk_as(a, t, k, e, n) & + bind(c, name="check_tk") + use, intrinsic :: iso_c_binding, only: & + c_int16_t, c_signed_char, c_size_t + implicit none + type(*), intent(in) :: a(:) + integer(c_int16_t), value, intent(in) :: t + integer(c_signed_char), value, intent(in) :: k + integer(c_size_t), value, intent(in) :: e + integer(c_size_t), value, intent(in) :: n + end subroutine check_tk_as + subroutine check_tk_ar(a, t, k, e, n) & + bind(c, name="check_tk") + use, intrinsic :: iso_c_binding, only: & + c_int16_t, c_signed_char, c_size_t + implicit none + type(*), intent(in) :: a(..) + integer(c_int16_t), value, intent(in) :: t + integer(c_signed_char), value, intent(in) :: k + integer(c_size_t), value, intent(in) :: e + integer(c_size_t), value, intent(in) :: n + end subroutine check_tk_ar + end interface + +contains + + elemental function cfi_encode_type(type, kind) result(itype) + integer(kind=c_signed_char), intent(in) :: type + integer(kind=c_signed_char), intent(in) :: kind + + integer(kind=c_int16_t) :: itype, ikind + + itype = int(type, kind=c_int16_t) + itype = iand(itype, CFI_type_mask) + ikind = int(kind, kind=c_int16_t) + ikind = iand(ikind, CFI_type_mask) + ikind = shiftl(ikind, CFI_type_kind_shift) + itype = ior(ikind, itype) + return + end function cfi_encode_type + +end module isof_m + +module iso_check_m + + use, intrinsic :: iso_c_binding, only: & + c_signed_char, c_int16_t, c_size_t + + use, intrinsic :: iso_c_binding, only: & + c_int, c_ptr, c_loc, c_associated + + use, intrinsic :: iso_c_binding, only: & + c_ptr + + use :: isof_m, only: & + CFI_type_cptr + + use :: isof_m, only: & + check_tk_as, & + check_tk_ar + + use :: isof_m, only: & + cfi_encode_type + + implicit none + + integer :: i + integer(kind=c_size_t), parameter :: b = 8 + integer, parameter :: n = 11 + + type, bind(c) :: c_foo_t + integer(kind=c_int) :: a + end type c_foo_t + + type(c_foo_t), parameter :: ref_c_foo_t(*) = [(c_foo_t(a=i), i=1,n)] + + type(c_foo_t), protected, target :: target_c_foo_t(n) + + +contains + + subroutine check_c_ptr() + type(c_ptr) :: p(n) + integer :: i + ! + target_c_foo_t = ref_c_foo_t + p = [(c_loc(target_c_foo_t(i)), i=1,n)] + call f_check_c_ptr_as(p) + if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 1 + do i = 1, n + if(.not.c_associated(p(i), c_loc(target_c_foo_t(i)))) stop 2 + end do + target_c_foo_t = ref_c_foo_t + p = [(c_loc(target_c_foo_t(i)), i=1,n)] + call c_check_c_ptr_as(p) + if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 3 + do i = 1, n + if(.not.c_associated(p(i), c_loc(target_c_foo_t(i)))) stop 4 + end do + target_c_foo_t = ref_c_foo_t + p = [(c_loc(target_c_foo_t(i)), i=1,n)] + call f_check_c_ptr_ar(p) + if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 5 + do i = 1, n + if(.not.c_associated(p(i), c_loc(target_c_foo_t(i)))) stop 6 + end do + target_c_foo_t = ref_c_foo_t + p = [(c_loc(target_c_foo_t(i)), i=1,n)] + call c_check_c_ptr_ar(p) + if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 7 + do i = 1, n + if(.not.c_associated(p(i), c_loc(target_c_foo_t(i)))) stop 8 + end do + return + end subroutine check_c_ptr + + subroutine f_check_c_ptr_as(a) + type(c_ptr), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = 0 + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_cptr, k) + ! Assumes 64-bit target. + ! if(e/=8) stop 9 + if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 10 + do i = 1, n + if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 11 + end do + call check_tk_as(a, t, k, e, 1_c_size_t) + if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 12 + do i = 1, n + if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 13 + end do + return + end subroutine f_check_c_ptr_as + + subroutine c_check_c_ptr_as(a) bind(c) + type(c_ptr), intent(in) :: a(:) + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = 0 + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_cptr, k) + ! Assumes 64-bit target. + ! if(e/=8) stop 14 + if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 15 + do i = 1, n + if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 16 + end do + call check_tk_as(a, t, k, e, 1_c_size_t) + if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 17 + do i = 1, n + if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 18 + end do + return + end subroutine c_check_c_ptr_as + + subroutine f_check_c_ptr_ar(a) + type(c_ptr), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = 0 + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_cptr, k) + ! Assumes 64-bit target. + ! if(e/=8) stop 19 + select rank(a) + rank(1) + if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 20 + do i = 1, n + if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 21 + end do + rank default + stop 22 + end select + call check_tk_ar(a, t, k, e, 1_c_size_t) + select rank(a) + rank(1) + if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 23 + do i = 1, n + if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 24 + end do + rank default + stop 25 + end select + return + end subroutine f_check_c_ptr_ar + + subroutine c_check_c_ptr_ar(a) bind(c) + type(c_ptr), intent(in) :: a(..) + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = 0 + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_cptr, k) + ! Assumes 64-bit target. + ! if(e/=8) stop 26 + select rank(a) + rank(1) + if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 27 + do i = 1, n + if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 28 + end do + rank default + stop 29 + end select + call check_tk_ar(a, t, k, e, 1_c_size_t) + select rank(a) + rank(1) + if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 30 + do i = 1, n + if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 31 + end do + rank default + stop 32 + end select + return + end subroutine c_check_c_ptr_ar + +end module iso_check_m + +program main_p + + use :: iso_check_m, only: & + check_c_ptr + + implicit none + + call check_c_ptr() + stop + +end program main_p + +!! Local Variables: +!! mode: f90 +!! End: + Index: Fortran/gfortran/regression/PR100914.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100914.c @@ -0,0 +1,225 @@ +/* Test the fix for PR100914 */ + +#include +#include +#include +#include +#include + +#include + +#define _CFI_type_mask 0xFF +#define _CFI_type_kind_shift 8 + +#define _CFI_decode_type(NAME) (signed char)((NAME) & CFI_type_mask) +#define _CFI_decode_kind(NAME) (signed char)(((NAME) >> CFI_type_kind_shift) & CFI_type_mask) + +#define _CFI_encode_type(TYPE, KIND) (int16_t)\ +((((KIND) & CFI_type_mask) << CFI_type_kind_shift)\ + | ((TYPE) & CFI_type_mask)) + +#undef CMPLXF +#define CMPLXF(x, y) ((float complex)((float)(x) + I * (float)(y))) + +#undef CMPLX +#define CMPLX(x, y) ((double complex)((double)(x) + (double complex)I * (double)(y))) + +#undef CMPLXL +#define CMPLXL(x, y) ((long double complex)((long double)(x) + (long double complex)I * (long double)(y))) + +#undef CMPLX +#define CMPLX(x, y) ((_Float128 _Complex )((double)(x) + (double complex)I * (double)(y))) + +#define N 11 +#define M 7 + +typedef float _Complex c_float_complex; +typedef double _Complex c_double_complex; +typedef long double _Complex c_long_double_complex; +typedef _Float128 _Complex c_float128_complex; + +bool c_vrfy_c_float_complex (const CFI_cdesc_t *restrict); + +bool c_vrfy_c_double_complex (const CFI_cdesc_t *restrict); + +bool c_vrfy_c_long_double_complex (const CFI_cdesc_t *restrict); + +bool c_vrfy_c_float128_complex (const CFI_cdesc_t *restrict); + +bool c_vrfy_complex (const CFI_cdesc_t *restrict); + +bool c_vrfy_desc (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t); + +void check_tk (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t); + + + +bool +c_vrfy_c_float_complex (const CFI_cdesc_t *restrict auxp) +{ + CFI_index_t i, lb, ub, ex; + size_t sz; + c_float_complex *ip = NULL; + + assert (auxp); + assert (auxp->base_addr); + assert (auxp->elem_len>0); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + assert (ex==11); + sz = (size_t)auxp->elem_len / sizeof (c_float_complex); + assert (sz==1); + ub = ex + lb - 1; + ip = (c_float_complex*)auxp->base_addr; + for (i=0; i(float)0.0)) + return false; + for (i=lb; i(float)0.0)) + return false; + } + return true; +} + +bool +c_vrfy_c_double_complex (const CFI_cdesc_t *restrict auxp) +{ + CFI_index_t i, lb, ub, ex; + size_t sz; + c_double_complex *ip = NULL; + + assert (auxp); + assert (auxp->base_addr); + assert (auxp->elem_len>0); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + assert (ex==11); + sz = (size_t)auxp->elem_len / sizeof (c_double_complex); + assert (sz==1); + ub = ex + lb - 1; + ip = (c_double_complex*)auxp->base_addr; + for (i=0; i(double)0.0)) + return false; + for (i=lb; i(double)0.0)) + return false; + } + return true; +} + +bool +c_vrfy_c_long_double_complex (const CFI_cdesc_t *restrict auxp) +{ + CFI_index_t i, lb, ub, ex; + size_t sz; + c_long_double_complex *ip = NULL; + + assert (auxp); + assert (auxp->base_addr); + assert (auxp->elem_len>0); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + assert (ex==11); + sz = (size_t)auxp->elem_len / sizeof (c_long_double_complex); + assert (sz==1); + ub = ex + lb - 1; + ip = (c_long_double_complex*)auxp->base_addr; + for (i=0; i(long double)0.0)) + return false; + for (i=lb; i(long double)0.0)) + return false; + } + return true; +} + +bool +c_vrfy_c_float128_complex (const CFI_cdesc_t *restrict auxp) +{ + CFI_index_t i, lb, ub, ex; + size_t sz; + c_float128_complex *ip = NULL; + + assert (auxp); + assert (auxp->base_addr); + assert (auxp->elem_len>0); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + assert (ex==11); + sz = (size_t)auxp->elem_len / sizeof (c_float128_complex); + assert (sz==1); + ub = ex + lb - 1; + ip = (c_float128_complex*)auxp->base_addr; + for (i=0; i(double)0.0)) + return false; + for (i=lb; i(double)0.0)) + return false; + } + return true; +} + +bool +c_vrfy_complex (const CFI_cdesc_t *restrict auxp) +{ + signed char type, kind; + + assert (auxp); + type = _CFI_decode_type(auxp->type); + kind = _CFI_decode_kind(auxp->type); + assert (type == CFI_type_Complex); + switch (kind) + { + case 4: + return c_vrfy_c_float_complex (auxp); + break; + case 8: + return c_vrfy_c_double_complex (auxp); + break; + case 10: + return c_vrfy_c_long_double_complex (auxp); + break; + case 16: + return c_vrfy_c_float128_complex (auxp); + break; + default: + assert (false); + } + return true; +} + +void +check_tk (const CFI_cdesc_t *restrict auxp, const CFI_type_t type, const signed char kind, const size_t elem_len, const size_t nelem) +{ + signed char ityp, iknd; + + assert (auxp); + assert (auxp->elem_len==elem_len*nelem); + assert (auxp->rank==1); + assert (auxp->dim[0].sm>0); + assert ((size_t)auxp->dim[0].sm==elem_len*nelem); + /* */ + assert (auxp->type==type); + ityp = _CFI_decode_type(auxp->type); + assert (ityp == CFI_type_Complex); + iknd = _CFI_decode_kind(auxp->type); + assert (_CFI_decode_type(type)==ityp); + assert (kind==iknd); + assert (c_vrfy_complex (auxp)); + return; +} + +// Local Variables: +// mode: C +// End: Index: Fortran/gfortran/regression/PR100914.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100914.f90 @@ -0,0 +1,652 @@ +! Fails on x86 targets where sizeof(long double) == 16. +! { dg-do run } +! { dg-additional-sources PR100914.c } +! { dg-require-effective-target fortran_real_c_float128 } +! { dg-additional-options "-Wno-pedantic" } +! +! Test the fix for PR100914 +! + +module isof_m + + use, intrinsic :: iso_c_binding, only: & + c_signed_char, c_int16_t + + implicit none + + private + + public :: & + CFI_type_Complex, & + CFI_type_float_Complex, & + CFI_type_double_Complex, & + CFI_type_long_double_Complex, & + CFI_type_float128_Complex + + public :: & + check_tk_as, & + check_tk_ar + + + public :: & + cfi_encode_type + + integer, parameter :: CFI_type_t = c_int16_t + + integer(kind=c_int16_t), parameter :: CFI_type_mask = int(z"FF", kind=c_int16_t) + integer(kind=c_int16_t), parameter :: CFI_type_kind_shift = 8_c_int16_t + + ! Intrinsic types. Their kind number defines their storage size. */ + integer(kind=c_signed_char), parameter :: CFI_type_Complex = 4 + + ! C-Fortran Interoperability types. + integer(kind=cfi_type_t), parameter :: CFI_type_float_Complex = & + ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(4_c_int16_t, CFI_type_kind_shift)) + integer(kind=cfi_type_t), parameter :: CFI_type_double_Complex = & + ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(8_c_int16_t, CFI_type_kind_shift)) + integer(kind=cfi_type_t), parameter :: CFI_type_long_double_Complex = & + ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(10_c_int16_t, CFI_type_kind_shift)) + integer(kind=cfi_type_t), parameter :: CFI_type_float128_Complex = & + ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(16_c_int16_t, CFI_type_kind_shift)) + + interface + subroutine check_tk_as(a, t, k, e, n) & + bind(c, name="check_tk") + use, intrinsic :: iso_c_binding, only: & + c_int16_t, c_signed_char, c_size_t + implicit none + type(*), intent(in) :: a(:) + integer(c_int16_t), value, intent(in) :: t + integer(c_signed_char), value, intent(in) :: k + integer(c_size_t), value, intent(in) :: e + integer(c_size_t), value, intent(in) :: n + end subroutine check_tk_as + subroutine check_tk_ar(a, t, k, e, n) & + bind(c, name="check_tk") + use, intrinsic :: iso_c_binding, only: & + c_int16_t, c_signed_char, c_size_t + implicit none + type(*), intent(in) :: a(..) + integer(c_int16_t), value, intent(in) :: t + integer(c_signed_char), value, intent(in) :: k + integer(c_size_t), value, intent(in) :: e + integer(c_size_t), value, intent(in) :: n + end subroutine check_tk_ar + end interface + +contains + + elemental function cfi_encode_type(type, kind) result(itype) + integer(kind=c_signed_char), intent(in) :: type + integer(kind=c_signed_char), intent(in) :: kind + + integer(kind=c_int16_t) :: itype, ikind + + itype = int(type, kind=c_int16_t) + itype = iand(itype, CFI_type_mask) + ikind = int(kind, kind=c_int16_t) + ikind = iand(ikind, CFI_type_mask) + ikind = shiftl(ikind, CFI_type_kind_shift) + itype = ior(ikind, itype) + return + end function cfi_encode_type + +end module isof_m + +module iso_check_m + + use, intrinsic :: iso_c_binding, only: & + c_signed_char, c_int16_t, c_size_t + + use, intrinsic :: iso_c_binding, only: & + c_float_complex, & + c_double_complex, & + c_long_double_complex, & + c_float128_complex + + use :: isof_m, only: & + CFI_type_Complex + + use :: isof_m, only: & + CFI_type_float_Complex, & + CFI_type_double_Complex, & + CFI_type_long_double_Complex, & + CFI_type_float128_Complex + + use :: isof_m, only: & + check_tk_as, & + check_tk_ar + + use :: isof_m, only: & + cfi_encode_type + + implicit none + + private + + public :: & + check_c_float_complex, & + check_c_double_complex, & + check_c_long_double_complex, & + check_c_float128_complex + + integer :: i + integer(kind=c_size_t), parameter :: b = 8 + integer, parameter :: n = 11 + + complex(kind=c_float_complex), parameter :: ref_c_float_complex(*) = & + [(cmplx(i, 2*i, kind=c_float_complex), i=1,n)] + complex(kind=c_double_complex), parameter :: ref_c_double_complex(*) = & + [(cmplx(i, 2*i, kind=c_double_complex), i=1,n)] + complex(kind=c_long_double_complex), parameter :: ref_c_long_double_complex(*) = & + [(cmplx(i, 2*i, kind=c_long_double_complex), i=1,n)] + complex(kind=c_float128_complex), parameter :: ref_c_float128_complex(*) = & + [(cmplx(i, 2*i, kind=c_float128_complex), i=1,n)] + +contains + + ! CFI_type_float_complex + subroutine check_c_float_complex() + complex(kind=c_float_complex) :: a(n) + ! + if (c_float_complex/=4) stop 1 + a = ref_c_float_complex + call f_check_c_float_complex_as(a) + if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 2 + a = ref_c_float_complex + call c_check_c_float_complex_as(a) + if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 3 + a = ref_c_float_complex + call f_check_c_float_complex_ar(a) + if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 4 + a = ref_c_float_complex + call c_check_c_float_complex_ar(a) + if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 5 + return + end subroutine check_c_float_complex + + subroutine f_check_c_float_complex_as(a) + complex(kind=c_float_complex), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 6 + if(k/=4_c_signed_char) stop 7 + if(int(k, kind=c_size_t)/=(e/2)) stop 8 + if(t/=CFI_type_float_complex) stop 9 + if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 10 + call check_tk_as(a, t, k, e, 1_c_size_t) + if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 11 + return + end subroutine f_check_c_float_complex_as + + subroutine c_check_c_float_complex_as(a) bind(c) + complex(kind=c_float_complex), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 12 + if(k/=4_c_signed_char) stop 13 + if(int(k, kind=c_size_t)/=(e/2)) stop 14 + if(t/=CFI_type_float_complex) stop 15 + if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 16 + call check_tk_as(a, t, k, e, 1_c_size_t) + if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 17 + return + end subroutine c_check_c_float_complex_as + + subroutine f_check_c_float_complex_ar(a) + complex(kind=c_float_complex), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 18 + if(k/=4_c_signed_char) stop 19 + if(int(k, kind=c_size_t)/=(e/2)) stop 20 + if(t/=CFI_type_float_complex) stop 21 + select rank(a) + rank(1) + if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 22 + rank default + stop 23 + end select + call check_tk_ar(a, t, k, e, 1_c_size_t) + select rank(a) + rank(1) + if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 24 + rank default + stop 25 + end select + return + end subroutine f_check_c_float_complex_ar + + subroutine c_check_c_float_complex_ar(a) bind(c) + complex(kind=c_float_complex), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 26 + if(k/=4_c_signed_char) stop 27 + if(int(k, kind=c_size_t)/=(e/2)) stop 28 + if(t/=CFI_type_float_complex) stop 29 + select rank(a) + rank(1) + if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 30 + rank default + stop 31 + end select + call check_tk_ar(a, t, k, e, 1_c_size_t) + select rank(a) + rank(1) + if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 32 + rank default + stop 33 + end select + return + end subroutine c_check_c_float_complex_ar + + ! CFI_type_double_complex + subroutine check_c_double_complex() + complex(kind=c_double_complex) :: a(n) + ! + if (c_double_complex/=8) stop 34 + a = ref_c_double_complex + call f_check_c_double_complex_as(a) + if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 35 + a = ref_c_double_complex + call c_check_c_double_complex_as(a) + if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 36 + a = ref_c_double_complex + call f_check_c_double_complex_ar(a) + if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 37 + a = ref_c_double_complex + call c_check_c_double_complex_ar(a) + if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 38 + return + end subroutine check_c_double_complex + + subroutine f_check_c_double_complex_as(a) + complex(kind=c_double_complex), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 39 + if(k/=8_c_signed_char) stop 40 + if(int(k, kind=c_size_t)/=(e/2)) stop 41 + if(t/=CFI_type_double_complex) stop 42 + if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 43 + call check_tk_as(a, t, k, e, 1_c_size_t) + if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 44 + return + end subroutine f_check_c_double_complex_as + + subroutine c_check_c_double_complex_as(a) bind(c) + complex(kind=c_double_complex), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 45 + if(k/=8_c_signed_char) stop 46 + if(int(k, kind=c_size_t)/=(e/2)) stop 47 + if(t/=CFI_type_double_complex) stop 48 + if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 49 + call check_tk_as(a, t, k, e, 1_c_size_t) + if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 50 + return + end subroutine c_check_c_double_complex_as + + subroutine f_check_c_double_complex_ar(a) + complex(kind=c_double_complex), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 51 + if(k/=8_c_signed_char) stop 52 + if(int(k, kind=c_size_t)/=(e/2)) stop 53 + if(t/=CFI_type_double_complex) stop 54 + select rank(a) + rank(1) + if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 55 + rank default + stop 56 + end select + call check_tk_ar(a, t, k, e, 1_c_size_t) + select rank(a) + rank(1) + if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 57 + rank default + stop 58 + end select + return + end subroutine f_check_c_double_complex_ar + + subroutine c_check_c_double_complex_ar(a) bind(c) + complex(kind=c_double_complex), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 59 + if(k/=8_c_signed_char) stop 60 + if(int(k, kind=c_size_t)/=(e/2)) stop 61 + if(t/=CFI_type_double_complex) stop 62 + select rank(a) + rank(1) + if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 63 + rank default + stop 64 + end select + call check_tk_ar(a, t, k, e, 1_c_size_t) + select rank(a) + rank(1) + if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 65 + rank default + stop 66 + end select + return + end subroutine c_check_c_double_complex_ar + + ! CFI_type_long_double_complex + subroutine check_c_long_double_complex() + complex(kind=c_long_double_complex) :: a(n) + ! + if (c_long_double_complex/=10) stop 67 + a = ref_c_long_double_complex + call f_check_c_long_double_complex_as(a) + if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 68 + a = ref_c_long_double_complex + call c_check_c_long_double_complex_as(a) + if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 69 + a = ref_c_long_double_complex + call f_check_c_long_double_complex_ar(a) + if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 70 + a = ref_c_long_double_complex + call c_check_c_long_double_complex_ar(a) + if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 71 + return + end subroutine check_c_long_double_complex + + subroutine f_check_c_long_double_complex_as(a) + complex(kind=c_long_double_complex), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 72 + if(k/=10_c_signed_char) stop 73 + if(e/=32) stop 74 + if(t/=CFI_type_long_double_complex) stop 75 + if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 76 + call check_tk_as(a, t, k, e, 1_c_size_t) + if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 77 + return + end subroutine f_check_c_long_double_complex_as + + subroutine c_check_c_long_double_complex_as(a) bind(c) + complex(kind=c_long_double_complex), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 78 + if(k/=10_c_signed_char) stop 79 + if(e/=32) stop 80 + if(t/=CFI_type_long_double_complex) stop 81 + if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 82 + call check_tk_as(a, t, k, e, 1_c_size_t) + if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 83 + return + end subroutine c_check_c_long_double_complex_as + + subroutine f_check_c_long_double_complex_ar(a) + complex(kind=c_long_double_complex), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 84 + if(k/=10_c_signed_char) stop 85 + if(e/=32) stop 86 + if(t/=CFI_type_long_double_complex) stop 87 + select rank(a) + rank(1) + if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 88 + rank default + stop 89 + end select + call check_tk_ar(a, t, k, e, 1_c_size_t) + select rank(a) + rank(1) + if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 90 + rank default + stop 91 + end select + return + end subroutine f_check_c_long_double_complex_ar + + subroutine c_check_c_long_double_complex_ar(a) bind(c) + complex(kind=c_long_double_complex), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 92 + if(k/=10_c_signed_char) stop 93 + if(e/=32) stop 94 + if(t/=CFI_type_long_double_complex) stop 95 + select rank(a) + rank(1) + if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 96 + rank default + stop 97 + end select + call check_tk_ar(a, t, k, e, 1_c_size_t) + select rank(a) + rank(1) + if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 98 + rank default + stop 99 + end select + return + end subroutine c_check_c_long_double_complex_ar + + ! CFI_type_float128_complex + subroutine check_c_float128_complex() + complex(kind=c_float128_complex) :: a(n) + ! + if (c_float128_complex/=16) stop 100 + a = ref_c_float128_complex + call f_check_c_float128_complex_as(a) + if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 101 + a = ref_c_float128_complex + call c_check_c_float128_complex_as(a) + if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 102 + a = ref_c_float128_complex + call f_check_c_float128_complex_ar(a) + if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 103 + a = ref_c_float128_complex + call c_check_c_float128_complex_ar(a) + if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 104 + return + end subroutine check_c_float128_complex + + subroutine f_check_c_float128_complex_as(a) + complex(kind=c_float128_complex), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 105 + if(k/=16_c_signed_char) stop 106 + if(int(k, kind=c_size_t)/=(e/2)) stop 107 + if(t/=CFI_type_float128_complex) stop 108 + if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 109 + call check_tk_as(a, t, k, e, 1_c_size_t) + if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 110 + return + end subroutine f_check_c_float128_complex_as + + subroutine c_check_c_float128_complex_as(a) bind(c) + complex(kind=c_float128_complex), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 111 + if(k/=16_c_signed_char) stop 112 + if(int(k, kind=c_size_t)/=(e/2)) stop 113 + if(t/=CFI_type_float128_complex) stop 114 + if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 115 + call check_tk_as(a, t, k, e, 1_c_size_t) + if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 116 + return + end subroutine c_check_c_float128_complex_as + + subroutine f_check_c_float128_complex_ar(a) + complex(kind=c_float128_complex), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 117 + if(k/=16_c_signed_char) stop 118 + if(int(k, kind=c_size_t)/=(e/2)) stop 119 + if(t/=CFI_type_float128_complex) stop 120 + select rank(a) + rank(1) + if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 121 + rank default + stop 122 + end select + call check_tk_ar(a, t, k, e, 1_c_size_t) + select rank(a) + rank(1) + if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 123 + rank default + stop 124 + end select + return + end subroutine f_check_c_float128_complex_ar + + subroutine c_check_c_float128_complex_ar(a) bind(c) + complex(kind=c_float128_complex), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = kind(a) + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_complex, k) + if(k<=0_c_signed_char) stop 125 + if(k/=16_c_signed_char) stop 126 + if(int(k, kind=c_size_t)/=(e/2)) stop 127 + if(t/=CFI_type_float128_complex) stop 128 + select rank(a) + rank(1) + if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 129 + rank default + stop 130 + end select + call check_tk_ar(a, t, k, e, 1_c_size_t) + select rank(a) + rank(1) + if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 131 + rank default + stop 132 + end select + return + end subroutine c_check_c_float128_complex_ar + +end module iso_check_m + +program main_p + + use :: iso_check_m, only: & + check_c_float_complex, & + check_c_double_complex, & + check_c_long_double_complex, & + check_c_float128_complex + + implicit none + + call check_c_float_complex() + call check_c_double_complex() + ! see PR100910 + ! call check_c_long_double_complex() + call check_c_float128_complex() + stop + +end program main_p + +!! Local Variables: +!! mode: f90 +!! End: + Index: Fortran/gfortran/regression/PR100915.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100915.c @@ -0,0 +1,80 @@ +/* Test the fix for PR100915 */ + +#include +#include +#include + +#include + +#define _CFI_type_mask 0xFF +#define _CFI_type_kind_shift 8 + +#define _CFI_decode_type(NAME) (signed char)((NAME) & CFI_type_mask) +#define _CFI_decode_kind(NAME) (signed char)(((NAME) >> CFI_type_kind_shift) & CFI_type_mask) + +#define _CFI_encode_type(TYPE, KIND) (int16_t)\ +((((KIND) & CFI_type_mask) << CFI_type_kind_shift)\ + | ((TYPE) & CFI_type_mask)) + +#define N 11 +#define M 7 + +typedef int(*c_funptr)(int); + +bool c_vrfy_c_funptr (const CFI_cdesc_t *restrict); + +void check_fn (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t); + +bool +c_vrfy_c_funptr (const CFI_cdesc_t *restrict auxp) +{ + CFI_index_t i, lb, ub, ex; + size_t sz; + c_funptr *ip = NULL; + + assert (auxp); + assert (auxp->base_addr); + assert (auxp->elem_len>0); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + assert (ex==11); + sz = (size_t)auxp->elem_len / sizeof (c_funptr); + assert (sz==1); + ub = ex + lb - 1; + ip = (c_funptr*)auxp->base_addr; + for (i=0; ielem_len==elem_len*nelem); + assert (auxp->rank==1); + assert (auxp->dim[0].sm>0); + assert ((size_t)auxp->dim[0].sm==elem_len*nelem); + /* */ + assert (auxp->type==type); + ityp = _CFI_decode_type(auxp->type); + assert (ityp == CFI_type_cfunptr); + iknd = _CFI_decode_kind(auxp->type); + assert (_CFI_decode_type(type)==ityp); + assert (kind==iknd); + assert (c_vrfy_c_funptr (auxp)); + return; +} + +// Local Variables: +// mode: C +// End: Index: Fortran/gfortran/regression/PR100915.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR100915.f90 @@ -0,0 +1,273 @@ +! { dg-do run } +! { dg-additional-sources PR100915.c } +! +! Test the fix for PR100915 +! + +module isof_m + + use, intrinsic :: iso_c_binding, only: & + c_signed_char, c_int16_t + + implicit none + + private + + public :: & + CFI_type_cptr, CFI_type_cfunptr + + public :: & + check_fn_as, & + check_fn_ar + + public :: & + mult2 + + public :: & + cfi_encode_type + + integer, parameter :: CFI_type_t = c_int16_t + + integer(kind=c_int16_t), parameter :: CFI_type_mask = int(z"FF", kind=c_int16_t) + integer(kind=c_int16_t), parameter :: CFI_type_kind_shift = 8_c_int16_t + + ! Intrinsic types. Their kind number defines their storage size. */ + integer(kind=c_signed_char), parameter :: CFI_type_cptr = 7 + integer(kind=c_signed_char), parameter :: CFI_type_cfunptr = 8 + + interface + subroutine check_fn_as(a, t, k, e, n) & + bind(c, name="check_fn") + use, intrinsic :: iso_c_binding, only: & + c_int16_t, c_signed_char, c_size_t + implicit none + type(*), intent(in) :: a(:) + integer(c_int16_t), value, intent(in) :: t + integer(c_signed_char), value, intent(in) :: k + integer(c_size_t), value, intent(in) :: e + integer(c_size_t), value, intent(in) :: n + end subroutine check_fn_as + subroutine check_fn_ar(a, t, k, e, n) & + bind(c, name="check_fn") + use, intrinsic :: iso_c_binding, only: & + c_int16_t, c_signed_char, c_size_t + implicit none + type(*), intent(in) :: a(..) + integer(c_int16_t), value, intent(in) :: t + integer(c_signed_char), value, intent(in) :: k + integer(c_size_t), value, intent(in) :: e + integer(c_size_t), value, intent(in) :: n + end subroutine check_fn_ar + end interface + +contains + + function mult2(a) result(b) bind(c) + use, intrinsic :: iso_c_binding, only: & + c_int + + integer(kind=c_int), value, intent(in) :: a + + integer(kind=c_int) :: b + + b = 2_c_int * a + return + end function mult2 + + elemental function cfi_encode_type(type, kind) result(itype) + integer(kind=c_signed_char), intent(in) :: type + integer(kind=c_signed_char), intent(in) :: kind + + integer(kind=c_int16_t) :: itype, ikind + + itype = int(type, kind=c_int16_t) + itype = iand(itype, CFI_type_mask) + ikind = int(kind, kind=c_int16_t) + ikind = iand(ikind, CFI_type_mask) + ikind = shiftl(ikind, CFI_type_kind_shift) + itype = ior(ikind, itype) + return + end function cfi_encode_type + +end module isof_m + +module iso_check_m + + use, intrinsic :: iso_c_binding, only: & + c_signed_char, c_int16_t, c_size_t + + use, intrinsic :: iso_c_binding, only: & + c_funptr, c_funloc, c_associated + + use :: isof_m, only: & + CFI_type_cptr, CFI_type_cfunptr + + use :: isof_m, only: & + check_fn_as, & + check_fn_ar + + use :: isof_m, only: & + mult2 + + use :: isof_m, only: & + cfi_encode_type + + implicit none + + integer :: i + integer(kind=c_size_t), parameter :: b = 8 + integer, parameter :: n = 11 + +contains + + subroutine check_c_funptr() + type(c_funptr) :: p(n) + integer :: i + ! + p = [(c_funloc(mult2), i=1,n)] + call f_check_c_funptr_as(p) + do i = 1, n + if(.not.c_associated(p(i), c_funloc(mult2))) stop 1 + end do + p = [(c_funloc(mult2), i=1,n)] + call c_check_c_funptr_as(p) + do i = 1, n + if(.not.c_associated(p(i), c_funloc(mult2))) stop 2 + end do + p = [(c_funloc(mult2), i=1,n)] + call f_check_c_funptr_ar(p) + do i = 1, n + if(.not.c_associated(p(i), c_funloc(mult2))) stop 3 + end do + p = [(c_funloc(mult2), i=1,n)] + call c_check_c_funptr_ar(p) + do i = 1, n + if(.not.c_associated(p(i), c_funloc(mult2))) stop 4 + end do + return + end subroutine check_c_funptr + + subroutine f_check_c_funptr_as(a) + type(c_funptr), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = 0 + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_cfunptr, k) + ! Assumes 64-bit target. + ! if(e/=8) stop 5 + do i = 1, n + if(.not.c_associated(a(i), c_funloc(mult2))) stop 6 + end do + call check_fn_as(a, t, k, e, 1_c_size_t) + do i = 1, n + if(.not.c_associated(a(i), c_funloc(mult2))) stop 7 + end do + return + end subroutine f_check_c_funptr_as + + subroutine c_check_c_funptr_as(a) bind(c) + type(c_funptr), intent(in) :: a(:) + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = 0 + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_cfunptr, k) + ! Assumes 64-bit target. + ! if(e/=8) stop 8 + do i = 1, n + if(.not.c_associated(a(i), c_funloc(mult2))) stop 9 + end do + call check_fn_as(a, t, k, e, 1_c_size_t) + do i = 1, n + if(.not.c_associated(a(i), c_funloc(mult2))) stop 10 + end do + return + end subroutine c_check_c_funptr_as + + subroutine f_check_c_funptr_ar(a) + type(c_funptr), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = 0 + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_cfunptr, k) + ! Assumes 64-bit target. + ! if(e/=8) stop 11 + select rank(a) + rank(1) + do i = 1, n + if(.not.c_associated(a(i), c_funloc(mult2))) stop 12 + end do + rank default + stop 13 + end select + call check_fn_ar(a, t, k, e, 1_c_size_t) + select rank(a) + rank(1) + do i = 1, n + if(.not.c_associated(a(i), c_funloc(mult2))) stop 14 + end do + rank default + stop 15 + end select + return + end subroutine f_check_c_funptr_ar + + subroutine c_check_c_funptr_ar(a) bind(c) + type(c_funptr), intent(in) :: a(..) + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e + ! + k = 0 + e = storage_size(a)/b + t = cfi_encode_type(CFI_type_cfunptr, k) + ! Assumes 64-bit target. + ! if(e/=8) stop 16 + select rank(a) + rank(1) + do i = 1, n + if(.not.c_associated(a(i), c_funloc(mult2))) stop 17 + end do + rank default + stop 18 + end select + call check_fn_ar(a, t, k, e, 1_c_size_t) + select rank(a) + rank(1) + do i = 1, n + if(.not.c_associated(a(i), c_funloc(mult2))) stop 19 + end do + rank default + stop 20 + end select + return + end subroutine c_check_c_funptr_ar + +end module iso_check_m + +program main_p + + use :: iso_check_m, only: & + check_c_funptr + + implicit none + + call check_c_funptr() + stop + +end program main_p + +!! Local Variables: +!! mode: f90 +!! End: + Index: Fortran/gfortran/regression/PR19754_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR19754_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! Test of fix to PR19754 +program PR19754_1 + real x(3,3),y(2,2) + x = 1. + y = 2. + x = x + y ! { dg-error "Shapes for operands at" } +end program PR19754_1 + Index: Fortran/gfortran/regression/PR19754_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR19754_2.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! Test of Steve Kargl's fix to PR19754 +! This exercises bugs that the original patch caused +! +program PR19754_2 + real a(2,2), b(2,2),c(2,2),d(2,2) + integer i(2,2),j(2,2),k(2,2) + a = 1. ; b = 2. ; i = 4 + c = b - floor( a / b ) ! this caused an ICE + d = b - real(floor( a / b )) + if (any (c/=d)) STOP 1 + j = aint(b) - floor( a / b ) ! this caused an ICE + if (any(real(j)/=d)) STOP 2 + c = i + if (any(real(i)/=c)) STOP 3 + c = i + b ! this caused an ICE + d = real(i) + b + if (any(c/=d)) STOP 4 + j = i + aint (a) + k = i + a ! this caused an ICE + if (any(j/=k)) STOP 5 +end program PR19754_2 Index: Fortran/gfortran/regression/PR19872.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR19872.f @@ -0,0 +1,20 @@ +! { dg-do run { target fd_truncate } } +! PR 19872 - closed and re-opened file not overwriten + implicit none + integer i(4) + data i / 4 * 0 / + open(1,form='FORMATTED',status='UNKNOWN') + write(1,'("1 2 3 4 5 6 7 8 9")') + close(1) + open(1,form='FORMATTED') + write(1,'("9 8 7 6")') + close(1) + open(1,form='FORMATTED') + read(1,*)i + if(i(1).ne.9.or.i(2).ne.8.or.i(3).ne.7.or.i(4).ne.6)STOP 1 + read(1,*, end=200)i +! should only be able to read one line from the file + STOP 2 + 200 continue + close(1,STATUS='delete') + end Index: Fortran/gfortran/regression/PR24188.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR24188.f @@ -0,0 +1,6 @@ +C PR target/24188 +C { dg-do compile } +C { dg-options "-O2" } +C { dg-options "-O2 -mcmodel=medium" { target { { i?86-*-* x86_64-*-* } && lp64 } } } + WRITE(6,*) '' + END Index: Fortran/gfortran/regression/PR37039.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR37039.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcray-pointer" } +! +! Test for PR37039, from an issue on comp.lang.fortran +! http://groups.google.com/group/comp.lang.fortran/msg/8cfa06f222721386 + + subroutine test(nnode) + implicit none + integer n,nnode + pointer(ip_tab, tab) + integer , dimension(1:nnode) :: tab + do n=1,nnode + tab(n) = 0 + enddo + end subroutine test Index: Fortran/gfortran/regression/PR40660.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR40660.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original-lineno" } +! +! PR fortran/40660 + +PROGRAM test + INTEGER, DIMENSION(3) :: a1,a2 + a1 = 1 + PRINT*, a1 + a2 = 2 +end program test + +! { dg-final { scan-tree-dump-times ": 3\] _gfortran" 0 "original" } } + Index: Fortran/gfortran/regression/PR49268.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR49268.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! { dg-options "-fcray-pointer" } + +! Test the fix for a runtime error +! Contributed by Mike Kumbera + + program bob + implicit none + integer*8 ipfoo + integer n,m,i,j + real*8 foo + + common /ipdata/ ipfoo + common /ipsize/ n,m + POINTER ( ipfoo, foo(3,7) ) + + n=3 + m=7 + + ipfoo=malloc(8*n*m) + do i=1,n + do j=1,m + foo(i,j)=1.d0 + end do + end do + call use_foo() + end program bob + + + subroutine use_foo() + implicit none + integer n,m,i,j + integer*8 ipfoo + common /ipdata/ ipfoo + common /ipsize/ n,m + real*8 foo,boo + + !fails if * is the last dimension + POINTER ( ipfoo, foo(n,*) ) + + !works if the last dimension is specified + !POINTER ( ipfoo, foo(n,m) ) + boo=0.d0 + do i=1,n + do j=1,m + boo=foo(i,j)+1.0 + if (abs (boo - 2.0) .gt. 1e-6) STOP 1 + end do + end do + + end subroutine use_foo Index: Fortran/gfortran/regression/PR82376.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR82376.f90 @@ -0,0 +1,60 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcheck=pointer" } +! +! Test the fix for PR82376. The pointer check was doubling up the call +! to new. The fix reduces the count of 'new' from 5 to 4, or to 3, when +! counting only calls. +! +! Contributed by José Rui Faustino de Sousa +! +program main_p + + integer, parameter :: n = 10 + + type :: foo_t + integer, pointer :: v =>null() + end type foo_t + + integer, save :: pcnt = 0 + + type(foo_t) :: int + integer :: i + + do i = 1, n + call init(int, i) + if(.not.associated(int%v)) stop 1 + if(int%v/=i) stop 2 + if(pcnt/=i) stop 3 + end do + +contains + + function new(data) result(this) + integer, target, intent(in) :: data + + integer, pointer :: this + + nullify(this) + this => data + pcnt = pcnt + 1 + return + end function new + + subroutine init(this, data) + type(foo_t), intent(out) :: this + integer, intent(in) :: data + + call set(this, new(data)) + return + end subroutine init + + subroutine set(this, that) + type(foo_t), intent(inout) :: this + integer, target, intent(in) :: that + + this%v => that + return + end subroutine set + +end program main_p +! { dg-final { scan-tree-dump-times { new \(} 3 "original" } } Index: Fortran/gfortran/regression/PR85868A.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR85868A.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! +! PR fortran/85868 +! +! Contributed by Harald Anlauf +! + +program test + + implicit none + + integer, parameter :: e(*) = [1, 1, -1, -1, 0, 0, 1] + + integer, pointer :: t(:), u(:) + integer :: i + + allocate (t(-1:5)) + do i = -1, 5 + t(i) = i + end do + call p (t, e(1)) ! Pointer with lower bound = -1 from allocation + u => t ! Pointer assignment sets same lower bound + call p (u, e(2)) + ! + u => t(:) ! Pointer assignment with implicit lower bound (1) + call p (u, e(3)) + call p (t(:), e(4)) ! Full array, behaves the same + ! + call p (t(0:), e(5)) ! Array section + u => t(0:) ! Pointer assignment with implicit lower bound (1) + call p (u, e(6)) + u(0:) => t(0:) ! Pointer assignment with given lower bound (0) + call p (u, e(7)) + stop + +contains + + subroutine p (a, v) + integer, pointer, intent(in) :: a(:) + integer, intent(in) :: v + + if(a(1)/=v) stop 1001 + return + end subroutine p + +end program test + Index: Fortran/gfortran/regression/PR85868B.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR85868B.f90 @@ -0,0 +1,144 @@ +program main_p + + implicit none + + integer, parameter :: n = 10 + integer, parameter :: m = 5 + + integer, parameter :: b = 3 + integer, parameter :: t = n+b-1 + + integer, parameter :: l = 4 + integer, parameter :: u = 7 + integer, parameter :: s = 3 + integer, parameter :: e = (u-l)/s+1 + + call test_f() + call test_s() + call test_p() + call test_a() + stop + +contains + + subroutine test_f() + integer, target :: x(n,n) + integer, target :: y(b:t) + integer :: i + + x = reshape([(i, i=1,n*n)], [n,n]) + y = x(:,m) + call sub_s(x(:,m), y, 1, n, n) + call sub_s(y, x(:,m), b, t, n) + return + end subroutine test_f + + subroutine test_s() + integer, target :: x(n,n) + integer, target :: v(e) + integer :: i + + x = reshape([(i, i=1,n*n)], [n,n]) + v = x(l:u:s,m) + call sub_s(v, v, 1, e, e) + call sub_s(x(l:u:s,m), v, 1, e, e) + call sub_s(v, x(l:u:s,m), 1, e, e) + return + end subroutine test_s + + subroutine test_p() + integer, target :: x(n,n) + integer, pointer :: p(:) + integer :: v(e) + integer :: i + + x = reshape([(i, i=1,n*n)], [n,n]) + v = x(l:u:s,m) + p => x(:,m) + call sub_s(p(l:u:s), v, 1, e, e) + p => x(l:u:s,m) + call sub_s(p, v, 1, e, e) + p(l:) => x(l:u:s,m) + call sub_s(p, v, l, e+l-1, e) + p(l:l+e-1) => x(l:u:s,m) + call sub_s(p, v, l, e+l-1, e) + allocate(p(n)) + p(:) = x(:,m) + call sub_s(p(l:u:s), v, 1, e, e) + deallocate(p) + allocate(p(e)) + p(:) = x(l:u:s,m) + call sub_s(p, v, 1, e, e) + deallocate(p) + allocate(p(l:l+e-1)) + p(:) = x(l:u:s,m) + call sub_s(p, v, l, e+l-1, e) + deallocate(p) + allocate(p(l:l+e-1)) + p(l:) = x(l:u:s,m) + call sub_s(p, v, l, e+l-1, e) + deallocate(p) + allocate(p(l:l+e-1)) + p(l:l+e-1) = x(l:u:s,m) + call sub_s(p, v, l, e+l-1, e) + deallocate(p) + return + end subroutine test_p + + subroutine test_a() + integer :: x(n,n) + integer, allocatable, target :: a(:) + integer :: v(e) + integer :: i + + x = reshape([(i, i=1,n*n)], [n,n]) + v = x(l:u:s,m) + a = x(:,m) + call sub_s(a(l:u:s), v, 1, e, e) + deallocate(a) + allocate(a(n)) + a(:) = x(:,m) + call sub_s(a(l:u:s), v, 1, e, e) + deallocate(a) + a = x(l:u:s,m) + call sub_s(a, v, 1, e, e) + deallocate(a) + allocate(a(e)) + a(:) = x(l:u:s,m) + call sub_s(a, v, 1, e, e) + deallocate(a) + allocate(a(l:l+e-1)) + a(:) = x(l:u:s,m) + call sub_s(a, v, l, e+l-1, e) + deallocate(a) + allocate(a(l:l+e-1)) + a(l:) = x(l:u:s,m) + call sub_s(a, v, l, e+l-1, e) + deallocate(a) + allocate(a(l:l+e-1)) + a(l:l+e-1) = x(l:u:s,m) + call sub_s(a, v, l, e+l-1, e) + deallocate(a) + return + end subroutine test_a + + subroutine sub_s(a, b, l, u, e) + integer, pointer, intent(in) :: a(:) + integer, intent(in) :: b(:) + integer, intent(in) :: l + integer, intent(in) :: u + integer, intent(in) :: e + + integer :: i + + if(lbound(a,dim=1)/=l) stop 1001 + if(ubound(a,dim=1)/=u) stop 1002 + if(any(shape(a)/=[e])) stop 1003 + if(size(a, dim=1)/=e) stop 1004 + if(size(a)/=size(b)) stop 1005 + do i = l, u + if(a(i)/=b(i-l+1)) stop 1006 + end do + end subroutine sub_s + +end program main_p Index: Fortran/gfortran/regression/PR90350.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR90350.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! Test the fix for PR90350 +! +! Contributed by +! + +program artificial +implicit none +integer :: arr(-10:10) + call asub(arr,size(arr)) +end program artificial +subroutine asub(arr,n) +integer,intent(in) :: arr(*) +integer,intent(in) :: n + write(*,*)'UPPER=',ubound(arr(:n)) + write(*,*)'LOWER=',lbound(arr(:n)) + write(*,*)'SIZE=',size(arr(:n)) +end subroutine asub Index: Fortran/gfortran/regression/PR93308.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR93308.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Test the fix for PR94331 +! +! Contributed by Robin Hogan +! + +program test + + use, intrinsic :: iso_c_binding, only: & + c_int, c_float + + implicit none + + integer :: i + integer, parameter :: n = 11 + real(kind=c_float), parameter :: u(*) = [(real(i, kind=c_float), i=1,n)] + + real(kind=c_float), allocatable :: A(:) + real(kind=c_float) :: E(n) + integer(kind=c_int) :: l1, l2, l3 + + allocate(A, source=u) + l1 = lbound(A, 1) + call routine_bindc(A, l2) ! in gcc-9.2.1 this changes lbound of A... + l3 = lbound(A, 1) + if (l1 /= 1) stop 1 + if (l1 /= l2) stop 2 + if (l1 /= l3) stop 3 + if (any(abs(A(1:n)-u)>0.0_c_float)) stop 4 + deallocate(A) + ! + E = u + l1 = lbound(E, 1) + call routine_bindc(E, l2) ! ...but does not change lbound of E + l3 = lbound(E, 1) + if (l1 /= 1) stop 5 + if (l1 /= l2) stop 6 + if (l1 /= l3) stop 7 + if (any(abs(E(1:n)-u)>0.0_c_float)) stop 8 + +contains + + subroutine routine_bindc(v, l) bind(c) + real(kind=c_float), intent(inout) :: v(:) + integer(kind=c_int), intent(out) :: l + + l = lbound(v, 1) + if (any(abs(v(1:n)-u)>0.0_c_float)) stop 9 + end subroutine routine_bindc + +end program test Index: Fortran/gfortran/regression/PR93963.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR93963.f90 @@ -0,0 +1,197 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! +! Test the fix for PR93963 +! + +module m +contains +function rank_p(this) result(rnk) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + + implicit none + + integer(kind=c_int), pointer, intent(in) :: this(..) + integer(kind=c_int) :: rnk + + select rank(this) + rank(0) + rnk = 0 + rank(1) + rnk = 1 + rank(2) + rnk = 2 + rank(3) + rnk = 3 + rank(4) + rnk = 4 + rank(5) + rnk = 5 + rank(6) + rnk = 6 + rank(7) + rnk = 7 + rank(8) + rnk = 8 + rank(9) + rnk = 9 + rank(10) + rnk = 10 + rank(11) + rnk = 11 + rank(12) + rnk = 12 + rank(13) + rnk = 13 + rank(14) + rnk = 14 + rank(15) + rnk = 15 + rank default + rnk = -1000 + end select + return +end function rank_p + +function rank_a(this) result(rnk) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + + implicit none + + integer(kind=c_int), allocatable, intent(in) :: this(..) + integer(kind=c_int) :: rnk + + select rank(this) + rank(0) + rnk = 0 + rank(1) + rnk = 1 + rank(2) + rnk = 2 + rank(3) + rnk = 3 + rank(4) + rnk = 4 + rank(5) + rnk = 5 + rank(6) + rnk = 6 + rank(7) + rnk = 7 + rank(8) + rnk = 8 + rank(9) + rnk = 9 + rank(10) + rnk = 10 + rank(11) + rnk = 11 + rank(12) + rnk = 12 + rank(13) + rnk = 13 + rank(14) + rnk = 14 + rank(15) + rnk = 15 + rank default + rnk = -1000 + end select + return +end function rank_a + +function rank_o(this) result(rnk) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + + implicit none + + integer(kind=c_int), intent(in) :: this(..) + integer(kind=c_int) :: rnk + + select rank(this) + rank(0) + rnk = 0 + rank(1) + rnk = 1 + rank(2) + rnk = 2 + rank(3) + rnk = 3 + rank(4) + rnk = 4 + rank(5) + rnk = 5 + rank(6) + rnk = 6 + rank(7) + rnk = 7 + rank(8) + rnk = 8 + rank(9) + rnk = 9 + rank(10) + rnk = 10 + rank(11) + rnk = 11 + rank(12) + rnk = 12 + rank(13) + rnk = 13 + rank(14) + rnk = 14 + rank(15) + rnk = 15 + rank default + rnk = -1000 + end select + return +end function rank_o + +end module m + +program selr_p + use m + use, intrinsic :: iso_c_binding, only: c_int + + implicit none + + integer(kind=c_int), parameter :: siz = 7 + integer(kind=c_int), parameter :: rnk = 1 + + integer(kind=c_int), pointer :: intp(:) + integer(kind=c_int), allocatable :: inta(:) + integer(kind=c_int) :: irnk + + nullify(intp) + irnk = rank_p(intp) + if (irnk /= rnk) stop 1 + if (irnk /= rank(intp)) stop 2 + ! + irnk = rank_a(inta) + if (irnk /= rnk) stop 3 + if (irnk /= rank(inta)) stop 4 + ! + allocate(intp(siz)) + irnk = rank_p(intp) + if (irnk /= rnk) stop 5 + if (irnk /= rank(intp)) stop 6 + irnk = rank_o(intp) + if (irnk /= rnk) stop 7 + if (irnk /= rank(intp)) stop 8 + deallocate(intp) + nullify(intp) + ! + allocate(inta(siz)) + irnk = rank_a(inta) + if (irnk /= rnk) stop 9 + if (irnk /= rank(inta)) stop 10 + irnk = rank_o(inta) + if (irnk /= rnk) stop 11 + if (irnk /= rank(inta)) stop 12 + deallocate(inta) + +end program selr_p + +! Special code for assumed rank - but only if not allocatable/pointer +! Thus, expect it only once for subroutine rank_o but not for rank_a or rank_p +! { dg-final { scan-tree-dump-times "ubound != -1" 1 "original" } } Index: Fortran/gfortran/regression/PR94022.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR94022.f90 @@ -0,0 +1,132 @@ +! { dg-do run } +! +! Test the fix for PR94022 +! + +function isasa_f(a) result(s) + implicit none + + integer, intent(in) :: a(..) + + logical :: s + + select rank(a) + rank(*) + s = .true. + rank default + s = .false. + end select + return +end function isasa_f + +function isasa_c(a) result(s) bind(c) + use, intrinsic :: iso_c_binding, only: c_int, c_bool + + implicit none + + integer(kind=c_int), intent(in) :: a(..) + + logical(kind=c_bool) :: s + + select rank(a) + rank(*) + s = .true. + rank default + s = .false. + end select + return +end function isasa_c + +program isasa_p + + implicit none + + interface + function isasa_f(a) result(s) + implicit none + integer, intent(in) :: a(..) + logical :: s + end function isasa_f + function isasa_c(a) result(s) bind(c) + use, intrinsic :: iso_c_binding, only: c_int, c_bool + implicit none + integer(kind=c_int), intent(in) :: a(..) + logical(kind=c_bool) :: s + end function isasa_c + end interface + + integer, parameter :: sz = 7 + integer, parameter :: lb = 3 + integer, parameter :: ub = 9 + integer, parameter :: ex = ub-lb+1 + + integer :: arr(sz,lb:ub) + + arr = 1 + if (asaf_a(arr, lb+1, ub-1)) stop 1 + if (asaf_p(arr, lb+1, ub-1)) stop 2 + if (asaf_a(arr, 2, ex-1)) stop 3 + if (asaf_p(arr, 2, ex-1)) stop 4 + if (asac_a(arr, lb+1, ub-1)) stop 5 + if (asac_p(arr, lb+1, ub-1)) stop 6 + if (asac_a(arr, 2, ex-1)) stop 7 + if (asac_p(arr, 2, ex-1)) stop 8 + + stop + +contains + + function asaf_a(a, lb, ub) result(s) + integer, intent(in) :: lb + integer, target, intent(in) :: a(sz,lb:*) + integer, intent(in) :: ub + + logical :: s + + s = isasa_f(a(:,lb:ub)) + return + end function asaf_a + + function asaf_p(a, lb, ub) result(s) + integer, intent(in) :: lb + integer, target, intent(in) :: a(sz,lb:*) + integer, intent(in) :: ub + + logical :: s + + integer, pointer :: p(:,:) + + p => a(:,lb:ub) + s = isasa_f(p) + return + end function asaf_p + + function asac_a(a, lb, ub) result(s) + integer, intent(in) :: lb + integer, target, intent(in) :: a(sz,lb:*) + integer, intent(in) :: ub + + logical :: s + + s = logical(isasa_c(a(:,lb:ub))) + return + end function asac_a + + function asac_p(a, lb, ub) result(s) + integer, intent(in) :: lb + integer, target, intent(in) :: a(sz,lb:*) + integer, intent(in) :: ub + + logical :: s + + integer, pointer :: p(:,:) + + p => a(:,lb:ub) + s = logical(isasa_c(p)) + return + end function asac_p + +end program isasa_p + + + Index: Fortran/gfortran/regression/PR94104a.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR94104a.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/94104 +! + +program diag_p + implicit none + + integer, parameter :: n = 7 + + integer :: a(n) + integer, target :: b(n) + + a = 1 + print *, sumf(a) ! { dg-error "Actual argument for 'a' at .1. must be a pointer" } + print *, sumf(b) ! { dg-error "Fortran 2008: Non-pointer actual argument at .1. to pointer dummy 'a'" } + +contains + + function sumf(a) result(s) + integer, pointer, intent(in) :: a(:) + + integer :: s + + s = sum(a) + end function sumf + +end program diag_p Index: Fortran/gfortran/regression/PR94104b.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR94104b.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/94104 +! + +program diag_p + implicit none + + integer, parameter :: n = 7 + + integer :: a(n) + integer, target :: b(n) + + a = 1 + print *, sumf(a) ! { dg-error "Actual argument for 'a' at .1. must be a pointer or a valid target" } + print *, sumf(b) + +contains + + function sumf(a) result(s) + integer, pointer, intent(in) :: a(:) + + integer :: s + + s = sum(a) + end function sumf + +end program diag_p Index: Fortran/gfortran/regression/PR94110.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR94110.f90 @@ -0,0 +1,103 @@ +! { dg-do compile } +! +! Test the fix for PR94110 +! + +program asa_p + + implicit none + + integer, parameter :: n = 7 + + type t + end type t + + interface + subroutine fc2 (x) + import :: t + class(t), pointer, intent(in) :: x(..) + end subroutine + end interface + + integer :: p(n) + integer :: s + + p = 1 + s = sumf_as(p) + if (s/=n) stop 1 + s = sumf_ar(p) + if (s/=n) stop 2 + stop + +contains + + function sumf_as(a) result(s) + integer, target, intent(in) :: a(*) + + integer :: s + + s = sum_as(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" } + s = sum_p_ds(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" } + s = sum_p_ar(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" } + return + end function sumf_as + + function sumf_ar(a) result(s) + integer, target, intent(in) :: a(..) + + integer :: s + + select rank(a) + rank(*) + s = sum_as(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" } + s = sum_p_ds(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" } + s = sum_p_ar(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" } + rank default + stop 3 + end select + return + end function sumf_ar + + function sum_as(a) result(s) + integer, intent(in) :: a(:) + + integer :: s + + s = sum(a) + return + end function sum_as + + function sum_p_ds(a) result(s) + integer, pointer, intent(in) :: a(:) + + integer :: s + + s = -1 + if(associated(a))& + s = sum(a) + return + end function sum_p_ds + + function sum_p_ar(a) result(s) + integer, pointer, intent(in) :: a(..) + + integer :: s + + s = -1 + select rank(a) + rank(1) + if(associated(a))& + s = sum(a) + rank default + stop 4 + end select + return + end function sum_p_ar + + subroutine sub1(y) + type(t), target :: y(*) + call fc2 (y) ! { dg-error "Actual argument for .x. cannot be an assumed-size array" } + end subroutine sub1 + +end program asa_p + Index: Fortran/gfortran/regression/PR94289.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR94289.f90 @@ -0,0 +1,168 @@ +! { dg-do run } +! +! Testcase for PR 94289 +! +! - if the dummy argument is a pointer/allocatable, it has the same +! bounds as the dummy argument +! - if is is nonallocatable nonpointer, the lower bounds are [1, 1, 1]. + +module bounds_m + + implicit none + + private + public :: & + lb, ub + + public :: & + bnds_p, & + bnds_a, & + bnds_e + + integer, parameter :: lb1 = 3 + integer, parameter :: lb2 = 5 + integer, parameter :: lb3 = 9 + integer, parameter :: ub1 = 4 + integer, parameter :: ub2 = 50 + integer, parameter :: ub3 = 11 + integer, parameter :: ex1 = ub1 - lb1 + 1 + integer, parameter :: ex2 = ub2 - lb2 + 1 + integer, parameter :: ex3 = ub3 - lb3 + 1 + + integer, parameter :: lf(*) = [1,1,1] + integer, parameter :: lb(*) = [lb1,lb2,lb3] + integer, parameter :: ub(*) = [ub1,ub2,ub3] + integer, parameter :: ex(*) = [ex1,ex2,ex3] + +contains + + subroutine bounds(a, lb, ub) + integer, pointer, intent(in) :: a(..) + integer, intent(in) :: lb(3) + integer, intent(in) :: ub(3) + + integer :: ex(3) + + ex = max(ub-lb+1, 0) + if(any(lbound(a)/=lb)) stop 101 + if(any(ubound(a)/=ub)) stop 102 + if(any( shape(a)/=ex)) stop 103 + return + end subroutine bounds + + subroutine bnds_p(this) + integer, pointer, intent(in) :: this(..) + + if(any(lbound(this)/=lb)) stop 1 + if(any(ubound(this)/=ub)) stop 2 + if(any( shape(this)/=ex)) stop 3 + call bounds(this, lb, ub) + return + end subroutine bnds_p + + subroutine bnds_a(this) + integer, allocatable, target, intent(in) :: this(..) + + if(any(lbound(this)/=lb)) stop 4 + if(any(ubound(this)/=ub)) stop 5 + if(any( shape(this)/=ex)) stop 6 + call bounds(this, lb, ub) + return + end subroutine bnds_a + + subroutine bnds_e(this) + integer, target, intent(in) :: this(..) + + if(any(lbound(this)/=lf)) stop 7 + if(any(ubound(this)/=ex)) stop 8 + if(any( shape(this)/=ex)) stop 9 + call bounds(this, lf, ex) + return + end subroutine bnds_e + +end module bounds_m + +program bounds_p + + use, intrinsic :: iso_c_binding, only: c_int + + use bounds_m + + implicit none + + integer, parameter :: fpn = 1 + integer, parameter :: fan = 2 + integer, parameter :: fon = 3 + + integer :: i + + do i = fpn, fon + call test_p(i) + end do + do i = fpn, fon + call test_a(i) + end do + do i = fpn, fon + call test_e(i) + end do + stop + +contains + + subroutine test_p(t) + integer, intent(in) :: t + + integer, pointer :: a(:,:,:) + + allocate(a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))) + select case(t) + case(fpn) + call bnds_p(a) + case(fan) + case(fon) + call bnds_e(a) + case default + stop + end select + deallocate(a) + return + end subroutine test_p + + subroutine test_a(t) + integer, intent(in) :: t + + integer, allocatable, target :: a(:,:,:) + + allocate(a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))) + select case(t) + case(fpn) + call bnds_p(a) + case(fan) + call bnds_a(a) + case(fon) + call bnds_e(a) + case default + stop + end select + deallocate(a) + return + end subroutine test_a + + subroutine test_e(t) + integer, intent(in) :: t + + integer, target :: a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3)) + + select case(t) + case(fpn) + call bnds_p(a) + case(fan) + case(fon) + call bnds_e(a) + case default + stop + end select + return + end subroutine test_e + +end program bounds_p Index: Fortran/gfortran/regression/PR94327.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR94327.c @@ -0,0 +1,70 @@ +/* Test the fix for PR94327. */ + +#include +#include +#include + +#include + +bool c_vrfy (const CFI_cdesc_t *restrict); + +char get_attr (const CFI_cdesc_t*restrict, bool); + +bool +c_vrfy (const CFI_cdesc_t *restrict auxp) +{ + CFI_index_t i, lb, ub, ex; + int *ip = NULL; + + assert (auxp); + assert (auxp->base_addr); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + ub = ex + lb - 1; + ip = (int*)auxp->base_addr; + for (i=0; ielem_len == 4); + assert (auxp->rank == 1); + assert (auxp->type == CFI_type_int); + attr = '\0'; + switch (auxp->attribute) + { + case CFI_attribute_pointer: + if (alloc && !c_vrfy (auxp)) + break; + attr = 'p'; + break; + case CFI_attribute_allocatable: + if (alloc && !c_vrfy (auxp)) + break; + attr = 'a'; + break; + case CFI_attribute_other: + assert (alloc); + if (!c_vrfy (auxp)) + break; + attr = 'o'; + break; + default: + break; + } + return attr; +} + Index: Fortran/gfortran/regression/PR94327.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR94327.f90 @@ -0,0 +1,195 @@ +! { dg-do run } +! { dg-additional-sources PR94327.c } +! +! Test the fix for PR94327 +! + +program attr_p + + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + + implicit none + + integer :: i + integer, parameter :: n = 11 + integer, parameter :: u(*) = [(i, i=1,n)] + + interface + function attr_p_as(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), pointer, intent(in) :: a(:) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_p_as + function attr_a_as(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), allocatable, intent(in) :: a(:) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_a_as + function attr_o_as(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), intent(in) :: a(:) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_o_as + function attr_p_ar(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), pointer, intent(in) :: a(..) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_p_ar + function attr_a_ar(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), allocatable, intent(in) :: a(..) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_a_ar + function attr_o_ar(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), intent(in) :: a(..) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_o_ar + end interface + + integer(kind=c_int), target :: a(n) + integer(kind=c_int), allocatable, target :: b(:) + integer(kind=c_int), pointer :: p(:) + character(kind=c_char) :: c + + a = u + c = attr_p_as(a, .true._c_bool) + if(c/='p') stop 1 + if(any(a/=u)) stop 2 + ! + a = u + c = attr_p_ar(a, .true._c_bool) + if(c/='p') stop 3 + if(any(a/=u)) stop 4 + ! + a = u + c = attr_o_as(a, .true._c_bool) + if(c/='o') stop 5 + if(any(a/=u)) stop 6 + ! + a = u + c = attr_o_ar(a, .true._c_bool) + if(c/='o') stop 7 + if(any(a/=u)) stop 8 + ! + allocate(b, source=u) + c = attr_p_as(b, .true._c_bool) + if(c/='p') stop 9 + if(.not.allocated(b)) stop 10 + if(any(b/=u)) stop 11 + ! + deallocate(b) + allocate(b, source=u) + c = attr_p_ar(b, .true._c_bool) + if(c/='p') stop 12 + if(.not.allocated(b)) stop 13 + if(any(b/=u)) stop 14 + ! + deallocate(b) + allocate(b, source=u) + c = attr_a_as(b, .true._c_bool) + if(c/='a') stop 15 + if(.not.allocated(b)) stop 16 + if(any(b/=u)) stop 17 + ! + deallocate(b) + allocate(b, source=u) + c = attr_a_ar(b, .true._c_bool) + if(c/='a') stop 18 + if(.not.allocated(b)) stop 19 + if(any(b/=u)) stop 20 + ! + deallocate(b) + allocate(b, source=u) + c = attr_o_as(b, .true._c_bool) + if(c/='o') stop 21 + if(.not.allocated(b)) stop 22 + if(any(b/=u)) stop 23 + ! + deallocate(b) + allocate(b, source=u) + c = attr_o_ar(b, .true._c_bool) + if(c/='o') stop 24 + if(.not.allocated(b)) stop 25 + if(any(b/=u)) stop 26 + ! + deallocate(b) + c = attr_a_as(b, .false._c_bool) + if(c/='a') stop 27 + if(allocated(b)) stop 28 + ! + c = attr_a_ar(b, .false._c_bool) + if(c/='a') stop 29 + if(allocated(b)) stop 30 + ! + nullify(p) + p => a + c = attr_p_as(p, .true._c_bool) + if(c/='p') stop 31 + if(.not.associated(p)) stop 32 + if(.not.associated(p, a)) stop 33 + if(any(p/=u)) stop 34 + ! + nullify(p) + p => a + c = attr_p_ar(p, .true._c_bool) + if(c/='p') stop 35 + if(.not.associated(p)) stop 36 + if(.not.associated(p, a)) stop 37 + if(any(p/=u)) stop 38 + ! + nullify(p) + p => a + c = attr_o_as(p, .true._c_bool) + if(c/='o') stop 39 + if(.not.associated(p)) stop 40 + if(.not.associated(p, a)) stop 41 + if(any(p/=u)) stop 42 + ! + nullify(p) + p => a + c = attr_o_ar(p, .true._c_bool) + if(c/='o') stop 43 + if(.not.associated(p)) stop 44 + if(.not.associated(p, a)) stop 45 + if(any(p/=u)) stop 46 + ! + nullify(p) + c = attr_p_as(p, .false._c_bool) + if(c/='p') stop 47 + if(associated(p)) stop 48 + if(associated(p, a)) stop 49 + ! + nullify(p) + c = attr_p_ar(p, .false._c_bool) + if(c/='p') stop 50 + if(associated(p)) stop 51 + if(associated(p, a)) stop 52 + stop + +end program attr_p Index: Fortran/gfortran/regression/PR94331.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR94331.c @@ -0,0 +1,73 @@ +/* Test the fix for PR94331. */ + +#include +#include +#include + +#include + +bool c_vrfy (const CFI_cdesc_t *restrict); + +bool check_bounds(const CFI_cdesc_t*restrict, const int, const int); + +bool +c_vrfy (const CFI_cdesc_t *restrict auxp) +{ + CFI_index_t i, lb, ub, ex; + int *ip = NULL; + + assert (auxp); + assert (auxp->base_addr); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + ub = ex + lb - 1; + ip = (int*)auxp->base_addr; + for (i=0; ielem_len; + assert (auxp->rank==1); + assert (auxp->type==CFI_type_int); + assert (auxp->dim[0].sm>0); + assert ((size_t)auxp->dim[0].sm==el); + if (auxp->dim[0].extent==ex + && auxp->dim[0].lower_bound==lb) + { + switch(auxp->attribute) + { + case CFI_attribute_pointer: + case CFI_attribute_allocatable: + if (!c_vrfy (auxp)) + break; + is_ok = true; + break; + case CFI_attribute_other: + if (!c_vrfy (auxp)) + break; + is_ok = (lb==0); + break; + default: + assert (false); + break; + } + } + return is_ok; +} + Index: Fortran/gfortran/regression/PR94331.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR94331.f90 @@ -0,0 +1,252 @@ +! { dg-do run } +! { dg-additional-sources PR94331.c } +! +! Test the fix for PR94331 +! + +program main_p + + use, intrinsic :: iso_c_binding, only: & + c_int + + implicit none + + integer :: i + integer, parameter :: ex = 11 + integer, parameter :: lb = 11 + integer, parameter :: ub = ex+lb-1 + integer, parameter :: u(*) = [(i, i=1,ex)] + + interface + function checkb_p_as(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), pointer, intent(in) :: a(:) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_p_as + function checkb_a_as(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), allocatable, intent(in) :: a(:) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_a_as + function checkb_o_as(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), intent(in) :: a(:) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_o_as + function checkb_p_ar(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), pointer, intent(in) :: a(..) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_p_ar + function checkb_a_ar(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), allocatable, intent(in) :: a(..) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_a_ar + function checkb_o_ar(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), intent(in) :: a(..) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_o_ar + end interface + + integer(kind=c_int), target :: a(lb:ub) + integer(kind=c_int), allocatable, target :: b(:) + integer(kind=c_int), pointer :: p(:) + + a = u + if(lbound(a,1)/=lb) stop 1 + if(ubound(a,1)/=ub) stop 2 + if(any(shape(a)/=[ex])) stop 3 + if(.not.checkb_p_as(a, lb, ub)) stop 4 + if(lbound(a,1)/=lb) stop 5 + if(ubound(a,1)/=ub) stop 6 + if(any(shape(a)/=[ex])) stop 7 + if(any(a/=u)) stop 8 + ! + a = u + if(lbound(a,1)/=lb) stop 9 + if(ubound(a,1)/=ub) stop 10 + if(any(shape(a)/=[ex])) stop 11 + if(.not.checkb_p_ar(a, lb, ub)) stop 12 + if(lbound(a,1)/=lb) stop 13 + if(ubound(a,1)/=ub) stop 14 + if(any(shape(a)/=[ex])) stop 15 + if(any(a/=u)) stop 16 + ! + a = u + if(lbound(a,1)/=lb) stop 17 + if(ubound(a,1)/=ub) stop 18 + if(any(shape(a)/=[ex])) stop 19 + if(.not.checkb_o_as(a, 0, ex-1))stop 20 + if(lbound(a,1)/=lb) stop 21 + if(ubound(a,1)/=ub) stop 22 + if(any(shape(a)/=[ex])) stop 23 + if(any(a/=u)) stop 24 + ! + a = u + if(lbound(a,1)/=lb) stop 25 + if(ubound(a,1)/=ub) stop 26 + if(any(shape(a)/=[ex])) stop 27 + if(.not.checkb_o_ar(a, 0, ex-1))stop 28 + if(lbound(a,1)/=lb) stop 29 + if(ubound(a,1)/=ub) stop 30 + if(any(shape(a)/=[ex])) stop 31 + if(any(a/=u)) stop 32 + ! + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 33 + if(ubound(b,1)/=ub) stop 34 + if(any(shape(b)/=[ex])) stop 35 + if(.not.checkb_p_as(b, lb, ub)) stop 36 + if(.not.allocated(b)) stop 37 + if(lbound(b,1)/=lb) stop 38 + if(ubound(b,1)/=ub) stop 39 + if(any(shape(b)/=[ex])) stop 40 + if(any(b/=u)) stop 41 + ! + deallocate(b) + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 42 + if(ubound(b,1)/=ub) stop 43 + if(any(shape(b)/=[ex])) stop 44 + if(.not.checkb_p_ar(b, lb, ub)) stop 45 + if(.not.allocated(b)) stop 46 + if(lbound(b,1)/=lb) stop 47 + if(ubound(b,1)/=ub) stop 48 + if(any(shape(b)/=[ex])) stop 49 + if(any(b/=u)) stop 50 + ! + deallocate(b) + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 51 + if(ubound(b,1)/=ub) stop 52 + if(any(shape(b)/=[ex])) stop 53 + if(.not.checkb_a_as(b, lb, ub)) stop 54 + if(.not.allocated(b)) stop 55 + if(lbound(b,1)/=lb) stop 56 + if(ubound(b,1)/=ub) stop 57 + if(any(shape(b)/=[ex])) stop 58 + if(any(b/=u)) stop 59 + ! + deallocate(b) + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 60 + if(ubound(b,1)/=ub) stop 61 + if(any(shape(b)/=[ex])) stop 62 + if(.not.checkb_a_ar(b, lb, ub)) stop 63 + if(.not.allocated(b)) stop 64 + if(lbound(b,1)/=lb) stop 65 + if(ubound(b,1)/=ub) stop 66 + if(any(shape(b)/=[ex])) stop 67 + if(any(b/=u)) stop 68 + ! + deallocate(b) + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 69 + if(ubound(b,1)/=ub) stop 70 + if(any(shape(b)/=[ex])) stop 71 + if(.not.checkb_o_as(b, 0, ex-1))stop 72 + if(.not.allocated(b)) stop 73 + if(lbound(b,1)/=lb) stop 74 + if(ubound(b,1)/=ub) stop 75 + if(any(shape(b)/=[ex])) stop 76 + if(any(b/=u)) stop 77 + ! + deallocate(b) + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 78 + if(ubound(b,1)/=ub) stop 79 + if(any(shape(b)/=[ex])) stop 80 + if(.not.checkb_o_ar(b, 0, ex-1))stop 81 + if(.not.allocated(b)) stop 82 + if(lbound(b,1)/=lb) stop 83 + if(ubound(b,1)/=ub) stop 84 + if(any(shape(b)/=[ex])) stop 85 + if(any(b/=u)) stop 86 + deallocate(b) + ! + p(lb:ub) => a + if(lbound(p,1)/=lb) stop 87 + if(ubound(p,1)/=ub) stop 88 + if(any(shape(p)/=[ex])) stop 89 + if(.not.checkb_p_as(p, lb, ub)) stop 90 + if(.not.associated(p)) stop 91 + if(.not.associated(p, a)) stop 92 + if(lbound(p,1)/=lb) stop 93 + if(ubound(p,1)/=ub) stop 94 + if(any(shape(p)/=[ex])) stop 95 + if(any(p/=u)) stop 96 + ! + nullify(p) + p(lb:ub) => a + if(lbound(p,1)/=lb) stop 97 + if(ubound(p,1)/=ub) stop 98 + if(any(shape(p)/=[ex])) stop 99 + if(.not.checkb_p_ar(p, lb, ub)) stop 100 + if(.not.associated(p)) stop 101 + if(.not.associated(p, a)) stop 102 + if(lbound(p,1)/=lb) stop 103 + if(ubound(p,1)/=ub) stop 104 + if(any(shape(p)/=[ex])) stop 105 + if(any(p/=u)) stop 106 + ! + nullify(p) + p(lb:ub) => a + if(lbound(p,1)/=lb) stop 107 + if(ubound(p,1)/=ub) stop 108 + if(any(shape(p)/=[ex])) stop 109 + if(.not.checkb_o_as(p, 0, ex-1))stop 110 + if(.not.associated(p)) stop 111 + if(.not.associated(p, a)) stop 112 + if(lbound(p,1)/=lb) stop 113 + if(ubound(p,1)/=ub) stop 114 + if(any(shape(p)/=[ex])) stop 115 + if(any(p/=u)) stop 116 + ! + nullify(p) + p(lb:ub) => a + if(lbound(p,1)/=lb) stop 117 + if(ubound(p,1)/=ub) stop 118 + if(any(shape(p)/=[ex])) stop 119 + if(.not.checkb_o_ar(p, 0, ex-1))stop 120 + if(.not.associated(p)) stop 121 + if(.not.associated(p, a)) stop 122 + if(lbound(p,1)/=lb) stop 123 + if(ubound(p,1)/=ub) stop 124 + if(any(shape(p)/=[ex])) stop 125 + if(any(p/=u)) stop 126 + nullify(p) + stop + +end program main_p Index: Fortran/gfortran/regression/PR95196.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR95196.f90 @@ -0,0 +1,83 @@ +! { dg-do run } + +program rnk_p + + implicit none + + integer, parameter :: n = 10 + integer, parameter :: m = 5 + integer, parameter :: s = 4 + integer, parameter :: l = 4 + integer, parameter :: u = s+l-1 + + integer :: a(n) + integer :: b(n,n) + integer :: c(n,n,n) + integer :: r(s*s*s) + integer :: i + + a = reshape([(i, i=1,n)], [n]) + b = reshape([(i, i=1,n*n)], [n,n]) + c = reshape([(i, i=1,n*n*n)], [n,n,n]) + r(1:s) = a(l:u) + call rnk_s(a(l:u), r(1:s)) + r(1:s*s) = reshape(b(l:u,l:u), [s*s]) + call rnk_s(b(l:u,l:u), r(1:s*s)) + r = reshape(c(l:u,l:u,l:u), [s*s*s]) + call rnk_s(c(l:u,l:7,l:u), r) + stop + +contains + + subroutine rnk_s(a, b) + integer, intent(in) :: a(..) + integer, intent(in) :: b(:) + + !integer :: l(rank(a)), u(rank(a)) does not work due to Bug 94048 + integer, allocatable :: lb(:), ub(:) + integer :: i, j, k, l + + lb = lbound(a) + ub = ubound(a) + select rank(a) + rank(1) + if(any(lb/=lbound(a))) stop 11 + if(any(ub/=ubound(a))) stop 12 + if(size(a)/=size(b)) stop 13 + do i = 1, size(a) + if(a(i)/=b(i)) stop 14 + end do + rank(2) + if(any(lb/=lbound(a))) stop 21 + if(any(ub/=ubound(a))) stop 22 + if(size(a)/=size(b)) stop 23 + k = 0 + do j = 1, size(a, dim=2) + do i = 1, size(a, dim=1) + k = k + 1 + if(a(i,j)/=b(k)) stop 24 + end do + end do + rank(3) + if(any(lb/=lbound(a))) stop 31 + if(any(ub/=ubound(a))) stop 32 + if(size(a)/=size(b)) stop 33 + l = 0 + do k = 1, size(a, dim=3) + do j = 1, size(a, dim=2) + do i = 1, size(a, dim=1) + l = l + 1 + ! print *, a(i,j,k), b(l) + if(a(i,j,k)/=b(l)) stop 34 + end do + end do + end do + rank default + stop 171 + end select + deallocate(lb, ub) + return + end subroutine rnk_s + +end program rnk_p + Index: Fortran/gfortran/regression/PR95214.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR95214.f90 @@ -0,0 +1,84 @@ +! { dg-do run } +! +! PR fortran/95214 +! + +program chr_p + + implicit none + + integer, parameter :: u = 65 + + integer, parameter :: n = 26 + + character :: c(n) + integer :: i + + c = [(achar(i), i=u,u+n-1)] + call chr_s(c, c) + call gfc_descriptor_c_char(c) + call s1(c) + call s1s_a(c) + call s1s_b(c) + call s2(c) + stop + +contains + + subroutine chr_s(a, b) + character, intent(in) :: a(..) + character, intent(in) :: b(:) + + integer :: i + + select rank(a) + rank(1) + do i = 1, size(a) + if(a(i)/=b(i)) stop 1 + end do + rank default + stop 2 + end select + return + end subroutine chr_s + + ! From Bug 66833 + ! Contributed by Damian Rouson + subroutine gfc_descriptor_c_char(a) + character a(..) + if(rank(a)/=1) stop 3 ! ICE (also for lbound, ubound, and c_loc) + end subroutine gfc_descriptor_c_char + + + ! From Bug 67938 + ! Contributed by Gerhard Steinmetz + + ! example z1.f90 + subroutine s1(x) + character(1) :: x(..) + if(any(lbound(x)/=[1])) stop 4 + if(any(ubound(x)/=[n])) stop 5 + end subroutine s1 + + ! example z1s.f90 + subroutine s1s_a(x) + character :: x(..) + if(size(x)/=n) stop 6 + end subroutine s1s_a + + subroutine s1s_b(x) + character(77) :: x(..) + if(size(x)/=n) stop 7 + end subroutine s1s_b + + ! example z2.f90 + subroutine s2(x) + character(1) :: x(..) + if(lbound(x, dim=1)/=1) stop 8 + if(ubound(x, dim=1)/=n) stop 9 + if(size(x, dim=1)/=n) stop 10 + end subroutine s2 + +end program chr_p + + Index: Fortran/gfortran/regression/PR95331.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR95331.f90 @@ -0,0 +1,163 @@ +! { dg-do run } +! +! PR fortran/95331 +! + +program main_p + + implicit none + + integer, parameter :: n = 10 + integer, parameter :: m = 5 + + integer, parameter :: b = 3 + integer, parameter :: t = n+b-1 + + integer, parameter :: l = 4 + integer, parameter :: u = 7 + integer, parameter :: s = 3 + integer, parameter :: e = (u-l)/s+1 + + call test_f() + call test_s() + call test_p() + call test_a() + stop + +contains + + subroutine test_f() + integer :: x(n,n) + integer :: y(b:t) + integer :: i + + x = reshape([(i, i=1,n*n)], [n,n]) + y = x(:,m) + call sub_s(x(:,m), y, n) + call sub_s(y, x(:,m), n) + return + end subroutine test_f + + subroutine test_s() + integer :: x(n,n) + integer :: v(e) + integer :: i + + x = reshape([(i, i=1,n*n)], [n,n]) + v = x(l:u:s,m) + call sub_s(v, v, e) + call sub_s(x(l:u:s,m), v, e) + call sub_s(v, x(l:u:s,m), e) + return + end subroutine test_s + + subroutine test_p() + integer, target :: x(n,n) + integer, pointer :: p(:) + integer :: v(e) + integer :: i + + x = reshape([(i, i=1,n*n)], [n,n]) + v = x(l:u:s,m) + p => x(:,m) + call sub_s(p(l:u:s), v, e) + p => x(l:u:s,m) + call sub_s(p, v, e) + p(l:) => x(l:u:s,m) + call sub_s(p, v, e) + p(l:l+e-1) => x(l:u:s,m) + call sub_s(p, v, e) + allocate(p(n)) + p(:) = x(:,m) + call sub_s(p(l:u:s), v, e) + deallocate(p) + allocate(p(e)) + p(:) = x(l:u:s,m) + call sub_s(p, v, e) + deallocate(p) + allocate(p(l:l+e-1)) + p(:) = x(l:u:s,m) + call sub_s(p, v, e) + deallocate(p) + allocate(p(l:l+e-1)) + p(l:) = x(l:u:s,m) + call sub_s(p, v, e) + deallocate(p) + allocate(p(l:l+e-1)) + p(l:l+e-1) = x(l:u:s,m) + call sub_s(p, v, e) + deallocate(p) + return + end subroutine test_p + + subroutine test_a() + integer :: x(n,n) + integer, allocatable :: a(:) + integer :: v(e) + integer :: i + + x = reshape([(i, i=1,n*n)], [n,n]) + v = x(l:u:s,m) + a = x(:,m) + call sub_s(a(l:u:s), v, e) + deallocate(a) + allocate(a(n)) + a(:) = x(:,m) + call sub_s(a(l:u:s), v, e) + deallocate(a) + a = x(l:u:s,m) + call sub_s(a, v, e) + deallocate(a) + allocate(a(e)) + a(:) = x(l:u:s,m) + call sub_s(a, v, e) + deallocate(a) + allocate(a(l:l+e-1)) + a(:) = x(l:u:s,m) + call sub_s(a, v, e) + deallocate(a) + allocate(a(l:l+e-1)) + a(l:) = x(l:u:s,m) + call sub_s(a, v, e) + deallocate(a) + allocate(a(l:l+e-1)) + a(l:l+e-1) = x(l:u:s,m) + call sub_s(a, v, e) + deallocate(a) + return + end subroutine test_a + + subroutine sub_s(a, b, n) + class(*), intent(in) :: a(:) + integer, intent(in) :: b(:) + integer, intent(in) :: n + + integer :: i + + if(lbound(a, dim=1)/=1) stop 1001 + if(ubound(a, dim=1)/=n) stop 1002 + if(any(shape(a)/=[n])) stop 1003 + if(size(a, dim=1)/=n) stop 1004 + if(size(a)/=size(b)) stop 1005 + do i = 1, n + call vrfy(a(i), b(i)) + end do + return + end subroutine sub_s + + subroutine vrfy(a, b) + class(*), intent(in) :: a + integer, intent(in) :: b + + select type (a) + type is (integer) + !print *, a, b + if(a/=b) stop 2001 + class default + STOP 2002 + end select + return + end subroutine vrfy + +end program main_p + Index: Fortran/gfortran/regression/PR95352.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR95352.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! Test the fix for PR95352 +! + +module ice6_m + + implicit none + +contains + + function ice6_s(a) result(ierr) + integer, intent(in) :: a(..) + + integer :: ierr + + integer :: lb + + select rank(a) + rank(*) + lb = lbound(a, dim=1) + if(lbound(a, dim=1)/=lb) ierr = -1 + end select + return + end function ice6_s + +end module ice6_m Index: Fortran/gfortran/regression/PR96726.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR96726.f90 @@ -0,0 +1,72 @@ +! { dg-do run } +! +! Test the fix for PR96726 +! + +module cref_m + + implicit none + + private + + public :: & + sizeish + +contains + + pure function sizeish(a) result(s) + integer, intent(in) :: a(..) + + integer :: s + + s = size(a) + return + end function sizeish + +end module cref_m + +program cref_p + + use cref_m, only: & + sizeish + + implicit none + + integer :: i + + integer, parameter :: n = 3 + integer, parameter :: p(*) = [(i, i=1,n*n)] + + integer :: a(n,n) + integer :: b(n*n) + + a = reshape(p, shape=[n,n]) + call isub_a(a, b) + if (any(b/=p)) stop 1 + call isub_b(a, b) + if (any(b/=p)) stop 2 + stop + +contains + + subroutine isub_a(a, b) + integer, intent(in) :: a(..) + integer, intent(out) :: b(size(a)) + + integer :: i + + b = [(i, i=1,size(b))] + return + end subroutine isub_a + + subroutine isub_b(a, b) + integer, intent(in) :: a(..) + integer, intent(out) :: b(sizeish(a)) + + integer :: i + + b = [(i, i=1,sizeish(b))] + return + end subroutine isub_b + +end program cref_p Index: Fortran/gfortran/regression/PR96727.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR96727.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! Test the fix for PR96727 +! + +program cref_p + + implicit none + + integer :: i + + integer, parameter :: n = 3 + integer, parameter :: p(*) = [(i, i=1,n*n)] + character(len=*), parameter :: q = repeat('a', n*n) + + integer :: a(n,n) + character(len=n*n) :: c + + a = reshape(p, shape=[n,n]) + call csub(a, c) + if (c/=q) stop 1 + stop + +contains + + subroutine csub(a, b) + integer, intent(in) :: a(..) + character(len=size(a)), intent(out) :: b + + b = repeat('a', len(b)) + return + end subroutine csub + +end program cref_p Index: Fortran/gfortran/regression/PR96728.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR96728.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! +! Test the fix for PR96728 +! + +module cref_m + + implicit none + + private + + public :: & + isub_a_m + +contains + + subroutine isub_a_m(a, b) + integer, intent(in) :: a(..) + integer, intent(out) :: b(size(a)) + + integer :: i + + b = [(i, i=1,size(b))] + return + end subroutine isub_a_m + +end module cref_m + +program cref_p + + use cref_m, only: & + isub_a_m + + implicit none + + integer :: i + + integer, parameter :: n = 3 + integer, parameter :: p(*) = [(i, i=1,n*n)] + + integer :: a(n,n) + integer :: b(n*n) + + a = reshape(p, shape=[n,n]) + call isub_a_m(a, b) + if (any(b/=p)) stop 1 + stop + +end program cref_p Index: Fortran/gfortran/regression/PR97046.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/PR97046.f90 @@ -0,0 +1,58 @@ +! { dg-do run } +! +! Test the fix for PR94331 +! +! Contributed by Igor Gayday +! + +MODULE FOO + + implicit none + + INTEGER, parameter :: n = 11 + +contains + + SUBROUTINE dummyc(x0) BIND(C) + type(*), dimension(..) :: x0 + if(LBOUND(x0,1)/=1) stop 5 + if(UBOUND(x0,1)/=n) stop 6 + if(rank(x0)/=1) stop 7 + END SUBROUTINE dummyc + + SUBROUTINE dummy(x0) + type(*), dimension(..) :: x0 + call dummyc(x0) + END SUBROUTINE dummy + +END MODULE + +PROGRAM main + USE FOO + IMPLICIT NONE + integer :: before(2), after(2) + + DOUBLE PRECISION, ALLOCATABLE :: buf(:) + DOUBLE PRECISION :: buf2(n) + + ALLOCATE(buf(n)) + before(1) = LBOUND(buf,1) + before(2) = UBOUND(buf,1) + CALL dummy (buf) + after(1) = LBOUND(buf,1) + after(2) = UBOUND(buf,1) + deallocate(buf) + + if (before(1) .NE. after(1)) stop 1 + if (before(2) .NE. after(2)) stop 2 + + before(1) = LBOUND(buf2,1) + before(2) = UBOUND(buf2,1) + CALL dummy (buf2) + after(1) = LBOUND(buf2,1) + after(2) = UBOUND(buf2,1) + + if (before(1) .NE. after(1)) stop 3 + if (before(2) .NE. after(2)) stop 4 + +END PROGRAM Index: Fortran/gfortran/regression/Wall.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/Wall.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options -Wall } +! PR 30437 Test for Wall +program main + character (len=40) & + c + c = "Hello, & + world!" ! { dg-warning "Missing '&' in continued character constant" } + if (c.ne.& + "Hello, world!")& + STOP 1;end program main + Index: Fortran/gfortran/regression/Wno-all.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/Wno-all.f90 @@ -0,0 +1,12 @@ +! PR 30437 Test for negative Wall +! { dg-do run } +! { dg-options "-Wall -Wno-all" } +program main + character (len=40) & + c + c = "Hello, & + world!" ! { dg-bogus "Warning: Missing '&' in continued character constant" } + if (c.ne.& + "Hello, world!")& + STOP 1;end program main +