diff options
Diffstat (limited to 'gcc/testsuite/gfortran.dg')
28 files changed, 754 insertions, 8 deletions
diff --git a/gcc/testsuite/gfortran.dg/auto_dealloc_1.f90 b/gcc/testsuite/gfortran.dg/auto_dealloc_1.f90 new file mode 100644 index 00000000000..176f87a3d34 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/auto_dealloc_1.f90 @@ -0,0 +1,59 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR 41586: Allocatable _scalars_ are never auto-deallocated +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> + +module automatic_deallocation + + type t0 + integer :: i + end type + + type t1 + real :: pi = 3.14 + integer, allocatable :: j + end type + + type t2 + class(t0), allocatable :: k + end type t2 + +contains + + ! (1) simple allocatable scalars + subroutine a + integer, allocatable :: m + allocate (m) + m = 42 + end subroutine + + ! (2) allocatable scalar CLASS variables + subroutine b + class(t0), allocatable :: m + allocate (t0 :: m) + m%i = 43 + end subroutine + + ! (3) allocatable scalar components + subroutine c + type(t1) :: m + allocate (m%j) + m%j = 44 + end subroutine + + ! (4) allocatable scalar CLASS components + subroutine d + type(t2) :: m + allocate (t0 :: m%k) + m%k%i = 45 + end subroutine + +end module + + +! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } } + +! { dg-final { cleanup-modules "automatic_deallocation" } } +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/class_10.f03 b/gcc/testsuite/gfortran.dg/class_10.f03 new file mode 100644 index 00000000000..f238a597a65 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_10.f03 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR 41800: [OOP] ICE in fold_convert_loc, at fold-const.c:2789 +! +! Contributed by Harald Anlauf <anlauf@gmx.de> + +module abstract_gradient + + implicit none + private + + type, public, abstract :: gradient_class + contains + procedure, nopass :: inner_product + end type + +contains + + function inner_product () + class(gradient_class), pointer :: inner_product + inner_product => NULL() + end function + +end module + + + use abstract_gradient + class(gradient_class), pointer :: g_initial, ip_save + ip_save => g_initial%inner_product() ! ICE +end + +! { dg-final { cleanup-modules "abstract_gradient" } } diff --git a/gcc/testsuite/gfortran.dg/class_5.f03 b/gcc/testsuite/gfortran.dg/class_5.f03 new file mode 100644 index 00000000000..087d745aec7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_5.f03 @@ -0,0 +1,31 @@ +! { dg-do compile } +! +! PR 41719: [OOP] invalid: Intrinsic assignment involving polymorphic variables +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> + + implicit none + + type t1 + integer :: a + end type + + type, extends(t1) :: t2 + integer :: b + end type + + class(t1),pointer :: cp + type(t2) :: x + + x = t2(45,478) + allocate(t2 :: cp) + + cp = x ! { dg-error "Variable must not be polymorphic" } + + select type (cp) + type is (t2) + print *, cp%a, cp%b + end select + +end +
\ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/class_6.f03 b/gcc/testsuite/gfortran.dg/class_6.f03 new file mode 100644 index 00000000000..2f3ff62a6fa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_6.f03 @@ -0,0 +1,21 @@ +! { dg-do run } +! +! PR 41629: [OOP] gimplification error on valid code +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + + type t1 + integer :: comp + end type + + type(t1), target :: a + + class(t1) :: x + pointer :: x ! This is valid + + a%comp = 3 + x => a + print *,x%comp + if (x%comp/=3) call abort() + +end diff --git a/gcc/testsuite/gfortran.dg/class_7.f03 b/gcc/testsuite/gfortran.dg/class_7.f03 new file mode 100644 index 00000000000..ed4eeba9340 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_7.f03 @@ -0,0 +1,21 @@ +! { dg-do compile } +! Test fixes for PR41587 and PR41608. +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> +! +! PR41587: used to accept the declaration of component 'foo' + type t0 + integer :: j = 42 + end type t0 + type t + integer :: i + class(t0), allocatable :: foo(3) ! { dg-error "deferred shape" } + end type t + +! PR41608: Would ICE on missing type decl + class(t1), pointer :: c ! { dg-error "before it is defined" } + + select type (c) ! { dg-error "shall be polymorphic" } + type is (t1) ! { dg-error "Unexpected" } + end select ! { dg-error "Expecting END PROGRAM" } +end diff --git a/gcc/testsuite/gfortran.dg/class_8.f03 b/gcc/testsuite/gfortran.dg/class_8.f03 new file mode 100644 index 00000000000..78f10ebe2bd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_8.f03 @@ -0,0 +1,16 @@ +! { dg-do compile } +! Test fixes for PR41618. +! +! Contributed by Janus Weil <janus@gcc.gnu.org> +! + type t1 + integer :: comp + class(t1),pointer :: cc + end type + + class(t1) :: x ! { dg-error "must be dummy, allocatable or pointer" } + + x%comp = 3 + print *,x%comp + +end diff --git a/gcc/testsuite/gfortran.dg/class_9.f03 b/gcc/testsuite/gfortran.dg/class_9.f03 new file mode 100644 index 00000000000..5dbd4597abd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_9.f03 @@ -0,0 +1,68 @@ +! { dg-do run } +! Test the fix for PR41706, in which arguments of class methods that +! were themselves class methods did not work. +! +! Contributed by Janus Weil <janus@gcc.gnu.org> +! +module m +type :: t + real :: v = 1.5 +contains + procedure, nopass :: a + procedure, nopass :: b + procedure, pass :: c + procedure, nopass :: d +end type + +contains + + real function a (x) + real :: x + a = 2.*x + end function + + real function b (x) + real :: x + b = 3.*x + end function + + real function c (x) + class (t) :: x + c = 4.*x%v + end function + + subroutine d (x) + real :: x + if (abs(x-3.0)>1E-3) call abort() + end subroutine + + subroutine s (x) + class(t) :: x + real :: r + r = x%a (1.1) ! worked + if (r .ne. a (1.1)) call abort + + r = x%a (b (1.2)) ! worked + if (r .ne. a(b (1.2))) call abort + + r = b ( x%a (1.3)) ! worked + if (r .ne. b(a (1.3))) call abort + + r = x%a(x%b (1.4)) ! failed + if (r .ne. a(b (1.4))) call abort + + r = x%a(x%c ()) ! failed + if (r .ne. a(c (x))) call abort + + call x%d (x%a(1.5)) ! failed + + end subroutine + +end + + use m + class(t),allocatable :: x + allocate(x) + call s (x) +end +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/class_allocate_1.f03 b/gcc/testsuite/gfortran.dg/class_allocate_1.f03 index 719d90cf8f9..67c8065794b 100644 --- a/gcc/testsuite/gfortran.dg/class_allocate_1.f03 +++ b/gcc/testsuite/gfortran.dg/class_allocate_1.f03 @@ -68,8 +68,7 @@ i = 0 allocate(t2 :: cp2) -! FIXME: Not yet supported: source=<class> -! allocate(cp, source = cp2) + allocate(cp, source = cp2) allocate(t2 :: cp3) allocate(cp, source=cp3) select type (cp) diff --git a/gcc/testsuite/gfortran.dg/class_allocate_2.f03 b/gcc/testsuite/gfortran.dg/class_allocate_2.f03 index d6a5d78bd75..754faa9a9f4 100644 --- a/gcc/testsuite/gfortran.dg/class_allocate_2.f03 +++ b/gcc/testsuite/gfortran.dg/class_allocate_2.f03 @@ -7,7 +7,7 @@ type :: t end type t class(t), allocatable :: c,d allocate(t :: d) -allocate(c,source=d) ! { dg-error "not supported yet" } +allocate(c,source=d) end type, abstract :: t diff --git a/gcc/testsuite/gfortran.dg/class_allocate_3.f03 b/gcc/testsuite/gfortran.dg/class_allocate_3.f03 new file mode 100644 index 00000000000..c6128a8ab51 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_3.f03 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! PR 41581: [OOP] Allocation of a CLASS with SOURCE=<class> does not work +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> + + type t + end type t + + type,extends(t) :: t2 + integer :: i = 54 + real :: r = 384.02 + end type t2 + + class(t), allocatable :: m1, m2 + + allocate(t2 :: m2) + select type(m2) + type is (t2) + print *, m2%i, m2%r + if (m2%i/=54) call abort() + if (abs(m2%r-384.02)>1E-3) call abort() + m2%i = 42 + m2%r = -4.0 + class default + call abort() + end select + + allocate(m1, source=m2) + select type(m1) + type is (t2) + print *, m1%i, m1%r + if (m1%i/=42) call abort() + if (abs(m1%r+4.0)>1E-3) call abort() + class default + call abort() + end select + +end diff --git a/gcc/testsuite/gfortran.dg/complex_intrinsic_8.f90 b/gcc/testsuite/gfortran.dg/complex_intrinsic_8.f90 new file mode 100644 index 00000000000..f9529a52334 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/complex_intrinsic_8.f90 @@ -0,0 +1,50 @@ +! { dg-do link } +! { dg-require-effective-target mpc_arc } +! +! PR fortran/33197 +! +! Fortran complex trigonometric functions: acos, asin, atan, acosh, asinh, atanh +! +! Compile-time simplifications +! +implicit none +real(4), parameter :: pi = 2*acos(0.0_4) +real(8), parameter :: pi8 = 2*acos(0.0_8) +real(4), parameter :: eps = 10*epsilon(0.0_4) +real(8), parameter :: eps8 = 10*epsilon(0.0_8) +complex(4), parameter :: z0_0 = cmplx(0.0_4, 0.0_4, kind=4) +complex(4), parameter :: z1_1 = cmplx(1.0_4, 1.0_4, kind=4) +complex(8), parameter :: z80_0 = cmplx(0.0_8, 0.0_8, kind=8) +complex(8), parameter :: z81_1 = cmplx(1.0_8, 1.0_8, kind=8) + +if (abs(acos(z0_0) - cmplx(pi/2,-0.0,4)) > eps) call link_error() +if (abs(acos(z1_1) - cmplx(0.904556894, -1.06127506,4)) > eps) call link_error() +if (abs(acos(z80_0) - cmplx(pi8/2,-0.0_8,8)) > eps8) call link_error() +if (abs(acos(z81_1) - cmplx(0.90455689430238140_8, -1.0612750619050357_8,8)) > eps8) call link_error() + +if (abs(asin(z0_0) - cmplx(0.0,0.0,4)) > eps) call link_error() +if (abs(asin(z1_1) - cmplx(0.66623943, 1.06127506,4)) > eps) call link_error() +if (abs(asin(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call link_error() +if (abs(asin(z81_1) - cmplx(0.66623943249251527_8, 1.0612750619050357_8,8)) > eps8) call link_error() + +if (abs(atan(z0_0) - cmplx(0.0,0.0,4)) > eps) call link_error() +if (abs(atan(z1_1) - cmplx(1.01722196, 0.40235947,4)) > eps) call link_error() +if (abs(atan(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call link_error() +if (abs(atan(z81_1) - cmplx(1.0172219678978514_8, 0.40235947810852507_8,8)) > eps8) call link_error() + +if (abs(acosh(z0_0) - cmplx(0.0,pi/2,4)) > eps) call link_error() +if (abs(acosh(z1_1) - cmplx(1.06127506, 0.90455689,4)) > eps) call link_error() +if (abs(acosh(z80_0) - cmplx(0.0_8,pi8/2,8)) > eps8) call link_error() +if (abs(acosh(z81_1) - cmplx(1.0612750619050357_8, 0.90455689430238140_8,8)) > eps8) call link_error() + +if (abs(asinh(z0_0) - cmplx(0.0,0.0,4)) > eps) call link_error() +if (abs(asinh(z1_1) - cmplx(1.06127506, 0.66623943,4)) > eps) call link_error() +if (abs(asinh(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call link_error() +if (abs(asinh(z81_1) - cmplx(1.0612750619050357_8, 0.66623943249251527_8,8)) > eps8) call link_error() + +if (abs(atanh(z0_0) - cmplx(0.0,0.0,4)) > eps) call link_error() +if (abs(atanh(z1_1) - cmplx(0.40235947, 1.01722196,4)) > eps) call link_error() +if (abs(atanh(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call link_error() +if (abs(atanh(z81_1) - cmplx(0.40235947810852507_8, 1.0172219678978514_8,8)) > eps8) call link_error() + +end diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_4.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_4.f03 new file mode 100644 index 00000000000..b72819acc4c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_4.f03 @@ -0,0 +1,96 @@ +! { dg-do run } +! Tests the fix for PR41648 in which the reference a%a%getit () was wrongly +! identified as a recursive call to getit. +! +! Contributed by Salvatore Filippone <sfilippone@uniroma2.it> +! +module foo_mod + type foo + integer :: i + contains + procedure, pass(a) :: doit + procedure, pass(a) :: getit + end type foo + + private doit,getit +contains + subroutine doit(a) + class(foo) :: a + + a%i = 1 + end subroutine doit + function getit(a) result(res) + class(foo) :: a + integer :: res + + res = a%i + end function getit + +end module foo_mod + +module s_bar_mod + use foo_mod + type, extends(foo) :: s_bar + type(foo), allocatable :: a + contains + procedure, pass(a) :: doit + procedure, pass(a) :: getit + end type s_bar + private doit,getit + +contains + subroutine doit(a) + class(s_bar) :: a + allocate (a%a) + call a%a%doit() + end subroutine doit + function getit(a) result(res) + class(s_bar) :: a + integer :: res + + res = a%a%getit () * 2 + end function getit +end module s_bar_mod + +module a_bar_mod + use foo_mod + type, extends(foo) :: a_bar + type(foo), allocatable :: a(:) + contains + procedure, pass(a) :: doit + procedure, pass(a) :: getit + end type a_bar + private doit,getit + +contains + subroutine doit(a) + class(a_bar) :: a + allocate (a%a(1)) + call a%a(1)%doit () + end subroutine doit + function getit(a) result(res) + class(a_bar) :: a + integer :: res + + res = a%a(1)%getit () * 3 + end function getit +end module a_bar_mod + + use s_bar_mod + use a_bar_mod + type(foo), target :: b + type(s_bar), target :: c + type(a_bar), target :: d + class(foo), pointer :: a + a => b + call a%doit + if (a%getit () .ne. 1) call abort + a => c + call a%doit + if (a%getit () .ne. 2) call abort + a => d + call a%doit + if (a%getit () .ne. 3) call abort +end +! { dg-final { cleanup-modules "foo_mod s_bar_mod a_bar_mod" } } + diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 new file mode 100644 index 00000000000..8533508bcdc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 @@ -0,0 +1,185 @@ +! { dg-do compile } +! Tests the fix for PR4164656 in which the call to a%a%scal failed to compile. +! +! Contributed by Salvatore Filippone <sfilippone@uniroma2.it> +! +module const_mod + integer, parameter :: longndig=12 + integer, parameter :: long_int_k_ = selected_int_kind(longndig) + integer, parameter :: dpk_ = kind(1.d0) + integer, parameter :: spk_ = kind(1.e0) +end module const_mod + +module base_mat_mod + use const_mod + type :: base_sparse_mat + integer, private :: m, n + integer, private :: state, duplicate + logical, private :: triangle, unitd, upper, sorted + contains + procedure, pass(a) :: get_nzeros + end type base_sparse_mat + private :: get_nzeros +contains + function get_nzeros(a) result(res) + implicit none + class(base_sparse_mat), intent(in) :: a + integer :: res + integer :: err_act + character(len=20) :: name='base_get_nzeros' + logical, parameter :: debug=.false. + res = -1 + end function get_nzeros +end module base_mat_mod + +module s_base_mat_mod + use base_mat_mod + type, extends(base_sparse_mat) :: s_base_sparse_mat + contains + procedure, pass(a) :: s_scals + procedure, pass(a) :: s_scal + generic, public :: scal => s_scals, s_scal + end type s_base_sparse_mat + private :: s_scals, s_scal + + type, extends(s_base_sparse_mat) :: s_coo_sparse_mat + + integer :: nnz + integer, allocatable :: ia(:), ja(:) + real(spk_), allocatable :: val(:) + contains + procedure, pass(a) :: get_nzeros => s_coo_get_nzeros + procedure, pass(a) :: s_scals => s_coo_scals + procedure, pass(a) :: s_scal => s_coo_scal + end type s_coo_sparse_mat + private :: s_coo_scals, s_coo_scal, s_coo_get_nzeros +contains + subroutine s_scals(d,a,info) + implicit none + class(s_base_sparse_mat), intent(in) :: a + real(spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='s_scals' + logical, parameter :: debug=.false. + + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + end subroutine s_scals + + + subroutine s_scal(d,a,info) + implicit none + class(s_base_sparse_mat), intent(in) :: a + real(spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='s_scal' + logical, parameter :: debug=.false. + + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + end subroutine s_scal + + function s_coo_get_nzeros(a) result(res) + implicit none + class(s_coo_sparse_mat), intent(in) :: a + integer :: res + res = a%nnz + end function s_coo_get_nzeros + + + subroutine s_coo_scal(d,a,info) + use const_mod + implicit none + class(s_coo_sparse_mat), intent(inout) :: a + real(spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + info = 0 + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + end subroutine s_coo_scal + + subroutine s_coo_scals(d,a,info) + use const_mod + implicit none + class(s_coo_sparse_mat), intent(inout) :: a + real(spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + end subroutine s_coo_scals +end module s_base_mat_mod + +module s_mat_mod + use s_base_mat_mod + type :: s_sparse_mat + class(s_base_sparse_mat), pointer :: a + contains + procedure, pass(a) :: s_scals + procedure, pass(a) :: s_scal + generic, public :: scal => s_scals, s_scal + end type s_sparse_mat + interface scal + module procedure s_scals, s_scal + end interface +contains + subroutine s_scal(d,a,info) + use const_mod + implicit none + class(s_sparse_mat), intent(inout) :: a + real(spk_), intent(in) :: d(:) + integer, intent(out) :: info + integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + print *, "s_scal" + call a%a%scal(d,info) + return + end subroutine s_scal + + subroutine s_scals(d,a,info) + use const_mod + implicit none + class(s_sparse_mat), intent(inout) :: a + real(spk_), intent(in) :: d + integer, intent(out) :: info + integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + print *, "s_scals" + call a%a%scal(d,info) + return + end subroutine s_scals +end module s_mat_mod + + use s_mat_mod + class (s_sparse_mat), pointer :: a + type (s_sparse_mat), target :: b + type (s_base_sparse_mat), target :: c + integer info + b%a => c + a => b + call a%scal (1.0_spk_, info) +end +! { dg-final { cleanup-modules "const_mod base_mat_mod s_base_mat_mod s_mat_mod" } } + diff --git a/gcc/testsuite/gfortran.dg/equiv_8.f90 b/gcc/testsuite/gfortran.dg/equiv_8.f90 new file mode 100644 index 00000000000..a2ed7f0349e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/equiv_8.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! +! PR fortran/41755 +! + common /uno/ aa + equivalence (aa,aaaaa) (bb,cc) ! { dg-error "Expecting a comma in EQUIVALENCE" } + end diff --git a/gcc/testsuite/gfortran.dg/fmt_error_9.f b/gcc/testsuite/gfortran.dg/fmt_error_9.f index 0f2b63b6d32..d8abb851210 100644 --- a/gcc/testsuite/gfortran.dg/fmt_error_9.f +++ b/gcc/testsuite/gfortran.dg/fmt_error_9.f @@ -22,4 +22,8 @@ write (line,'(1pd24.15e11.3)') 1.0d0, 1.234 if (line.ne." 1.000000000000000D+00 1.234E+00") call abort + str = '(1p2d24.15)' + msg = " 1.000000000000000D+00 1.233999967575073D+00That's it!" + write (line,'(1p2d24.15a)') 1.0d0, 1.234, "That's it!" + if (line.ne.msg) print *, msg end diff --git a/gcc/testsuite/gfortran.dg/goto_8.f90 b/gcc/testsuite/gfortran.dg/goto_8.f90 new file mode 100644 index 00000000000..a5f1f7f07b9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goto_8.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! +! PR 41781: [OOP] bogus undefined label error with SELECT TYPE. +! +! Contributed by Salvatore Filippone <sfilippone@uniroma2.it> +! and Tobias Burnus >burnus@gcc.gnu.org> + +! 1st example: jumping out of SELECT TYPE (valid) +type bar + integer :: i +end type bar +class(bar), pointer :: var +select type(var) +class default + goto 9999 +end select +9999 continue + +! 2nd example: jumping out of BLOCK (valid) +block + goto 88 +end block +88 continue + +! 3rd example: jumping into BLOCK (invalid) +goto 99 ! { dg-error "is not in the same block" } +block + 99 continue ! { dg-error "is not in the same block" } +end block + +end diff --git a/gcc/testsuite/gfortran.dg/lto/20091015-1_0.f b/gcc/testsuite/gfortran.dg/lto/20091015-1_0.f new file mode 100644 index 00000000000..f47e1a4ac6c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/lto/20091015-1_0.f @@ -0,0 +1,8 @@ +! { dg-lto-do link } +! We expect some warnings about mismatched symbol types +! { dg-extra-ld-options "-w" } + + subroutine dalie6s(iqmod6,nz,wx,cor6d) + common/dascr/iscrda(100),rscrri(100),iscrri(100),idao + call daall(iscrda,100,'$$IS ',no,nv) + end diff --git a/gcc/testsuite/gfortran.dg/lto/20091015-1_1.f b/gcc/testsuite/gfortran.dg/lto/20091015-1_1.f new file mode 100644 index 00000000000..7a64ffa6786 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/lto/20091015-1_1.f @@ -0,0 +1,4 @@ + SUBROUTINE DAALL(IC,L,CCC,NO,NV) + COMMON /main1/ eps + END + diff --git a/gcc/testsuite/gfortran.dg/lto/20091015-1_2.f b/gcc/testsuite/gfortran.dg/lto/20091015-1_2.f new file mode 100644 index 00000000000..5bfd02227fa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/lto/20091015-1_2.f @@ -0,0 +1,5 @@ + program test + common/main1/ eps(2) + dimension cor6d(2,2) + call dalie6s(iqmod6,1,wx,cor6d) + end diff --git a/gcc/testsuite/gfortran.dg/lto/20091016-1_0.f90 b/gcc/testsuite/gfortran.dg/lto/20091016-1_0.f90 new file mode 100644 index 00000000000..c26ad90fbe2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/lto/20091016-1_0.f90 @@ -0,0 +1,12 @@ +! { dg-lto-do link } +! { dg-lto-options {{-flto -g -fPIC -shared} {-O -flto -g -fPIC -shared}} } + + FUNCTION makenumberstring(x) + IMPLICIT NONE + REAL, INTENT(IN) :: x + CHARACTER(len=20) :: makenumberstring + INTEGER :: xx + xx = x**2 ! << ICE + makenumberstring = '' + END FUNCTION + diff --git a/gcc/testsuite/gfortran.dg/lto/pr41521_0.f90 b/gcc/testsuite/gfortran.dg/lto/pr41521_0.f90 new file mode 100644 index 00000000000..d882779263d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/lto/pr41521_0.f90 @@ -0,0 +1,9 @@ +! { dg-lto-do link } +! { dg-lto-options {{-g -flto} {-g -O -flto}} } +program species +integer spk(2) +real eval(2) +spk = 2 +call atom(1.1,spk,eval) +end program + diff --git a/gcc/testsuite/gfortran.dg/lto/pr41521_1.f90 b/gcc/testsuite/gfortran.dg/lto/pr41521_1.f90 new file mode 100644 index 00000000000..897e7aded0a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/lto/pr41521_1.f90 @@ -0,0 +1,9 @@ +subroutine atom(sol,k,eval) +real, intent(in) :: sol +integer, intent(in) :: k(2) +real, intent(out) :: eval(2) +real t1 + t1=sqrt(dble(k(1)**2)-(sol)**2) + eval(1)=sol**2/sqrt(t1)-sol**2 +end subroutine + diff --git a/gcc/testsuite/gfortran.dg/select_type_7.f03 b/gcc/testsuite/gfortran.dg/select_type_7.f03 new file mode 100644 index 00000000000..554b6cd122d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_7.f03 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! PR 41766: [OOP] SELECT TYPE selector as actual argument with INTENT(INOUT) +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + + implicit none + + type t1 + integer :: a + end type + + type, extends(t1) :: t2 + integer :: b + end type + + class(t1),allocatable :: cp + + allocate(t2 :: cp) + + select type (cp) + type is (t2) + cp%a = 98 + cp%b = 76 + call s(cp) + print *,cp%a,cp%b + if (cp%a /= cp%b) call abort() + class default + call abort() + end select + +contains + + subroutine s(f) + type(t2), intent(inout) :: f + f%a = 3 + f%b = 3 + end subroutine + +end diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 index 57b34486313..b8dc5c9d104 100644 --- a/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 @@ -50,7 +50,6 @@ CONTAINS LOGICAL FUNCTION func (me, b) ! { dg-error "must be a SUBROUTINE" } CLASS(t), INTENT(OUT) :: me CLASS(t), INTENT(IN) :: b - me = t () func = .TRUE. END FUNCTION func diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 index 1ce2b97a0d7..835ceb63ff0 100644 --- a/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 @@ -37,7 +37,7 @@ CONTAINS PURE SUBROUTINE assign_int (dest, from) CLASS(myint), INTENT(OUT) :: dest INTEGER, INTENT(IN) :: from - dest = myint (from) + dest%value = from END SUBROUTINE assign_int TYPE(myreal) FUNCTION add_real (a, b) @@ -49,7 +49,7 @@ CONTAINS SUBROUTINE assign_real (dest, from) CLASS(myreal), INTENT(OUT) :: dest REAL, INTENT(IN) :: from - dest = myreal (from) + dest%value = from END SUBROUTINE assign_real SUBROUTINE in_module () diff --git a/gcc/testsuite/gfortran.dg/vect/fast-math-pr38968.f90 b/gcc/testsuite/gfortran.dg/vect/fast-math-pr38968.f90 index abb3c5f10df..3b8ac9defc3 100644 --- a/gcc/testsuite/gfortran.dg/vect/fast-math-pr38968.f90 +++ b/gcc/testsuite/gfortran.dg/vect/fast-math-pr38968.f90 @@ -1,3 +1,4 @@ +! { dg-timeout-factor 4.0 } program mymatmul implicit none integer, parameter :: kp = 4 diff --git a/gcc/testsuite/gfortran.dg/whole_file_5.f90 b/gcc/testsuite/gfortran.dg/whole_file_5.f90 index 07ba4411c4c..c6ad9e1b448 100644 --- a/gcc/testsuite/gfortran.dg/whole_file_5.f90 +++ b/gcc/testsuite/gfortran.dg/whole_file_5.f90 @@ -1,6 +1,6 @@ ! { dg-do "compile" } ! { dg-options "-O3 -fwhole-file -fdump-tree-optimized" } -! { dg-options "-O3 -fwhole-file -fdump-tree-optimized -fpie" { target { ! nonpic } } } +! { dg-add-options bind_pic_locally } ! ! Check that inlining of functions declared BEFORE usage works. ! If yes, then the dump does not contain a call to F(). diff --git a/gcc/testsuite/gfortran.dg/whole_file_6.f90 b/gcc/testsuite/gfortran.dg/whole_file_6.f90 index f903c7aefc5..274b8a99c6c 100644 --- a/gcc/testsuite/gfortran.dg/whole_file_6.f90 +++ b/gcc/testsuite/gfortran.dg/whole_file_6.f90 @@ -1,6 +1,6 @@ ! { dg-do "compile" } ! { dg-options "-O3 -fwhole-file -fdump-tree-optimized" } -! { dg-options "-O3 -fwhole-file -fdump-tree-optimized -fpie" { target { ! nonpic } } } +! { dg-add-options bind_pic_locally } ! ! Check that inlining of functions declared AFTER usage works. ! If yes, then the dump does not contain a call to F(). |