diff options
Diffstat (limited to 'gcc/testsuite/gfortran.dg')
52 files changed, 1501 insertions, 139 deletions
diff --git a/gcc/testsuite/gfortran.dg/aliasing_dummy_1.f90 b/gcc/testsuite/gfortran.dg/aliasing_dummy_1.f90 index dcc2d7c..a231a4d 100644 --- a/gcc/testsuite/gfortran.dg/aliasing_dummy_1.f90 +++ b/gcc/testsuite/gfortran.dg/aliasing_dummy_1.f90 @@ -48,19 +48,19 @@ contains subroutine foo1 (slist, i) character(*), dimension(*) :: slist integer i - write (slist(i), '(2hi=,i3)') i + write (slist(i), '(2hi=,i3)') i ! { dg-warning "H format specifier" } end subroutine foo1 subroutine foo2 (slist, i) character(5), dimension(:) :: slist integer i - write (slist(i), '(2hi=,i3)') i + write (slist(i), '(2hi=,i3)') i ! { dg-warning "H format specifier" } end subroutine foo2 subroutine foo3 (slist, i) character(5), dimension(:,:) :: slist integer i - write (slist(1,1), '(2hi=,i3)') i + write (slist(1,1), '(2hi=,i3)') i ! { dg-warning "H format specifier" } end subroutine foo3 end program test_lex diff --git a/gcc/testsuite/gfortran.dg/argument_checking_15.f90 b/gcc/testsuite/gfortran.dg/argument_checking_15.f90 index e79541f..63931a2 100644 --- a/gcc/testsuite/gfortran.dg/argument_checking_15.f90 +++ b/gcc/testsuite/gfortran.dg/argument_checking_15.f90 @@ -45,8 +45,8 @@ subroutine test() implicit none character(len=5), pointer :: c character(len=5) :: str(5) -call foo(c) ! { dg-warning "Character length mismatch" } -call bar(str) ! { dg-warning "Character length mismatch" } +call foo(c) ! { dg-error "Character length mismatch" } +call bar(str) ! { dg-error "Character length mismatch" } contains subroutine foo(a) character(len=3), pointer :: a diff --git a/gcc/testsuite/gfortran.dg/argument_checking_27.f90 b/gcc/testsuite/gfortran.dg/argument_checking_27.f90 new file mode 100644 index 0000000..06dd187 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_27.f90 @@ -0,0 +1,240 @@ +! { dg-do compile } +! { dg-additional-options "-std=f2018 -Wcharacter-truncation" } +! PR fortran/93330 +! +! Exercise compile-time checking of character length of dummy vs. +! actual arguments. Based on original testcase by Tobias Burnus + +module m + use iso_c_binding, only: c_char + implicit none +contains + ! scalar dummy + ! character(kind=1): + subroutine zero(x, y) + character(kind=1,len=0), value :: x + character(kind=1,len=1), value :: y + print '(5a)', 'zero >', x, '< >', y, '<' + end + subroutine one(x, y) + character(kind=1,len=1), value :: x + character(kind=1,len=1), value :: y + print '(5a)','one >', x, '< >', y, '<' + end + subroutine two(x, y) + character(kind=1,len=2), value :: x + character(kind=1,len=1), value :: y + print '(5a)','two >', x, '< >', y, '<' + end + subroutine cbind(x, y) bind(C) + character(kind=c_char,len=1), value :: x + character(kind=c_char,len=1), value :: y + print '(5a)','cbind >', x, '< >', y, '<' + end + + ! character(kind=4): + subroutine zero4(x, y) + character(kind=4,len=0), value :: x + character(kind=1,len=1), value :: y + print '(5a)', 'zero4 >', x, '< >', y, '<' + end + subroutine one4(x, y) + character(kind=4,len=1), value :: x + character(kind=1,len=1), value :: y + print '(5a)','one4 >', x, '< >', y, '<' + end + subroutine two4(x, y) + character(kind=4,len=2), value :: x + character(kind=1,len=1), value :: y + print '(5a)','two4 >', x, '< >', y, '<' + end + + ! character(kind=1): + ! array dummy, assumed size + subroutine zero_0(x, y) + character(kind=1,len=0) :: x(*) + character(kind=1,len=1), value :: y + print '(5a)', 'zero_0 >', x(1), '< >', y, '<' + end + subroutine one_0(x, y) + character(kind=1,len=1) :: x(*) + character(kind=1,len=1), value :: y + print '(5a)','one_0 >', x(1), '< >', y, '<' + end + subroutine two_0(x, y) + character(kind=1,len=2) :: x(*) + character(kind=1,len=1), value :: y + print '(5a)','two_0 >', x(1), '< >', y, '<' + end + + ! array dummy, explicit size + subroutine zero_1(x, y) + character(kind=1,len=0) :: x(1) + character(kind=1,len=1), value :: y + print '(5a)', 'zero_1 >', x(1), '< >', y, '<' + end + subroutine one_1(x, y) + character(kind=1,len=1) :: x(1) + character(kind=1,len=1), value :: y + print '(5a)','one_1 >', x(1), '< >', y, '<' + end + subroutine two_1(x, y) + character(kind=1,len=2) :: x(1) + character(kind=1,len=1), value :: y + print '(5a)','two_1 >', x(1), '< >', y, '<' + end + + ! array dummy, assumed shape + subroutine zero_a(x, y) + character(kind=1,len=0) :: x(:) + character(kind=1,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)', 'zero_a >', x(1), '< >', y, '<' + end + subroutine one_a(x, y) + character(kind=1,len=1) :: x(:) + character(kind=1,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)','one_a >', x(1), '< >', y, '<' + end + subroutine two_a(x, y) + character(kind=1,len=2) :: x(:) + character(kind=1,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)','two_a >', x(1), '< >', y, '<' + end + + ! character(kind=4): + ! array dummy, assumed size + subroutine zero4_0(x, y) + character(kind=4,len=0) :: x(*) + character(kind=4,len=1), value :: y + print '(5a)', 'zero4_0 >', x(1), '< >', y, '<' + end + subroutine one4_0(x, y) + character(kind=4,len=1) :: x(*) + character(kind=4,len=1), value :: y + print '(5a)','one4_0 >', x(1), '< >', y, '<' + end + subroutine two4_0(x, y) + character(kind=4,len=2) :: x(*) + character(kind=4,len=1), value :: y + print '(5a)','two4_0 >', x(1), '< >', y, '<' + end + + ! array dummy, explicit size + subroutine zero4_1(x, y) + character(kind=4,len=0) :: x(1) + character(kind=4,len=1), value :: y + print '(5a)', 'zero4_1 >', x(1), '< >', y, '<' + end + subroutine one4_1(x, y) + character(kind=4,len=1) :: x(1) + character(kind=4,len=1), value :: y + print '(5a)','one4_1 >', x(1), '< >', y, '<' + end + subroutine two4_1(x, y) + character(kind=4,len=2) :: x(1) + character(kind=4,len=1), value :: y + print '(5a)','two4_1 >', x(1), '< >', y, '<' + end + + ! array dummy, assumed shape + subroutine zero4_a(x, y) + character(kind=4,len=0) :: x(:) + character(kind=4,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)', 'zero4_a >', x(1), '< >', y, '<' + end + subroutine one4_a(x, y) + character(kind=4,len=1) :: x(:) + character(kind=4,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)','one4_a >', x(1), '< >', y, '<' + end + subroutine two4_a(x, y) + character(kind=4,len=2) :: x(:) + character(kind=4,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)','two4_a >', x(1), '< >', y, '<' + end +end + +program p + use m + implicit none + call zero('', '1') + call one ('', '2') ! { dg-error "length of actual argument shorter" } + call one ('b'(3:2),'3') ! { dg-error "length of actual argument shorter" } + call two ('', '4') ! { dg-error "length of actual argument shorter" } + call two ('f','5') ! { dg-error "length of actual argument shorter" } + + call cbind('', '6') ! { dg-error "length of actual argument shorter" } + call cbind('ABC','7') ! { dg-warning "length of actual argument longer" } + + ! character(kind=4): + call zero4(4_'', '8') + call zero4(4_'3','9') ! { dg-warning "length of actual argument longer" } + call one4 (4_'', 'A') ! { dg-error "length of actual argument shorter" } + call one4 (4_'b'(3:2),'B') ! { dg-error "length of actual argument shorter" } + call one4 (4_'bbcd'(3:3),'C') + call one4 (4_'cd','D') ! { dg-warning "length of actual argument longer" } + call two4 (4_'', 'E') ! { dg-error "length of actual argument shorter" } + call two4 (4_'f', 'F') ! { dg-error "length of actual argument shorter" } + call two4 (4_'fgh','G') ! { dg-warning "length of actual argument longer" } + + ! array dummy, assumed size + call zero_0([''],'a') + call zero_0(['a'],'b') + call one_0 ([''],'c') + call one_0 (['b'],'d') + call one_0 (['cd'],'e') + call two_0 ([''],'f') + call two_0 (['fg'],'g') + + ! array dummy, explicit size + call zero_1([''],'a') + call zero_1(['a'],'b') ! { dg-warning "actual argument longer" } + call one_1 ([''],'c') ! { dg-error "too few elements for dummy" } + call one_1 (['b'],'d') + call one_1 (['cd'],'e') ! { dg-warning "actual argument longer" } + call two_1 ([''],'f') ! { dg-error "too few elements for dummy" } + call two_1 (['fg'],'h') + + ! array dummy, assumed shape + call zero_a([''],'a') + call zero_a(['a'],'b') ! { dg-error "Character length mismatch" } + call one_a ([''],'c') ! { dg-error "Character length mismatch" } + call one_a (['b'],'d') + call one_a (['cd'],'e') ! { dg-error "Character length mismatch" } + call two_a ([''],'f') ! { dg-error "Character length mismatch" } + call two_a (['fg'],'h') + + ! character(kind=4): + ! array dummy, assumed size + call zero4_0([4_''],4_'a') + call zero4_0([4_'a'],4_'b') + call one4_0 ([4_''],4_'c') + call one4_0 ([4_'b'],4_'d') + call one4_0 ([4_'cd'],4_'e') + call two4_0 ([4_''],4_'f') + call two4_0 ([4_'fg'],4_'g') + + ! array dummy, explicit size + call zero4_1([4_''],4_'a') + call zero4_1([4_'a'],4_'b') ! { dg-warning "actual argument longer" } + call one4_1 ([4_''],4_'c') ! { dg-error "too few elements for dummy" } + call one4_1 ([4_'b'],4_'d') + call one4_1 ([4_'cd'],4_'e') ! { dg-warning "actual argument longer" } + call two4_1 ([4_''],4_'f') ! { dg-error "too few elements for dummy" } + call two4_1 ([4_'fg'],4_'h') + + ! array dummy, assumed shape + call zero4_a([4_''],4_'a') + call zero4_a([4_'a'],4_'b') ! { dg-error "Character length mismatch" } + call one4_a ([4_''],4_'c') ! { dg-error "Character length mismatch" } + call one4_a ([4_'b'],4_'d') + call one4_a ([4_'cd'],4_'e') ! { dg-error "Character length mismatch" } + call two4_a ([4_''],4_'f') ! { dg-error "Character length mismatch" } + call two4_a ([4_'fg'],4_'h') +end diff --git a/gcc/testsuite/gfortran.dg/bounds_check_strlen_7.f90 b/gcc/testsuite/gfortran.dg/bounds_check_strlen_7.f90 index 99a0d86..d8bb8cf 100644 --- a/gcc/testsuite/gfortran.dg/bounds_check_strlen_7.f90 +++ b/gcc/testsuite/gfortran.dg/bounds_check_strlen_7.f90 @@ -18,7 +18,8 @@ END MODULE m PROGRAM main USE m IMPLICIT NONE - CALL test ('') ! 0 length, but not absent argument. + ! 0 length, but not absent argument. + CALL test ('') ! { dg-warning "Character length of actual argument" } END PROGRAM main ! { dg-output "shorter than the declared one for dummy argument 'opt' \\(0/5\\)" } diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03 index 79cf2c1..da20835 100644 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03 +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03 @@ -1,5 +1,5 @@ ! { dg-do run } -! { dg-additional-sources c_f_pointer_shape_tests_2_driver.c } +! { dg-additional-sources c_f_pointer_shape_tests_driver.c } ! Verify that the optional SHAPE parameter to c_f_pointer can be of any ! valid integer kind. We don't test all kinds here since it would be ! difficult to know what kinds are valid for the architecture we're running on. diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c deleted file mode 100644 index 1282beb..0000000 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c +++ /dev/null @@ -1,46 +0,0 @@ -#define NUM_ELEMS 10 -#define NUM_ROWS 2 -#define NUM_COLS 3 - -void test_long_long_1d(int *array, int num_elems); -void test_long_long_2d(int *array, int num_rows, int num_cols); -void test_long_1d(int *array, int num_elems); -void test_int_1d(int *array, int num_elems); -void test_short_1d(int *array, int num_elems); -void test_mixed(int *array, int num_elems); - -int main(int argc, char **argv) -{ - int my_array[NUM_ELEMS]; - int my_2d_array[NUM_ROWS][NUM_COLS]; - int i, j; - - for(i = 0; i < NUM_ELEMS; i++) - my_array[i] = i; - - for(i = 0; i < NUM_ROWS; i++) - for(j = 0; j < NUM_COLS; j++) - my_2d_array[i][j] = (i*NUM_COLS) + j; - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. */ - test_long_long_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. - The indices are transposed for Fortran. */ - test_long_long_2d(my_2d_array[0], NUM_COLS, NUM_ROWS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_long. */ - test_long_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_int. */ - test_int_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_short. */ - test_short_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_int and - kind=c_long_long. */ - test_mixed(my_array, NUM_ELEMS); - - return 0; -} diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4.f03 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4.f03 index 3f60f17..519087a 100644 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4.f03 +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4.f03 @@ -1,5 +1,5 @@ ! { dg-do run } -! { dg-additional-sources c_f_pointer_shape_tests_2_driver.c } +! { dg-additional-sources c_f_pointer_shape_tests_driver.c } ! Verify that the optional SHAPE parameter to c_f_pointer can be of any ! valid integer kind. We don't test all kinds here since it would be ! difficult to know what kinds are valid for the architecture we're running on. diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4_driver.c b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4_driver.c deleted file mode 100644 index 1282beb..0000000 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4_driver.c +++ /dev/null @@ -1,46 +0,0 @@ -#define NUM_ELEMS 10 -#define NUM_ROWS 2 -#define NUM_COLS 3 - -void test_long_long_1d(int *array, int num_elems); -void test_long_long_2d(int *array, int num_rows, int num_cols); -void test_long_1d(int *array, int num_elems); -void test_int_1d(int *array, int num_elems); -void test_short_1d(int *array, int num_elems); -void test_mixed(int *array, int num_elems); - -int main(int argc, char **argv) -{ - int my_array[NUM_ELEMS]; - int my_2d_array[NUM_ROWS][NUM_COLS]; - int i, j; - - for(i = 0; i < NUM_ELEMS; i++) - my_array[i] = i; - - for(i = 0; i < NUM_ROWS; i++) - for(j = 0; j < NUM_COLS; j++) - my_2d_array[i][j] = (i*NUM_COLS) + j; - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. */ - test_long_long_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. - The indices are transposed for Fortran. */ - test_long_long_2d(my_2d_array[0], NUM_COLS, NUM_ROWS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_long. */ - test_long_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_int. */ - test_int_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_short. */ - test_short_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_int and - kind=c_long_long. */ - test_mixed(my_array, NUM_ELEMS); - - return 0; -} diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_7.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_7.f90 new file mode 100644 index 0000000..3504e68 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_7.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-options "-std=f2023" } +program lower + use iso_c_binding + type(c_ptr) :: x + integer, target :: array_2d(12), array_3d(24) + integer, pointer :: ptr_2d(:, :), ptr_3d(:, :, :) + integer :: myshape_2d(2), myshape_3d(3) + integer :: mylower_2d(2), mylower_3d(3) + + array_2d = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12] + x = c_loc(array_2d) + myshape_2d = [3, 4] + mylower_2d = [2, 2] + + call c_f_pointer(x, ptr_2d, shape=myshape_2d, lower=mylower_2d) + if (any(lbound(ptr_2d) /= [2, 2])) stop 1 + if (any(ubound(ptr_2d) /= [4, 5])) stop 2 + if (any(shape(ptr_2d) /= [3, 4])) stop 3 + if (ptr_2d(2, 2) /= 1) stop 4 + if (ptr_2d(3, 4) /= 8) stop 5 + if (ptr_2d(4, 5) /= 12) stop 6 + + array_3d = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24] + x = c_loc(array_3d) + myshape_3d = [2, 3, 4] + mylower_3d = [-1, -2, -3] + + call c_f_pointer(x, ptr_3d, shape=myshape_3d, lower=mylower_3d) + if (any(lbound(ptr_3d) /= [-1, -2, -3])) stop 7 + if (any(ubound(ptr_3d) /= [0, 0, 0])) stop 8 + if (any(shape(ptr_3d) /= [2, 3, 4])) stop 9 + if (ptr_3d(0, 0, 0) /= 24) stop 10 + +end program lower diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_8.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_8.f90 new file mode 100644 index 0000000..b9b851a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_8.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-std=f2023" } +! Verify that the type and rank of the LOWER argument are enforced. +module c_f_pointer_shape_tests_8 + use, intrinsic :: iso_c_binding + +contains + subroutine sub2(my_c_array) bind(c) + type(c_ptr), value :: my_c_array + integer(kind=c_int), dimension(:), pointer :: my_array_ptr + + call c_f_pointer(my_c_array, my_array_ptr, (/ 10 /), (/ 10.0 /)) ! { dg-error "must be INTEGER" } + end subroutine sub2 + + subroutine sub3(my_c_array) bind(c) + type(c_ptr), value :: my_c_array + integer(kind=c_int), dimension(:), pointer :: my_array_ptr + integer(kind=c_int), dimension(1) :: shape + integer(kind=c_int), dimension(1, 1) :: lower + + lower(1, 1) = 10 + call c_f_pointer(my_c_array, my_array_ptr, shape, lower) ! { dg-error "must be of rank 1" } + end subroutine sub3 +end module c_f_pointer_shape_tests_8 diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_9.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_9.f90 new file mode 100644 index 0000000..e501e3d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_9.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } +program lower + use iso_c_binding + type(c_ptr) :: x + integer, target :: array_2d(12) + integer, pointer :: ptr_2d(:, :) + integer :: myshape_2d(2) + integer :: mylower_2d(2) + + array_2d = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12] + x = c_loc(array_2d) + myshape_2d = [3, 4] + mylower_2d = [2, 2] + + call c_f_pointer(x, ptr_2d, shape=myshape_2d, lower=mylower_2d) ! { dg-error "Fortran 2023: LOWER argument at" } +end program lower diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_driver.c b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_driver.c new file mode 100644 index 0000000..70e7d56 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_driver.c @@ -0,0 +1,47 @@ +#define NUM_ELEMS 10 +#define NUM_ROWS 2 +#define NUM_COLS 3 + +void test_long_long_1d (int *array, int num_elems); +void test_long_long_2d (int *array, int num_rows, int num_cols); +void test_long_1d (int *array, int num_elems); +void test_int_1d (int *array, int num_elems); +void test_short_1d (int *array, int num_elems); +void test_mixed (int *array, int num_elems); + +int +main (int argc, char **argv) +{ + int my_array[NUM_ELEMS]; + int my_2d_array[NUM_ROWS][NUM_COLS]; + int i, j; + + for (i = 0; i < NUM_ELEMS; i++) + my_array[i] = i; + + for (i = 0; i < NUM_ROWS; i++) + for (j = 0; j < NUM_COLS; j++) + my_2d_array[i][j] = (i * NUM_COLS) + j; + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. */ + test_long_long_1d (my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. + The indices are transposed for Fortran. */ + test_long_long_2d (my_2d_array[0], NUM_COLS, NUM_ROWS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_long. */ + test_long_1d (my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_int. */ + test_int_1d (my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_short. */ + test_short_1d (my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_int and + kind=c_long_long. */ + test_mixed (my_array, NUM_ELEMS); + + return 0; +} diff --git a/gcc/testsuite/gfortran.dg/char_length_3.f90 b/gcc/testsuite/gfortran.dg/char_length_3.f90 index 6529a77..75cb438 100644 --- a/gcc/testsuite/gfortran.dg/char_length_3.f90 +++ b/gcc/testsuite/gfortran.dg/char_length_3.f90 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-options "-std=legacy" } ! PR fortran/25071 ! Check if actual argument is too short ! diff --git a/gcc/testsuite/gfortran.dg/class_elemental_1.f90 b/gcc/testsuite/gfortran.dg/class_elemental_1.f90 new file mode 100644 index 0000000..547ae98 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_elemental_1.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! PR fortran/121342 +! The polymorphic function result as actual argument used to force the loop +! bounds around the elemental call, altering access to the other arrays. + +program p + implicit none + type :: t + integer :: i + end type + type :: u + integer :: i, a + end type + type(u) :: accum(5) + integer :: a(3:7), k + a = [ (k*k, k=1,5) ] + call s(accum, f(), a) + ! print *, accum%i + ! print *, accum%a + if (any(accum%i /= accum%a)) error stop 1 +contains + elemental subroutine s(l, c, a) + type(u) , intent(out) :: l + class(t) , intent(in) :: c + integer , intent(in) :: a + l%i = c%i + l%a = a + end subroutine + function f() + class(t), allocatable :: f(:) + allocate(f(-1:3)) + f%i = [ (k*k, k=1,5) ] + end function +end program diff --git a/gcc/testsuite/gfortran.dg/eoshift_8.f90 b/gcc/testsuite/gfortran.dg/eoshift_8.f90 index 0930638..f63a987 100644 --- a/gcc/testsuite/gfortran.dg/eoshift_8.f90 +++ b/gcc/testsuite/gfortran.dg/eoshift_8.f90 @@ -14,5 +14,5 @@ program main f2 = eoshift(e,shift=n,boundary=bnd2) ! { dg-error "has invalid shape" } f2 = eoshift(e,shift=1,boundary="x") ! { dg-error "must be of same type and kind" } - print '(*(1H",A,1H",:","))',f2 + !print '(*(1H",A,1H",:","))',f2 end program main diff --git a/gcc/testsuite/gfortran.dg/g77/f77-edit-h-out.f b/gcc/testsuite/gfortran.dg/g77/f77-edit-h-out.f index f92b39f..a0e35c8 100644 --- a/gcc/testsuite/gfortran.dg/g77/f77-edit-h-out.f +++ b/gcc/testsuite/gfortran.dg/g77/f77-edit-h-out.f @@ -5,10 +5,12 @@ C Origin: David Billinghurst <David.Billinghurst@riotinto.com> C C { dg-do run } C { dg-output "^" } - 10 format(1H1) - 20 format(6H 6) +C { dg-options "-std=legacy" + 10 format(1H1) ! { dg-warning "H format specifier" } + 20 format(6H 6) ! { dg-warning "H format specifier" } write(*,10) ! { dg-output "1(\r*\n+)" } write(*,20) ! { dg-output " 6(\r*\n+)" } - write(*,'(16H''apostrophe'' fun)') ! { dg-output "'apostrophe' fun(\r*\n+)" } + write(*,'(16H''apostrophe'' fun)') ! { dg-warning "H format specifier" } + ! { dg-output "'apostrophe' fun(\r*\n+)" } C { dg-output "\$" } end diff --git a/gcc/testsuite/gfortran.dg/generic_stmt_1.f90 b/gcc/testsuite/gfortran.dg/generic_stmt_1.f90 new file mode 100644 index 0000000..57d0aba --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_stmt_1.f90 @@ -0,0 +1,194 @@ +! { dg-do run } +! +! Test the F2018 generic statement +! +function cg (arg1, arg2) + complex :: cg + complex, intent(in) :: arg1, arg2 + cg = arg1 + arg2 +end + +module m + implicit none + + type :: t + integer :: i + end type + integer :: tsum = 0 + + public g + interface g ! Check generic statement + generic interface works + module procedure tg + end interface g + + generic :: g => ig, rg + generic :: operator(.plus.) => ig, rg + generic, private :: h => ig, rg + generic :: WRITE(FORMATTED) => wtarray + + interface g ! Check generic statement + generic interface works + function cg (arg1, arg2) + complex :: cg + complex, intent(in) :: arg1, arg2 + end + end interface g + +! Subroutines + generic, public :: sg => sig, srg + +! Check that we can mix with submodule procedures + interface + real module function realg (arg1, arg2) + real, intent(in) :: arg1, arg2 + end function + end interface + generic, public :: subg => ig, realg + +contains + + function rg (arg1, arg2) + real :: rg + real, intent(in) :: arg1, arg2 + rg = arg1 + arg2 + end + function ig (arg1, arg2) + integer :: ig + integer, intent(in) :: arg1, arg2 + ig = arg1 + arg2 + end + function tg (arg1, arg2) result(res) + type(t) :: res + type(t), intent(in) :: arg1, arg2 + res%i = arg1%i + arg2%i + end + subroutine srg (arg1, arg2, arg3) + real :: arg3 + real, intent(in) :: arg1, arg2 + arg3 = arg1 + arg2 + end + subroutine sig (arg1, arg2, arg3) + integer :: arg3 + integer, intent(in) :: arg1, arg2 + arg3 = arg1 + arg2 + end + + SUBROUTINE wtarray (dtv, unit, iotype, v_list, iostat, iomsg) + CLASS(t), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER(*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: v_list (:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER(*), INTENT(INOUT) :: iomsg + WRITE (unit, FMT=*, iostat=iostat, iomsg=iomsg) dtv%i + END SUBROUTINE wtarray + + subroutine foo + real :: a = 1.0, b = 2.0, r + integer :: c = 3, d = 4 + type(t) :: tres + generic :: operator(+) => tg +! private in foo + r = h(a,b) + if (r /= rg(a,b)) stop 1 + if (h(c,d) /= ig(c,d)) stop 2 +! operator in foo + r = a.plus.b + if (r /= rg(a,b)) stop 3 + if ((c.plus.(2*d)) /= ig(c,2*d)) stop 4 +! check intrinsic operator + tres = t(21) + t(21) + if (tres%i /= 42) stop 5 + end +end module m + +submodule (m) subm +contains + real module function realg (arg1, arg2) + real, intent(in) :: arg1, arg2 + realg = arg1 + arg2 + end +end + +program p + use m + implicit none + integer :: i, rv + + generic :: operator(.minus.) => pig, prg + generic :: operator(*) => times + generic :: j => ig, rg + generic :: j => mg + + real :: a = 1.0, b = 2.0, s3 + integer :: c = 3, d = 4, si + type(t) :: t1 = t(2), t2 = t(3), tres + type(t) :: tarray(5) = [t(5), t(4), t(3), t(2), t(1)] + +! module generic in p + if (g(2.0*a,2.0*b) /= rg(2.0*a,2.0*b)) stop 6 + if (g(c,d) /= ig(c,d)) stop 7 +! local generic in p + if (j(a,b) /= rg(a,b)) stop 8 + if (j(c,d) /= ig (c,d)) stop 9 +! local generic in p with different number of arguments + if (j(c,d,-1) /= mg(c,d,-1)) stop 10 +! module operator in p + if (7*int(a.plus.b) /= 3*(c.plus.d)) stop 11 +! local operator in p + if ((a.minus.b) /= prg(a,b)) stop 12 + if ((c.minus.d) /= pig(c,d)) stop 13 +! local operator in block + block + generic :: operator(.bminus.) => pig, prg + if ((a.bminus.b) /= prg(a,b)) stop 14 + if ((c.bminus.d) /= pig(c,d)) stop 15 + end block +! intrinsic operator in p + tres = t1 * t2 + if (tres%i /= 6) stop 16 +! test private interface in module + call foo +! test mixture of GENERIC statement and generic INTERFACE + if (g((1.0,1.0),(2.0,2.0)) /= cg((1.0,1.0),(2.0,2.0))) stop 17 + tres = g(t1,t2) + if (tres%i /= 5) stop 18 +! subroutines + call sg(10.0*a, b, s3) + if (int(s3) /= 12) stop 19 + call sg(5*c, d, si) + if (si /= 19) stop 20 +! submodule procedures + if (subg(20.0*a,2.0*b) /= realg(20.0*a,2.0*b)) stop 21 +! check DTIO + open (10,status='scratch') + WRITE(10, '(DT)') tarray + rewind(10) + do i = 1,5 + read(10, *) rv + tsum = tsum + rv + end do + close(10) + if (tsum /= 15) stop 22 +contains + + function pig (arg1, arg2) + integer :: pig + integer, intent(in) :: arg1, arg2 + pig = arg1 - arg2 + end + function prg (arg1, arg2) + real :: prg + real, intent(in) :: arg1, arg2 + prg = arg1 - arg2 + end + function times (arg1, arg2) result(res) + type(t) :: res + type(t), intent(in) :: arg1, arg2 + res%i = arg1%i * arg2%i + end + function mg (arg1, arg2, arg3) + integer :: mg + integer, intent(in) :: arg1, arg2, arg3 + mg = arg1 - arg2 * arg3 + end +end diff --git a/gcc/testsuite/gfortran.dg/generic_stmt_2.f90 b/gcc/testsuite/gfortran.dg/generic_stmt_2.f90 new file mode 100644 index 0000000..f698012 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_stmt_2.f90 @@ -0,0 +1,87 @@ +! { dg-do compile } +! +! Test the F2018 generic statement error reporting using the module from +! generic_stmt_1.f90 +! +function cg (arg1, arg2) + complex :: cg + complex, intent(in) :: arg1, arg2 + cg = arg1 + arg2 +end + +module m1 + implicit none + + type :: t + integer :: i + end type + + public g + interface g ! Check generic statement + generic interface works + module procedure tg + end interface g + + generic, public :: g => ig ! { dg-error "repeats that already given" } + generic, private :: g => rg ! { dg-error "conflicts with that already" } + generic :: operator(.plus.) => ig, rg, gg ! { dg-error "did you mean|must be a FUNCTION" } + generic, private :: h => ig, rg + generic :: => ig, rg ! { dg-error "Malformed GENERIC statement" } + generic :: wron ng => ig, rg ! { dg-error "Expected .=>." } + generic :: #!& => ig, rg ! { dg-error "Malformed GENERIC statement" } + generic, private :: operator(.plusplus.) => ig + generic, private :: operator(.plusplus.) => rg ! { dg-error "repeats the access specification" } + generic, PUBLIC :: operator(.plusplus.) => tg ! { dg-error "must have the same access" } + + interface g ! Check generic statement + generic interface works + function cg (arg1, arg2) + complex :: cg + complex, intent(in) :: arg1, arg2 + end + end interface g + + generic, public :: sg => sig, srg + generic, public :: sg2 => sig, srg, rg ! Error appears at 'srg' declaration + + +contains + + function rg (arg1, arg2) + real :: rg + real, intent(in) :: arg1, arg2 + rg = arg1 + arg2 + end + function ig (arg1, arg2) + integer :: ig + integer, intent(in) :: arg1, arg2 + ig = arg1 + arg2 + end + function tg (arg1, arg2) result(res) + type(t) :: res + type(t), intent(in) :: arg1, arg2 + res%i = arg1%i + arg2%i + end + subroutine srg (arg1, arg2, arg3) ! { dg-error "procedures must be either all SUBROUTINEs" } + real :: arg3 + real, intent(in) :: arg1, arg2 + arg3 = arg1 + arg2 + end + subroutine sig (arg1, arg2, arg3) + integer :: arg3 + integer, intent(in) :: arg1, arg2 + arg3 = arg1 + arg2 + end + subroutine foo + real :: a = 1.0, b = 2.0, r + integer :: c = 3, d = 4 + generic, public :: sg => sig, srg ! { dg-error "not in a module" } + generic :: operator(+) => rg ! { dg-error "conflicts with intrinsic interface" } + r = h(a,d) ! { dg-error "There is no specific function" } + if (r /= rg(a,b)) stop 1 + if (h(c,d) /= ig(c,d)) stop 2 + generic :: wrong => ig, rg ! { dg-error "Unexpected GENERIC statement" } +! operator in foo + r = c.plus.b ! { dg-error "Unknown operator" } + if (r /= rg(a,b)) stop 3 + if ((c.plus.(2*d)) /= ig(c,2*d)) stop 4 + end +end module m1 diff --git a/gcc/testsuite/gfortran.dg/generic_stmt_3.f90 b/gcc/testsuite/gfortran.dg/generic_stmt_3.f90 new file mode 100644 index 0000000..543c63f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_stmt_3.f90 @@ -0,0 +1,96 @@ +! { dg-do compile } +! +! Test the F2018 generic statement error reporting of access and name conflicts. +! +! Contributed by Steven Kargl <kargls@comcast.net> +! + module foo1 + + implicit none + private + + public bah + generic :: bah => bah, bak ! { dg-error "conflicts with that" } + + public bar + generic :: bar => bah, bak ! OK - checked that 'bar' is not a procedure + + contains + integer function bah(i) + integer, intent(in) :: i + bah = i + end function bah + real function bak(x) + real, intent(in) :: x + bak = 42.5 + end function bak + end module foo1 + + module foo2 + + implicit none + private + + generic :: bah => bah, bak ! { dg-error "conflicts with that" } + public bah + + generic :: bar => bah, bak ! OK - checked that 'bar' is not a procedure + public bar + + contains + integer function bah(i) + integer, intent(in) :: i + bah = i + end function bah + real function bak(x) + real, intent(in) :: x + bak = 42.5 + end function bak + end module foo2 + + module foo3 ! { dg-error "clashes with the name of an entity" } + + implicit none + private + + integer :: bar = 10 ! { dg-error "has a type" } + generic :: bar => bah, bak ! { dg-error "has a type" } + + generic :: foo3 => bah, bak ! { dg-error "clashes with the name of an entity" } + + contains + integer function bah(i) + integer, intent(in) :: i + bah = i + end function bah + real function bak(x) + real, intent(in) :: x + bak = 42.5 + end function bak + end module foo3 + + module foo4 + implicit none + private + public bak + + generic :: bak => bar, bah + + contains + function bar(i) + real bar + integer, intent(in) :: i + bar = i + end function bar + function bah(x) + real bah + real, intent(in) :: x + bah = x + end function bah + end module foo4 + + program snooze + use foo4 + print *, bak(42) ! Public statement for 'bak' exposes the + print *, bak(43.5) ! specific procedures 'bar' and 'bah' here. + end program snooze diff --git a/gcc/testsuite/gfortran.dg/generic_stmt_4.f90 b/gcc/testsuite/gfortran.dg/generic_stmt_4.f90 new file mode 100644 index 0000000..24e814a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_stmt_4.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! +! Test the correct processing of public generic statements and verify that they +! behave in the same way as public interfaces. +! +! Contributed by Steven Kargl <kargls@comcast.net> +! +module foo + + implicit none + + private + public bak1, bak2 + + + generic :: bak1 => bar, bah + + ! Should be equivalent to above. + + interface bak2 + module procedure bar + module procedure bah + end interface bak2 + + + contains + function bar(i) + real bar + integer, intent(in) :: i + bar = i + end function bar + function bah(x) + real bah + real, intent(in) :: x + bah = x + end function bah +end module foo + +program snooze + use foo + if (bak1(42) /= bak2(42)) stop 1 + if (bak1(43.5) /= bak2(43.5)) stop 2 +end program snooze diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 index 39824c2..3a6711b 100644 --- a/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 @@ -26,7 +26,7 @@ module main integer function f4 (a) import c_ptr type(c_ptr), intent(inout) :: a - !$omp declare variant (f0) adjust_args (nothing: a) ! { dg-error "the 'adjust_args' clause at .1. can only be specified if the 'dispatch' selector of the construct selector set appears in the 'match' clause" } + !$omp declare variant (f0) adjust_args (nothing: a) ! { dg-error "expected 'match' clause at .1." } end function integer function f5 (i) integer, intent(inout) :: i diff --git a/gcc/testsuite/gfortran.dg/gomp/append_args-1.f90 b/gcc/testsuite/gfortran.dg/gomp/append_args-1.f90 index 7e4f74d..fdab51f 100644 --- a/gcc/testsuite/gfortran.dg/gomp/append_args-1.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/append_args-1.f90 @@ -56,12 +56,12 @@ contains subroutine f2b () !$omp declare variant (f1c) & - !$omp& append_args ( interop ( target , targetsync) ) ! { dg-error "the 'append_args' clause at .1. can only be specified if the 'dispatch' selector of the construct selector set appears in the 'match' clause" } + !$omp& append_args ( interop ( target , targetsync) ) ! { dg-error "expected 'match'" } end subroutine subroutine f2c (x,y) !$omp declare variant (fop) , append_args ( interop ( target, prefer_type ( "cuda", "hip" ) ) , interop(target)) , & - !$omp& adjust_args (need_device_ptr : x, y ) ! { dg-error "the 'adjust_args' clause at .1. can only be specified if the 'dispatch' selector of the construct selector set appears in the 'match' clause" } + !$omp& adjust_args (need_device_ptr : x, y ) ! { dg-error "expected 'match' clause at .1." } type(c_ptr) :: x, y value :: y end subroutine diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-22.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-22.f90 new file mode 100644 index 0000000..a1b2f2a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-22.f90 @@ -0,0 +1,6 @@ +! PR118839: Check that error is diagnosed when the variant is the same +! as the base function. + +subroutine f() + !$omp declare variant(f) match(user={condition(.true.)}) ! { dg-error "variant 'f' at .1. is the same as base function" } +end subroutine diff --git a/gcc/testsuite/gfortran.dg/gomp/pr107421.f90 b/gcc/testsuite/gfortran.dg/gomp/pr107421.f90 new file mode 100644 index 0000000..db98dce --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr107421.f90 @@ -0,0 +1,15 @@ +! { dg-additional-options "-fdump-ipa-whole-program" } +! { dg-additional-options "-mno-direct-extern-access" { target { i?86-*-* x86_64-*-* } } } + +integer :: i + +common /c/ i + +!$omp threadprivate (/c/) + +i = 0 + +end + +! tls_model should be tls-initial-exec due to common block. +! { dg-final { scan-ipa-dump "Varpool flags: tls-initial-exec" "whole-program" } } diff --git a/gcc/testsuite/gfortran.dg/hollerith_1.f90 b/gcc/testsuite/gfortran.dg/hollerith_1.f90 index fc163d8..9cbc5aa 100644 --- a/gcc/testsuite/gfortran.dg/hollerith_1.f90 +++ b/gcc/testsuite/gfortran.dg/hollerith_1.f90 @@ -6,7 +6,7 @@ ! Also verifies the functioning of hollerith formatting. character*72 c write(c,8000) -8000 format(36(2H!))) +8000 format(36(2H!))) ! { dg-warning "H format specifier" } do i = 1,72,2 if (c(i:i+1) /= '!)') STOP 1 end do diff --git a/gcc/testsuite/gfortran.dg/io_constraints_1.f90 b/gcc/testsuite/gfortran.dg/io_constraints_1.f90 index c6f9569..9e0a19b 100644 --- a/gcc/testsuite/gfortran.dg/io_constraints_1.f90 +++ b/gcc/testsuite/gfortran.dg/io_constraints_1.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-std=f95" } +! { dg-options "-std=legacy" } ! Part I of the test of the IO constraints patch, which fixes PRs: ! PRs 25053, 25063, 25064, 25066, 25067, 25068, 25069, 25307 and 20862. ! @@ -7,7 +7,7 @@ ! module fails - 2000 format (1h , 2i6) ! { dg-error "Format statement in module" } + 2000 format (2i6) ! { dg-error "Format statement in module" } end module fails @@ -21,7 +21,7 @@ contains subroutine foo (i) integer :: i write (*, 100) i - 100 format (1h , "i=", i6) ! { dg-warning "The H format specifier at ... is a Fortran 95 deleted feature" } + 100 format ("i=", i6) end subroutine foo end module global @@ -33,7 +33,7 @@ end module global ! Appending to a USE associated namelist is an extension. - NAMELIST /NL/ a,b ! { dg-error "already is USE associated" } + NAMELIST /NL/ a,b a=1 ; b=2 @@ -54,7 +54,7 @@ end module global ! R912 !Was correctly picked up before patch. - write(6, NML=NL, iostat = ierr) ! { dg-error "requires default INTEGER" } + write(6, NML=NL, iostat = ierr) ! Constraints !Was correctly picked up before patch. diff --git a/gcc/testsuite/gfortran.dg/io_constraints_2.f90 b/gcc/testsuite/gfortran.dg/io_constraints_2.f90 index e0e0db6..5479c34 100644 --- a/gcc/testsuite/gfortran.dg/io_constraints_2.f90 +++ b/gcc/testsuite/gfortran.dg/io_constraints_2.f90 @@ -17,7 +17,7 @@ contains subroutine foo (i) integer :: i write (*, 100) i - 100 format (1h , "i=", i6) ! { dg-warning "H format specifier" } + 100 format ("i=", i6) end subroutine foo end module global diff --git a/gcc/testsuite/gfortran.dg/longline.f b/gcc/testsuite/gfortran.dg/longline.f index c2a5f5a..4b666fa 100644 --- a/gcc/testsuite/gfortran.dg/longline.f +++ b/gcc/testsuite/gfortran.dg/longline.f @@ -6,6 +6,6 @@ character*10 cpnam character*4 csig write (34,808) csig,ilax,cpnam - 808 format (/9X,4HTHE ,A4, 29HTIVE MINOS ERROR OF PARAMETER,I3, 2H - +, ,A10) + 808 format (/9X,'THE ',A4, 'TIVE MINOS ERROR OF PARAMETER',I3, ' + +,' ,A10) end diff --git a/gcc/testsuite/gfortran.dg/pdt_22.f03 b/gcc/testsuite/gfortran.dg/pdt_22.f03 index 929f398..23feb8c 100644 --- a/gcc/testsuite/gfortran.dg/pdt_22.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_22.f03 @@ -8,9 +8,10 @@ ! program p character(120) :: buffer - integer :: i(4) + integer :: i(3) type t(a) integer, len :: a + integer :: z = 4 end type type t2(b) integer, len :: b @@ -18,6 +19,10 @@ program p end type type(t2(3)) :: x write (buffer,*) x - read (buffer,*) i - if (any (i .ne. [3,1,1,1])) STOP 1 + read (buffer, *) i + if (any (i .ne. [4,4,4])) stop 1 + x%r = [t(1)(3),t(1)(2),t(1)(1)] + write (buffer,*) x + read (buffer, *) i + if (any (i .ne. [3,2,1])) stop 2 end diff --git a/gcc/testsuite/gfortran.dg/pdt_23.f03 b/gcc/testsuite/gfortran.dg/pdt_23.f03 index b2156b9..c0cec9a 100644 --- a/gcc/testsuite/gfortran.dg/pdt_23.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_23.f03 @@ -15,19 +15,19 @@ program p type(t(:)), allocatable :: x allocate (t(2) :: x) - x = t(2,'ab') + x = t(2)('ab') write (buffer, *) x%c ! Tests the fix for PR82720 read (buffer, *) chr if (trim (chr) .ne. 'ab') STOP 1 - x = t(3,'xyz') + x = t(3)('xyz') if (len (x%c) .ne. 3) STOP 2 - write (buffer, *) x ! Tests the fix for PR82719 - read (buffer, *) i, chr - if (i .ne. 3) STOP 3 + write (buffer, *) x ! Tests the fix for PR82719. PDT IO was incorrect (PRs 84143/84432). + read (buffer, *) chr +! if (i .ne. 3) STOP 3 if (chr .ne. 'xyz') STOP 4 - buffer = " 3 lmn" - read (buffer, *) x ! Some thought will be needed for PDT reads. + buffer = "lmn" + read (buffer, *) x ! PDT IO was incorrect (PRs 84143/84432). if (x%c .ne. 'lmn') STOP 5 end diff --git a/gcc/testsuite/gfortran.dg/pdt_3.f03 b/gcc/testsuite/gfortran.dg/pdt_3.f03 index e364eea..cd48364 100644 --- a/gcc/testsuite/gfortran.dg/pdt_3.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_3.f03 @@ -5,7 +5,7 @@ module vars integer :: d_dim = 4 integer :: mat_dim = 256 - integer, parameter :: ftype = kind(0.0d0) + integer, parameter :: ftype = kind(0.0) end module use vars @@ -34,7 +34,7 @@ end module real, allocatable :: matrix (:,:) type(thytype(ftype, 4, 4)) :: w - type(x(8,4,256)) :: q + type(x(ftype,ftype,256)) :: q class(mytype(ftype, :)), allocatable :: cz w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim]) @@ -57,21 +57,21 @@ end module matrix = w%d ! TODO - for some reason, using w%d directly in the source causes a seg fault. - allocate (cz, source = mytype(ftype, d_dim, 0, matrix)) + allocate (cz, source = mytype(ftype, d_dim)( 0, matrix)) select type (cz) type is (mytype(ftype, *)) if (int (sum (cz%d)) .ne. 136) STOP 11 - type is (thytype(ftype, *, 8)) + type is (thytype(ftype, *, ftype)) STOP 12 end select deallocate (cz) - allocate (thytype(ftype, d_dim*2, 8) :: cz) + allocate (thytype(ftype, d_dim*2, ftype) :: cz) cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b]) select type (cz) type is (mytype(ftype, *)) STOP 13 - type is (thytype(ftype, *, 8)) + type is (thytype(ftype, *, ftype)) if (int (sum (cz%d)) .ne. 20800) STOP 14 end select diff --git a/gcc/testsuite/gfortran.dg/pdt_38.f03 b/gcc/testsuite/gfortran.dg/pdt_38.f03 new file mode 100644 index 0000000..4eb8a41 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_38.f03 @@ -0,0 +1,21 @@ +! { dg-do compile ) +! +! Test the fix for pr84122 +! +! Contributed by Neil Carlson <neil.n.carlson@gmail.com> +! +module mod +type foo(idim) + integer, len, PUBLIC :: idim ! { dg-error "is not allowed" } + private + integer :: array(idim) +end type +end module + +module bar +type foo(idim) + private + integer,len :: idim ! { dg-error "must come before a PRIVATE statement" } + integer :: array(idim) +end type +end module diff --git a/gcc/testsuite/gfortran.dg/pdt_39.f03 b/gcc/testsuite/gfortran.dg/pdt_39.f03 new file mode 100644 index 0000000..7378cf5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_39.f03 @@ -0,0 +1,123 @@ +! { dg-do run } +! +! Test the fix for pr95541. +! +! Contributed by Juergen Reuter <juergen.reuter@desy.de> +! +module mykinds + use, intrinsic :: iso_fortran_env, only : i4 => int32, r4 => real32, r8 => real64 + implicit none + private + public :: i4, r4, r8 +end module mykinds + +module matrix + use mykinds, only : r4, r8 + implicit none + private + + type, public :: mat_t(k,c,r) + !.. type parameters + integer, kind :: k = r4 + integer, len :: c = 1 + integer, len :: r = 1 + private + !.. private by default + !.. type data + real(kind=k) :: m_a(c,r) + end type mat_t + + interface assignment(=) + module procedure geta_r4 + module procedure seta_r4 + module procedure geta_r8 + module procedure seta_r8 + !.. additional bindings elided + end interface assignment(=) + + public :: assignment(=) + +contains + + subroutine geta_r4(a_lhs, t_rhs) + real(r4), allocatable, intent(out) :: a_lhs(:,:) + class(mat_t(k=r4,c=*,r=*)), intent(in) :: t_rhs + a_lhs = t_rhs%m_a + return + end subroutine geta_r4 + + subroutine geta_r8(a_lhs, t_rhs) + real(r8), allocatable, intent(out) :: a_lhs(:,:) + class(mat_t(k=r8,c=*,r=*)), intent(in) :: t_rhs + a_lhs = t_rhs%m_a + return + end subroutine geta_r8 + + subroutine seta_r4(t_lhs, a_rhs) + class(mat_t(k=r4,c=*,r=*)), intent(inout) :: t_lhs + real(r4), intent(in) :: a_rhs(:,:) + !.. checks on size elided + t_lhs%m_a = a_rhs + return + end subroutine seta_r4 + + subroutine seta_r8(t_lhs, a_rhs) + class(mat_t(k=r8,c=*,r=*)), intent(inout) :: t_lhs + real(r8), intent(in) :: a_rhs(:,:) + !.. checks on size elided + t_lhs%m_a = a_rhs + return + end subroutine seta_r8 + +end module matrix + +program p + use mykinds, only : r4, r8 + use matrix, only : mat_t, assignment(=) + implicit none + type(mat_t(k=r4,c=:,r=:)), allocatable :: mat_r4 + type(mat_t(k=r8,c=:,r=:)), allocatable :: mat_r8 + real(r4), allocatable :: a_r4(:,:) + real(r8), allocatable :: a_r8(:,:) + integer :: N + integer :: M + integer :: i + integer :: istat + N = 2 + M = 3 + allocate( mat_t(k=r4,c=N,r=M) :: mat_r4, stat=istat ) + if ( istat /= 0 ) then + print *, " error allocating mat_r4: stat = ", istat + stop + end if + if (mat_r4%k /= r4) stop 1 + if (mat_r4%c /= N) stop 2 + if (mat_r4%r /= M) stop 3 + mat_r4 = reshape( [ (real(i, kind=mat_r4%k), i=1,N*M) ], [ N, M ] ) + a_r4 = mat_r4 + if (int (sum (a_r4)) /= 21) stop 4 + N = 4 + M = 4 + allocate( mat_t(k=r8,c=N,r=M) :: mat_r8, stat=istat ) + if ( istat /= 0 ) then + print *, " error allocating mat_r4: stat = ", istat + stop + end if + if (mat_r8%k /= r8) stop 5 + if (mat_r8%c /= N) stop 6 + if (mat_r8%r /= M) stop 7 + mat_r8 = reshape( [ (real(i, kind=mat_r8%k), i=1,N*M) ], [ N, M ] ) + a_r8 = mat_r8 + if (int (sum (a_r8)) /= 136) stop 8 + deallocate( mat_r4, stat=istat ) + if ( istat /= 0 ) then + print *, " error deallocating mat_r4: stat = ", istat + stop + end if + deallocate( mat_r8, stat=istat ) + if ( istat /= 0 ) then + print *, " error deallocating mat_r4: stat = ", istat + stop + end if + stop +end program p diff --git a/gcc/testsuite/gfortran.dg/pdt_40.f03 b/gcc/testsuite/gfortran.dg/pdt_40.f03 new file mode 100644 index 0000000..4853508 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_40.f03 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! Contributed by FortranFan at https://groups.google.com/g/comp.lang.fortran/c/NDE6JKTFbNU +! + integer, parameter :: parm = 42 + type :: t(ell) + integer, len :: ell + integer :: i + end type + + type :: u + type(t(ell=:)), allocatable :: x + end type + + type(t(ell=:)), allocatable :: foo + type(u) :: bar + + allocate( t(ell = parm) :: foo ) + foo%i = 2 * foo%ell + + bar = u (foo) ! Gave: Cannot convert TYPE(Pdtt) to TYPE(t) + + if (bar%x%ell /= parm) stop 1 ! Then these component references failed in + if (bar%x%i /= 2 * parm) stop 2 ! translation. +end diff --git a/gcc/testsuite/gfortran.dg/pdt_41.f03 b/gcc/testsuite/gfortran.dg/pdt_41.f03 new file mode 100644 index 0000000..be2e871 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_41.f03 @@ -0,0 +1,47 @@ +! { dg-do run } +! +! Test the fix for pr99709 in which the object being passed to a PDT dummy +! with the value attribute was not a deep copy. +! +! Contribute by Xiao Liu <xiao.liu@compiler-dev.com> +! +program value_f2008 + implicit none + type :: matrix(k) + integer, len :: k + integer :: elements(k, k) + !integer :: elements(2, 2) + end type matrix + + type, extends(matrix) :: child + end type child + + integer, parameter :: array_parm(2, 2) = reshape([1, 2, 3, 4], [2, 2]) + + type(child(2)) :: obj + obj%elements = array_parm + + call test_value_attr(2, obj) + if (any (obj%elements /= array_parm)) stop 1 + + call test(2, obj) + if (any (obj%elements /= 0)) stop 2 + +contains + + subroutine test(n, nonconstant_length_object) + integer :: n + type(child(n)) :: nonconstant_length_object + if (nonconstant_length_object%k /= 2) stop 3 + if (any (nonconstant_length_object%elements /= array_parm)) stop 4 + nonconstant_length_object%elements = 0 + end subroutine test + + subroutine test_value_attr(n, nonconstant_length_object) + integer :: n + type(child(n)), value :: nonconstant_length_object + if (nonconstant_length_object%k /= 2) stop 5 + if (any (nonconstant_length_object%elements /= array_parm)) stop 6 + nonconstant_length_object%elements = 0 + end subroutine test_value_attr +end program value_f2008 diff --git a/gcc/testsuite/gfortran.dg/pdt_42.f03 b/gcc/testsuite/gfortran.dg/pdt_42.f03 new file mode 100644 index 0000000..47743d1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_42.f03 @@ -0,0 +1,46 @@ +! { dg-do run ) +! +! Test the fix for PR87669 in which SELECT TYPE was not identifying the difference +! between derived types with different type kind parameters, when the selector +! is unlimited polymorphic. +! +! Contributed by Etienne Descamps <etdescdev@gmail.com> +! +Program Devtest + Type dvtype(k) + Integer, Kind :: k + Real(k) :: a, b, c + End Type dvtype + type(dvtype(8)) :: dv + type(dvtype(4)) :: fv + integer :: ctr = 0 + + dv%a = 1; dv%b = 2; dv%c = 3 + call dvtype_print(dv) + if (ctr /= 2) stop 1 + + fv%a = 1; fv%b = 2; fv%c = 3 + call dvtype_print(fv) + if (ctr /= 0) stop 2 + +Contains + Subroutine dvtype_print(p) + class(*), intent(in) :: p + Select Type(p) + class is (dvtype(4)) + ctr = ctr - 1 + End Select + Select Type(p) + class is (dvtype(8)) + ctr = ctr + 1 + End Select + Select Type(p) + type is (dvtype(4)) + ctr = ctr - 1 + End Select + Select Type(p) + type is (dvtype(8)) + ctr = ctr + 1 + End Select + End Subroutine dvtype_print +End diff --git a/gcc/testsuite/gfortran.dg/pdt_43.f03 b/gcc/testsuite/gfortran.dg/pdt_43.f03 new file mode 100644 index 0000000..c9f2502 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_43.f03 @@ -0,0 +1,28 @@ +! { dg-do run ) +! +! Test the fix for PR89707 in which the procedure pointer component +! with a parameterized KIND expression caused an ICE in resolution. +! +! Contributed by Janus Weil <janus@gcc.gnu.org> +! +program pdt_with_ppc + integer, parameter :: kt = kind (0d0) + type :: q(k) + integer, kind :: k = 4 + procedure (real(kind=kt)), pointer, nopass :: p + end type + type (q(kt)) :: x + x%p => foo + if (int (x%p(2d0)) /= 4) stop 1 + x%p => bar + if (int (x%p(2d0, 4d0)) /= 16) stop 2 +contains + real(kind=kt) function foo (x) + real(kind = kt) :: x + foo = 2.0 * x + end + real(kind=kt) function bar (x, y) + real(kind = kt) :: x, y + bar = x ** y + end +end diff --git a/gcc/testsuite/gfortran.dg/pdt_generic_1.f90 b/gcc/testsuite/gfortran.dg/pdt_generic_1.f90 new file mode 100644 index 0000000..a6c0f6ac --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_generic_1.f90 @@ -0,0 +1,94 @@ +! { dg-do run } +! +! Check the fix for pr121398 +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module tensor_m + implicit none + private + public tensor_t + + type tensor_t(k) + integer, kind :: k + integer :: n + contains + procedure, private :: default_real_num_components + procedure, private :: default_real_num_components2 + procedure, private :: double_precision_num_components + procedure, private, pass(self) :: quad_precision_num_components + generic :: num_components => default_real_num_components, & ! Failed ambiguity test + default_real_num_components2, & + double_precision_num_components, & + quad_precision_num_components + end type + + interface + + module function default_real_num_components(self) result(res) + implicit none + class(tensor_t(kind(0.))) self + integer :: res + end function + + module function default_real_num_components2(self, another) result(res) + implicit none + class(tensor_t(kind(0.))) self, another + integer :: res + end function + + module function double_precision_num_components(self) result(res) + implicit none + class(tensor_t(kind(0.0_8))) self + integer :: res + end function + + module function quad_precision_num_components(l, self) result(res) + implicit none + class(tensor_t(kind(0.0_16))) self + integer :: l + integer :: res + end function + + end interface + +end module + +submodule (tensor_m) tensor_m_components +contains + module procedure default_real_num_components + implicit none + self%n = 10 + res = 1 + end + + module procedure default_real_num_components2 + implicit none + self%n = 2 * another%n + res = 1 + end + + module procedure double_precision_num_components + implicit none + self%n = 20 + res = 2 + end + + module procedure quad_precision_num_components + implicit none + self%n = 10 * l + res = l + end +end + + use tensor_m + type (tensor_t(kind(0.))) :: a + type (tensor_t(kind(0.))) :: ap + type (tensor_t(kind(0.0_8))) :: b + type (tensor_t(kind(0.0_16))) :: c + if (a%num_components () /= 1) stop 1 + if (ap%num_components (a) /= 1) stop 2 + if (2 * a%n /= ap%n) stop 3 + if (b%num_components () /= 2 ) stop 4 + if (c%num_components (42) /= 42 ) stop 5 +end diff --git a/gcc/testsuite/gfortran.dg/pointer_assign_16.f90 b/gcc/testsuite/gfortran.dg/pointer_assign_16.f90 new file mode 100644 index 0000000..9282283 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_assign_16.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! Check the span of the descriptor of an array pointer after it has been +! assigned to from a polymorphic function result. + +program test + implicit none + type t + integer :: c + end type t + type, extends(t) :: u + integer :: d + end type u + type(t), pointer :: p(:) + class(t), allocatable, target :: a(:) + p => f() + ! print *, p%c + if (any(p%c /= [2,5,11,17,23])) error stop 1 +contains + function f() + class(t), pointer :: f(:) + a = [ u(2,3), u(5,7), u(11,13), u(17,19), u(23,29) ] + f => a + end function +end program diff --git a/gcc/testsuite/gfortran.dg/pr121234.f90 b/gcc/testsuite/gfortran.dg/pr121234.f90 new file mode 100644 index 0000000..8eb1af5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr121234.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! PR121234 Bogus diagnostic on READ of string with semicolon. + character(12) buffer,a + a = 'xxxxxxxxxx' + buffer="33;44" + read(buffer,*) a + if (a .ne. "33;44") stop 1 + a = 'xxxxxxxxxx' + buffer=" ;;33 ,44 " + read(buffer,*,decimal="comma") a + if (a .ne. 'xxxxxxxxxx') stop 2 ! A null read + a = 'xxxxxxxxxx' + buffer=" ;;33 ,44 " + read(buffer,*,decimal="point") a + if (a .ne. ';;33') stop 3 ! Spaces are delimiting + a = 'xxxxxxxxxx' + buffer=";;33;,44 " + read(buffer,*) a + if (a .ne. ';;33;') stop 4 ! Comma is delimiting + a = 'xxxxxxxxxx' + buffer=";;33;44;; " + read(buffer,*) a + if (a .ne. ';;33;44;;') stop 5 ! Space is delimiting + a = 'xxxxxxxxxx' + buffer=";;33;44;;;.7" + read(buffer,*) a + if (a .ne. ';;33;44;;;.7') stop 6 ! Space is delimiting +end diff --git a/gcc/testsuite/gfortran.dg/pr121627.f90 b/gcc/testsuite/gfortran.dg/pr121627.f90 new file mode 100644 index 0000000..c3ce218 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr121627.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +program real_kinds ! { dg-error "already declared at" } + use iso_fortran_env ! { dg-error "already declared at" } + i = real64 +end program real_kinds diff --git a/gcc/testsuite/gfortran.dg/pr20086.f90 b/gcc/testsuite/gfortran.dg/pr20086.f90 index 674261e..ffd5841 100644 --- a/gcc/testsuite/gfortran.dg/pr20086.f90 +++ b/gcc/testsuite/gfortran.dg/pr20086.f90 @@ -10,7 +10,7 @@ if (line.ne.' stiffness reformed for hello hello')STOP 2 stop - 2070 format (2x,37hstiffness reformed for this high step) - 2090 format (2x,34hstiffness reformed for hello hello) + 2070 format (2x,37hstiffness reformed for this high step) ! { dg-warning "H format specifier" } + 2090 format (2x,34hstiffness reformed for hello hello) ! { dg-warning "H format specifier" } end diff --git a/gcc/testsuite/gfortran.dg/pr89092.f90 b/gcc/testsuite/gfortran.dg/pr89092.f90 new file mode 100644 index 0000000..2164994 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr89092.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +module AModule + implicit none + private + public Foo + + interface Foo + module procedure FooPrivate + end interface +contains + subroutine FooPrivate(x) + integer :: x + + write(*,*) 'Foo(integer)' + end subroutine +end module +module BModule + implicit none + private + + type, public :: BType + contains + procedure :: Foo + end type +contains + subroutine Foo(self) + class(BType) :: self + + write(*,*) 'Foo(BType)' + end subroutine +end module +program iface_tbp_test + use AModule + implicit none + + call test() + +contains + subroutine test() + use BModule + + type(BType) :: y + + call y%Foo() + call Foo(1) + end subroutine +end program +! { dg-final { scan-tree-dump-times "foo \\(&class.2\\)" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/split_1.f90 b/gcc/testsuite/gfortran.dg/split_1.f90 new file mode 100644 index 0000000..21659b0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/split_1.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +program b + character(len=:), allocatable :: input + character(len=2) :: set = ', ' + integer :: p + input = " one,last example," + p = 0 + + call split(input, set, p) + if (p /= 1) STOP 1 + call split(input, set, p) + if (p /= 5) STOP 2 + call split(input, set, p) + if (p /= 10) STOP 3 + call split(input, set, p) + if (p /= 18) STOP 4 + call split(input, set, p) + if (p /= 19) STOP 5 + + call split(input, set, p, .true.) + if (p /= 18) STOP 6 + call split(input, set, p, .true.) + if (p /= 10) STOP 7 + call split(input, set, p, .true.) + if (p /= 5) STOP 8 + call split(input, set, p, .true.) + if (p /= 1) STOP 9 +end program b diff --git a/gcc/testsuite/gfortran.dg/split_2.f90 b/gcc/testsuite/gfortran.dg/split_2.f90 new file mode 100644 index 0000000..9afb30b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/split_2.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +program b + integer, parameter :: ucs4 = selected_char_kind('ISO_10646') + character(kind=ucs4, len=:), allocatable :: input, set + integer :: p = 0 + + input = char(int(z'4f60'), ucs4) // char(int(z'597d'), ucs4) // char(int(z'4f60'), ucs4) // char(int(z'4e16'), ucs4) + set = char(int(z'597d'), ucs4) // char(int(z'4e16'), ucs4) + + call split(input, set, p) + if (p /= 2) stop 1 + call split(input, set, p) + if (p /= 4) stop 2 + call split(input, set, p) + if (p /= 5) stop 3 + call split(input, set, p, .true.) + if (p /= 4) stop 4 + call split(input, set, p, .true.) + if (p /= 2) stop 5 + call split(input, set, p, .true.) + if (p /= 0) stop 6 +end program b diff --git a/gcc/testsuite/gfortran.dg/split_3.f90 b/gcc/testsuite/gfortran.dg/split_3.f90 new file mode 100644 index 0000000..bec3fdc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/split_3.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-shouldfail "Fortran runtime error" } + +program b + character(len=:), allocatable :: input + character(len=2) :: set = ', ' + integer :: p + input = " one,last example," + p = -1 + call split(input, set, p) +end program b diff --git a/gcc/testsuite/gfortran.dg/split_4.f90 b/gcc/testsuite/gfortran.dg/split_4.f90 new file mode 100644 index 0000000..a3c27bb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/split_4.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-shouldfail "Fortran runtime error" } + +program b + character(len=:), allocatable :: input + character(len=2) :: set = ', ' + integer :: p + input = " one,last example," + p = 0 + call split(input, set, p, .true.) +end program b diff --git a/gcc/testsuite/gfortran.dg/unused_artificial_dummies_1.f90 b/gcc/testsuite/gfortran.dg/unused_artificial_dummies_1.f90 index 68ceee7..6d21a89 100644 --- a/gcc/testsuite/gfortran.dg/unused_artificial_dummies_1.f90 +++ b/gcc/testsuite/gfortran.dg/unused_artificial_dummies_1.f90 @@ -32,7 +32,7 @@ contains subroutine foo1 (slist, i) character(*), dimension(*) :: slist integer i - write (slist(i), '(2hi=,i3)') i + write (slist(i), '(2hi=,i3)') i ! { dg-warning "H format specifier" } end subroutine foo1 ! This tests the additions to the fix that prevent the dummies of entry thunks diff --git a/gcc/testsuite/gfortran.dg/value_10.f90 b/gcc/testsuite/gfortran.dg/value_10.f90 new file mode 100644 index 0000000..b1c8d1d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_10.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! { dg-additional-options "-Wcharacter-truncation -fdump-tree-original" } +! PR fortran/121727 + +program p + use iso_c_binding, only: c_char + implicit none + call cbind('abcd') ! { dg-warning "length of actual argument longer" } + call one ('efgh') ! { dg-warning "length of actual argument longer" } + call one4 (4_'IJKL') ! { dg-warning "length of actual argument longer" } + + call two4 (4_'MNOP') ! { dg-warning "length of actual argument longer" } + call three('efgh') ! { dg-warning "length of actual argument longer" } + call four ('ijklmn') ! { dg-warning "length of actual argument longer" } +contains + subroutine cbind(c) bind(C) + character(kind=c_char,len=1), value :: c + end + + subroutine one(x) + character(kind=1,len=1), value :: x + end + + subroutine one4(w) + character(kind=4,len=1), value :: w + end + + subroutine two4(y) + character(kind=4,len=2), value :: y + end + + subroutine three(z) + character(kind=1,len=3), value :: z + end + + subroutine four(v) + character(kind=1,len=4), optional, value :: v + end +end + +! { dg-final { scan-tree-dump-times "two4 \\(.*, 2\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "three \\(.*, 3\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "four \\(.*, 1, 4\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/whole_file_24.f90 b/gcc/testsuite/gfortran.dg/whole_file_24.f90 index 3ff6ca8..7b322f1 100644 --- a/gcc/testsuite/gfortran.dg/whole_file_24.f90 +++ b/gcc/testsuite/gfortran.dg/whole_file_24.f90 @@ -27,7 +27,7 @@ module syntax_rules contains subroutine syntax_init_from_ifile () type(string_t) :: string - string = line_get_string_advance ("") + string = line_get_string_advance ("") ! { dg-warning "Character length of actual argument shorter" } end subroutine syntax_init_from_ifile end module syntax_rules end diff --git a/gcc/testsuite/gfortran.dg/whole_file_29.f90 b/gcc/testsuite/gfortran.dg/whole_file_29.f90 index 86d84cf..87ac4f3 100644 --- a/gcc/testsuite/gfortran.dg/whole_file_29.f90 +++ b/gcc/testsuite/gfortran.dg/whole_file_29.f90 @@ -19,7 +19,7 @@ module syntax_rules contains subroutine syntax_init_from_ifile () type(string_t) :: string - string = line_get_string_advance ("") + string = line_get_string_advance ("") ! { dg-warning "Character length of actual argument shorter" } end subroutine syntax_init_from_ifile end module syntax_rules end diff --git a/gcc/testsuite/gfortran.dg/x_slash_1.f b/gcc/testsuite/gfortran.dg/x_slash_1.f index 73db12e..b3c7218 100644 --- a/gcc/testsuite/gfortran.dg/x_slash_1.f +++ b/gcc/testsuite/gfortran.dg/x_slash_1.f @@ -18,7 +18,7 @@ c Line 2 has nothing but x editing, followed by a slash. c Line 3 has x editing finished off by a 1h* write (10, 100) - 100 format (1h1,58x,1h!,/,60x,/,59x,1h*,/) + 100 format (1h1,58x,1h!,/,60x,/,59x,1h*,/) ! { dg-warning "H format specifier" } rewind (10) read (10, 200) a @@ -42,7 +42,7 @@ c Line 3 has tabs to the left of present position. write (10, 101) 101 format (1h1,58x,1h#,/,t38,2x,1h ,tr10,9x,1h$,/, - > 6habcdef,tl4,2x,6hghijkl,t1,59x,1h*) + > 6habcdef,tl4,2x,6hghijkl,t1,59x,1h*) ! { dg-warning "H format specifier" } rewind (10) read (10, 200) a |