diff options
Diffstat (limited to 'gcc/testsuite/gfortran.dg')
24 files changed, 798 insertions, 5 deletions
diff --git a/gcc/testsuite/gfortran.dg/allocate_error_4.f90 b/gcc/testsuite/gfortran.dg/allocate_error_4.f90 new file mode 100644 index 00000000000..6652b472f49 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_error_4.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR fortran/55314 - the second allocate statement was rejected. + +program main + implicit none + integer :: max_nb + type comm_mask + integer(4), pointer :: mask(:) + end type comm_mask + type (comm_mask), allocatable, save :: encode(:,:) + max_nb=2 + allocate( encode(1:1,1:max_nb)) + allocate( encode(1,1)%mask(1),encode(1,2)%mask(1)) + deallocate( encode(1,1)%mask,encode(1,2)%mask) + allocate( encode(1,1)%mask(1),encode(1,1)%mask(1)) ! { dg-error "also appears at" } +end program main diff --git a/gcc/testsuite/gfortran.dg/array_section_3.f90 b/gcc/testsuite/gfortran.dg/array_section_3.f90 new file mode 100644 index 00000000000..d3093d14d50 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/array_section_3.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR fortran/54225 +! +! Contributed by robb wu +! +program test + implicit none + real :: A(2,3) + + print *, A(1, *) ! { dg-error "Expected array subscript" } +end program + +subroutine test2 +integer, dimension(2) :: a +a(*) = 1 ! { dg-error "Expected array subscript" } +end diff --git a/gcc/testsuite/gfortran.dg/bound_simplification_3.f90 b/gcc/testsuite/gfortran.dg/bound_simplification_3.f90 new file mode 100644 index 00000000000..de3a3dc8a94 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bound_simplification_3.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/54208 +! The I and J definitions used to raise an error because ARR's array spec +! was resolved to late for the LBOUND and UBOUND calls to be simplified to +! a constant. +! +! Contributed by Carlos A. Cruz <carlos.a.cruz@nasa.gov> + +program testit + integer, parameter :: n=2 + integer, dimension(1-min(n,2)/2:n) :: arr + integer, parameter :: i=lbound(arr,1) + integer, parameter :: j=ubound(arr,1) + ! write(6,*) i, j + if (i /= 0) call abort + if (j /= 2) call abort +end program testit + +! { dg-final { scan-tree-dump-times "bound" 0 "original" } } +! { dg-final { scan-tree-dump-times "abort" 0 "original" } } +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/class_55.f90 b/gcc/testsuite/gfortran.dg/class_55.f90 new file mode 100644 index 00000000000..b47989f416c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_55.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR 55983: [4.7/4.8 Regression] ICE in find_typebound_proc_uop, at fortran/class.c:2711 +! +! Contributed by Sylwester Arabas <slayoo@staszic.waw.pl> + + type :: mpdata_t + class(bcd_t), pointer :: bcx, bcy ! { dg-error "is a type that has not been declared" } + end type + type(mpdata_t) :: this + call this%bcx%fill_halos() ! { dg-error "is being used before it is defined" } +end diff --git a/gcc/testsuite/gfortran.dg/class_allocate_13.f90 b/gcc/testsuite/gfortran.dg/class_allocate_13.f90 new file mode 100644 index 00000000000..64f37dc59b5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_13.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! PR 54784: [4.7/4.8 Regression] [OOP] wrong code in polymorphic allocation with SOURCE +! +! Contributed by Jeremy Kozdon <jkozdon@gmail.com> + +program bug + implicit none + + type :: block + real, allocatable :: fields + end type + + type :: list + class(block),allocatable :: B + end type + + type :: domain + type(list),dimension(2) :: L + end type + + type(domain) :: d + type(block) :: b1 + + allocate(b1%fields,source=5.) + + allocate(d%L(2)%B,source=b1) ! wrong code + + if (d%L(2)%B%fields/=5.) call abort() + +end program diff --git a/gcc/testsuite/gfortran.dg/coarray_10.f90 b/gcc/testsuite/gfortran.dg/coarray_10.f90 index 99f5782e35b..78abb5ad191 100644 --- a/gcc/testsuite/gfortran.dg/coarray_10.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_10.f90 @@ -30,12 +30,12 @@ end subroutine this_image_check subroutine rank_mismatch() implicit none integer,allocatable :: A(:)[:,:,:,:] - allocate(A(1)[1,1,1:*]) ! { dg-error "Unexpected ... for codimension" } + allocate(A(1)[1,1,1:*]) ! { dg-error "Too few codimensions" } allocate(A(1)[1,1,1,1,1,*]) ! { dg-error "Invalid codimension 5" } allocate(A(1)[1,1,1,*]) allocate(A(1)[1,1]) ! { dg-error "Too few codimensions" } allocate(A(1)[1,*]) ! { dg-error "Too few codimensions" } - allocate(A(1)[1,1:*]) ! { dg-error "Unexpected ... for codimension" } + allocate(A(1)[1,1:*]) ! { dg-error "Too few codimensions" } A(1)[1,1,1] = 1 ! { dg-error "Too few codimensions" } A(1)[1,1,1,1,1,1] = 1 ! { dg-error "Invalid codimension 5" } @@ -48,5 +48,5 @@ end subroutine rank_mismatch subroutine rank_mismatch2() implicit none integer, allocatable:: A(:)[:,:,:] - allocate(A(1)[7:8,4:*]) ! { dg-error "Unexpected .*. for codimension 2 of 3" } + allocate(A(1)[7:8,4:*]) ! { dg-error "Too few codimensions" } end subroutine rank_mismatch2 diff --git a/gcc/testsuite/gfortran.dg/coarray_28.f90 b/gcc/testsuite/gfortran.dg/coarray_28.f90 new file mode 100644 index 00000000000..ca6f863568a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_28.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/54225 +! + +integer, allocatable :: a[:,:] + +allocate (a[*,4]) ! { dg-error "Unexpected '.' for codimension 1 of 2" } +end diff --git a/gcc/testsuite/gfortran.dg/elemental_scalar_args_2.f90 b/gcc/testsuite/gfortran.dg/elemental_scalar_args_2.f90 new file mode 100644 index 00000000000..c2b5df8d18b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/elemental_scalar_args_2.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! Test the fix for PR55618, in which character scalar function arguments to +! elemental functions would gain an extra indirect reference thus causing +! failures in Vst17.f95, Vst 30.f95 and Vst31.f95 in the iso_varying_string +! testsuite, where elemental tests are done. +! +! Reported by Tobias Burnus <burnus@gcc.gnu.org> +! + integer, dimension (2) :: i = [1,2] + integer :: j = 64 + character (len = 2) :: chr1 = "lm" + character (len = 1), dimension (2) :: chr2 = ["r", "s"] + if (any (foo (i, bar()) .ne. ["a", "b"])) call abort ! This would fail + if (any (foo (i, "xy") .ne. ["x", "y"])) call abort ! OK - not a function + if (any (foo (i, chr1) .ne. ["l", "m"])) call abort ! ditto + if (any (foo (i, char (j)) .ne. ["A", "B"])) call abort ! This would fail + if (any (foo (i, chr2) .ne. ["s", "u"])) call abort ! OK - not a scalar + if (any (foo (i, bar2()) .ne. ["e", "g"])) call abort ! OK - not a scalar function +contains + elemental character(len = 1) function foo (arg1, arg2) + integer, intent (in) :: arg1 + character(len = *), intent (in) :: arg2 + if (len (arg2) > 1) then + foo = arg2(arg1:arg1) + else + foo = char (ichar (arg2) + arg1) + end if + end function + character(len = 2) function bar () + bar = "ab" + end function + function bar2 () result(res) + character (len = 1), dimension(2) :: res + res = ["d", "e"] + end function +end diff --git a/gcc/testsuite/gfortran.dg/enum_10.f90 b/gcc/testsuite/gfortran.dg/enum_10.f90 index 99a16901c4b..188976637da 100644 --- a/gcc/testsuite/gfortran.dg/enum_10.f90 +++ b/gcc/testsuite/gfortran.dg/enum_10.f90 @@ -1,7 +1,7 @@ ! { dg-do run } ! { dg-additional-sources enum_10.c } ! { dg-options "-fshort-enums -w" } -! { dg-options "-fshort-enums -w -Wl,--no-enum-size-warning" { target arm*-*-linux*eabi } } +! { dg-options "-fshort-enums -w -Wl,--no-enum-size-warning" { target arm*-*-linux*eabi* } } ! Make sure short enums are indeed interoperable with the ! corresponding C type. diff --git a/gcc/testsuite/gfortran.dg/enum_9.f90 b/gcc/testsuite/gfortran.dg/enum_9.f90 index 8a5c60a10f4..fec5d92c6ba 100644 --- a/gcc/testsuite/gfortran.dg/enum_9.f90 +++ b/gcc/testsuite/gfortran.dg/enum_9.f90 @@ -1,6 +1,6 @@ ! { dg-do run } ! { dg-options "-fshort-enums" } -! { dg-options "-fshort-enums -Wl,--no-enum-size-warning" { target arm*-*-linux*eabi } } +! { dg-options "-fshort-enums -Wl,--no-enum-size-warning" { target arm*-*-linux*eabi* } } ! Program to test enumerations when option -fshort-enums is given program main diff --git a/gcc/testsuite/gfortran.dg/implicit_pure_3.f90 b/gcc/testsuite/gfortran.dg/implicit_pure_3.f90 new file mode 100644 index 00000000000..d9d7734dab3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/implicit_pure_3.f90 @@ -0,0 +1,109 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-optimized" } +! +! PR fortran/54556 +! +! Contributed by Joost VandeVondele +! +MODULE parallel_rng_types + + IMPLICIT NONE + + ! Global parameters in this module + INTEGER, PARAMETER :: dp=8 + + TYPE rng_stream_type + PRIVATE + CHARACTER(LEN=40) :: name + INTEGER :: distribution_type + REAL(KIND=dp), DIMENSION(3,2) :: bg,cg,ig + LOGICAL :: antithetic,extended_precision + REAL(KIND=dp) :: buffer + LOGICAL :: buffer_filled + END TYPE rng_stream_type + + REAL(KIND=dp), DIMENSION(3,3) :: a1p0,a1p76,a1p127,& + a2p0,a2p76,a2p127,& + inv_a1,inv_a2 + + INTEGER, PARAMETER :: GAUSSIAN = 1,& + UNIFORM = 2 + + REAL(KIND=dp), PARAMETER :: norm = 2.328306549295727688e-10_dp,& + m1 = 4294967087.0_dp,& + m2 = 4294944443.0_dp,& + a12 = 1403580.0_dp,& + a13n = 810728.0_dp,& + a21 = 527612.0_dp,& + a23n = 1370589.0_dp,& + two17 = 131072.0_dp,& ! 2**17 + two53 = 9007199254740992.0_dp,& ! 2**53 + fact = 5.9604644775390625e-8_dp ! 1/2**24 + + +CONTAINS + + FUNCTION rn32(rng_stream) RESULT(u) + + TYPE(rng_stream_type), POINTER :: rng_stream + REAL(KIND=dp) :: u + + INTEGER :: k + REAL(KIND=dp) :: p1, p2 + +! ------------------------------------------------------------------------- +! Component 1 + + p1 = a12*rng_stream%cg(2,1) - a13n*rng_stream%cg(1,1) + k = INT(p1/m1) + p1 = p1 - k*m1 + IF (p1 < 0.0_dp) p1 = p1 + m1 + rng_stream%cg(1,1) = rng_stream%cg(2,1) + rng_stream%cg(2,1) = rng_stream%cg(3,1) + rng_stream%cg(3,1) = p1 + + ! Component 2 + + p2 = a21*rng_stream%cg(3,2) - a23n*rng_stream%cg(1,2) + k = INT(p2/m2) + p2 = p2 - k*m2 + IF (p2 < 0.0_dp) p2 = p2 + m2 + rng_stream%cg(1,2) = rng_stream%cg(2,2) + rng_stream%cg(2,2) = rng_stream%cg(3,2) + rng_stream%cg(3,2) = p2 + + ! Combination + + IF (p1 > p2) THEN + u = (p1 - p2)*norm + ELSE + u = (p1 - p2 + m1)*norm + END IF + + IF (rng_stream%antithetic) u = 1.0_dp - u + + END FUNCTION rn32 + +! ***************************************************************************** + FUNCTION rn53(rng_stream) RESULT(u) + + TYPE(rng_stream_type), POINTER :: rng_stream + REAL(KIND=dp) :: u + + u = rn32(rng_stream) + + IF (rng_stream%antithetic) THEN + u = u + (rn32(rng_stream) - 1.0_dp)*fact + IF (u < 0.0_dp) u = u + 1.0_dp + ELSE + u = u + rn32(rng_stream)*fact + IF (u >= 1.0_dp) u = u - 1.0_dp + END IF + + END FUNCTION rn53 + +END MODULE + +! { dg-final { scan-module-absence "parallel_rng_types" "IMPLICIT_PURE" } } +! { dg-final { scan-tree-dump-times "rn32 \\(rng_stream" 3 "optimized" } } +! { dg-final { cleanup-tree-dump "optimized" } } diff --git a/gcc/testsuite/gfortran.dg/internal_pack_13.f90 b/gcc/testsuite/gfortran.dg/internal_pack_13.f90 new file mode 100644 index 00000000000..21fdc541878 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/internal_pack_13.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! PR 55072: [4.6/4.7/4.8 Regression] Missing internal_pack leads to wrong code with derived type +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> + +implicit none +type t +integer :: i +end type t +type(t), target :: tgt(4,4) +type(t), pointer :: p(:,:) +integer :: i,j,k + +k = 1 +do i = 1, 4 + do j = 1, 4 + tgt(i,j)%i = k + k = k+1 + end do +end do + +p => tgt(::2,::2) +print *,p%i +call bar(p) + +contains + + subroutine bar(x) + type(t) :: x(*) + print *,x(1:4)%i + if (any (x(1:4)%i /= [1, 9, 3, 11])) call abort() + end subroutine +end diff --git a/gcc/testsuite/gfortran.dg/internal_pack_14.f90 b/gcc/testsuite/gfortran.dg/internal_pack_14.f90 new file mode 100644 index 00000000000..1a4b3725fbb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/internal_pack_14.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! PR 55072: [4.6/4.7/4.8 Regression] Missing internal_pack leads to wrong code with derived type +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + +program GiBUU_neutrino_bug + + Type particle + integer :: ID + End Type + + type(particle), dimension(1:2,1:2) :: OutPart + + OutPart(1,:)%ID = 1 + OutPart(2,:)%ID = 2 + + call s1(OutPart(1,:)) + +contains + + subroutine s1(j) + type(particle) :: j(:) + print *,j(:)%ID + call s2(j) + end subroutine + + subroutine s2(k) + type(particle) :: k(1:2) + print *,k(:)%ID + if (any (k(1:2)%ID /= [1, 1])) call abort() + end subroutine + +end diff --git a/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 b/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 new file mode 100644 index 00000000000..d5f4bd23d55 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/55852 +! +! Contributed by A. Kasahara +! +program bug + implicit none + + Real, allocatable:: a(:) + integer(2) :: iszs + + allocate(a(1:3)) + + iszs = ubound((a), 1)! Was ICEing +! print*, ubound((a), 1) ! Was ICEing +! print*, ubound(a, 1) ! OK +! print*, lbound((a), 1) ! OK +! print*, lbound(a, 1) ! OK + + stop +end program bug + +! { dg-final { scan-tree-dump-times "iszs = \\(integer\\(kind=2\\)\\) MAX_EXPR <\\(D.....->dim.0..ubound - D.....->dim.0..lbound\\) \\+ 1, 0>;" 1 "original" } } +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/namelist_76.f90 b/gcc/testsuite/gfortran.dg/namelist_76.f90 new file mode 100644 index 00000000000..acb3b2f6561 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_76.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR 55352: [4.7/4.8 Regression] Erroneous gfortran warning of unused module variable when variable is only used in namelist +! +! Contributed by <AstroFloyd@gmail.com> + +module data + implicit none + integer :: a +end module data + +program test + use data, only: a + implicit none + a = 1 + call write_data() +end program test + +subroutine write_data() + use data, only: a + implicit none + namelist /write_data_list/ a + open(unit=10,form='formatted',status='replace',action='write',file='test.dat') + write(10, nml=write_data_list) + close(10) +end subroutine write_data + +! { dg-final { cleanup-modules "data" } } diff --git a/gcc/testsuite/gfortran.dg/select_type_29.f03 b/gcc/testsuite/gfortran.dg/select_type_29.f03 new file mode 100644 index 00000000000..71603e3841a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_29.f03 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR 54435: [4.7/4.8 Regression] ICE with SELECT TYPE on a non-CLASS object +! +! Contributed by xarthisius + +subroutine foo(x) + integer :: x + select type (x) ! { dg-error "Selector shall be polymorphic" } + end select +end + + +! PR 54443: [4.7/4.8 Regression] Segmentation Fault when Compiling for code using Fortran Polymorphic Entities +! +! Contributed by Mark Beyer <mbeyer@cirrusaircraft.com> + +program class_test + type hashnode + character(4) :: htype + end type + class(hashnode), pointer :: hp + + select type(hp%htype) ! { dg-error "is not a named variable" } + +end program diff --git a/gcc/testsuite/gfortran.dg/transfer_class_1.f90 b/gcc/testsuite/gfortran.dg/transfer_class_1.f90 new file mode 100644 index 00000000000..00b3a2405f3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_class_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-Wsurprising" } +! +! PR 54917: [4.7/4.8 Regression] [OOP] TRANSFER on polymorphic variable causes ICE +! +! Contributed by Sean Santos <quantheory@gmail.com> + +subroutine test_routine1(arg) + implicit none + type test_type + integer :: test_comp + end type + class(test_type) :: arg + integer :: i + i = transfer(arg, 1) +end subroutine diff --git a/gcc/testsuite/gfortran.dg/transfer_intrinsic_4.f b/gcc/testsuite/gfortran.dg/transfer_intrinsic_4.f new file mode 100644 index 00000000000..4173afdde1a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_intrinsic_4.f @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR fortran/54818 +! +! Contributed by Scott Pakin +! + subroutine broken ( name1, name2, bmix ) + + implicit none + + integer, parameter :: i_knd = kind( 1 ) + integer, parameter :: r_knd = selected_real_kind( 13 ) + + character(len=8) :: dum + character(len=8) :: blk + real(r_knd), dimension(*) :: bmix, name1, name2 + integer(i_knd) :: j, idx1, n, i + integer(i_knd), external :: nafix + + write (*, 99002) name1(j), + & ( adjustl( + & transfer(name2(nafix(bmix(idx1+i),1)),dum)//blk + & //blk), bmix(idx1+i+1), i = 1, n, 2 ) + +99002 format (' *', 10x, a8, 8x, 3(a24,1pe12.5,',',6x)) + + end subroutine broken diff --git a/gcc/testsuite/gfortran.dg/use_22.f90 b/gcc/testsuite/gfortran.dg/use_22.f90 new file mode 100644 index 00000000000..d61df671322 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/use_22.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! PR fortran/55827 +! gfortran used to ICE with the call to `tostring' depending on how the +! `tostring' symbol was USE-associated. +! +! Contributed by Lorenz Hüdepohl <bugs@stellardeath.org> + +module stringutils + interface + pure function strlen(handle) result(len) + integer, intent(in) :: handle + integer :: len + end function + end interface +end module +module intermediate ! does not die if this module is merged with stringutils + contains + function tostring(handle) result(string) + use stringutils + integer, intent(in) :: handle + character(len=strlen(handle)) :: string + end function +end module +module usage + contains + subroutine dies_here(handle) + use stringutils ! does not die if this unnecessary line is omitted or placed after "use intermediate" + use intermediate + integer :: handle + write(*,*) tostring(handle) ! ICE + end subroutine +end module + + diff --git a/gcc/testsuite/gfortran.dg/use_23.f90 b/gcc/testsuite/gfortran.dg/use_23.f90 new file mode 100644 index 00000000000..da05e1a8e20 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/use_23.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } +! +! PR fortran/42769 +! This test used to ICE in resolve_typebound_procedure because T1's GET +! procedure was wrongly associated to MOD2's MY_GET (instead of the original +! MOD1's MY_GET) in MOD3's SUB. +! +! Original testcase by Salvator Filippone <sfilippone@uniroma2.it> +! Reduced by Janus Weil <janus@gcc.gnu.org> + +module mod1 + type :: t1 + contains + procedure, nopass :: get => my_get + end type +contains + logical function my_get() + end function +end module + +module mod2 +contains + logical function my_get() + end function +end module + +module mod3 +contains + subroutine sub(a) + use mod2, only: my_get + use mod1, only: t1 + type(t1) :: a + end subroutine +end module + + +use mod2, only: my_get +use mod3, only: sub +end + + + diff --git a/gcc/testsuite/gfortran.dg/use_24.f90 b/gcc/testsuite/gfortran.dg/use_24.f90 new file mode 100644 index 00000000000..b709347b0fd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/use_24.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! +! PR fortran/42769 +! The static resolution of A%GET used to be incorrectly simplified to MOD2's +! MY_GET instead of the original MOD1's MY_GET, depending on the order in which +! MOD1 and MOD2 were use-associated. +! +! Original testcase by Salvator Filippone <sfilippone@uniroma2.it> +! Reduced by Janus Weil <janus@gcc.gnu.org> + +module mod1 + type :: t1 + contains + procedure, nopass :: get => my_get + end type +contains + subroutine my_get(i) + i = 2 + end subroutine +end module + +module mod2 +contains + subroutine my_get(i) ! must have the same name as the function in mod1 + i = 5 + end subroutine +end module + + + call test1() + call test2() + +contains + + subroutine test1() + use mod2 + use mod1 + type(t1) :: a + call a%get(j) + if (j /= 2) call abort + end subroutine test1 + + subroutine test2() + use mod1 + use mod2 + type(t1) :: a + call a%get(j) + if (j /= 2) call abort + end subroutine test2 +end + + + diff --git a/gcc/testsuite/gfortran.dg/use_25.f90 b/gcc/testsuite/gfortran.dg/use_25.f90 new file mode 100644 index 00000000000..b79297f9fce --- /dev/null +++ b/gcc/testsuite/gfortran.dg/use_25.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! +! PR fortran/42769 +! This test used to be rejected because the typebound call A%GET was +! simplified to MY_GET which is an ambiguous name in the main program +! namespace. +! +! Original testcase by Salvator Filippone <sfilippone@uniroma2.it> +! Reduced by Janus Weil <janus@gcc.gnu.org> + +module mod1 + type :: t1 + contains + procedure, nopass :: get => my_get + end type +contains + subroutine my_get() + print *,"my_get (mod1)" + end subroutine +end module + +module mod2 +contains + subroutine my_get() ! must have the same name as the function in mod1 + print *,"my_get (mod2)" + end subroutine +end module + + use mod2 + use mod1 + type(t1) :: a + call call_get + contains + subroutine call_get + call a%get() + end subroutine call_get +end + + diff --git a/gcc/testsuite/gfortran.dg/use_26.f90 b/gcc/testsuite/gfortran.dg/use_26.f90 new file mode 100644 index 00000000000..2e66401a14c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/use_26.f90 @@ -0,0 +1,76 @@ +! { dg-do compile } +! +! PR fortran/45836 +! The B_TYPE_INSTANCE%SIZERETURN() typebound function used to be rejected on a +! type mismatch because the function was resolved to A's SIZERETURN instead of +! B's because of the ambiguity of the SIZERETURN name in the MAIN namespace. +! +! Original testcase by someone <ortp21@gmail.com> + +module A +implicit none + type :: a_type + private + integer :: size = 1 + contains + procedure :: sizeReturn + end type a_type + contains + function sizeReturn( a_type_ ) + implicit none + integer :: sizeReturn + class(a_type) :: a_type_ + + sizeReturn = a_type_%size + end function sizeReturn +end module A + +module B +implicit none + type :: b_type + private + integer :: size = 2 + contains + procedure :: sizeReturn + end type b_type + contains + function sizeReturn( b_type_ ) + implicit none + integer :: sizeReturn + class(b_type) :: b_type_ + + sizeReturn = b_type_%size + end function sizeReturn +end module B + +program main + + call test1 + call test2 + +contains + + subroutine test1 + use A + use B + implicit none + type(a_type) :: a_type_instance + type(b_type) :: b_type_instance + + print *, a_type_instance%sizeReturn() + print *, b_type_instance%sizeReturn() + end subroutine test1 + + subroutine test2 + use B + use A + implicit none + type(a_type) :: a_type_instance + type(b_type) :: b_type_instance + + print *, a_type_instance%sizeReturn() + print *, b_type_instance%sizeReturn() + end subroutine test2 +end program main + + diff --git a/gcc/testsuite/gfortran.dg/use_27.f90 b/gcc/testsuite/gfortran.dg/use_27.f90 new file mode 100644 index 00000000000..71d77cc0180 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/use_27.f90 @@ -0,0 +1,103 @@ +! { dg-do run } +! +! PR fortran/45900 +! The BTYPEINSTANCE%CALLBACK() typebound call was resolved incorrectly to +! A's CALLBACK procedure instead of B's because the CALLBACK name is ambiguous +! in the MAIN namespace. +! +! Original testcase by someone <ortp21@gmail.com> + +module A +implicit none + type :: aType + contains + procedure :: callback + end type aType + contains + subroutine callback( callback_, i ) + implicit none + class(aType) :: callback_ + integer :: i + + i = 3 + end subroutine callback + + subroutine solver( callback_, i ) + implicit none + class(aType) :: callback_ + integer :: i + + call callback_%callback(i) + end subroutine solver +end module A + +module B +use A, only: aType +implicit none + type, extends(aType) :: bType + integer :: i + contains + procedure :: callback + end type bType + contains + subroutine callback( callback_, i ) + implicit none + class(bType) :: callback_ + integer :: i + + i = 7 + end subroutine callback +end module B + +program main + call test1() + call test2() + +contains + + subroutine test1 + use A + use B + implicit none + type(aType) :: aTypeInstance + type(bType) :: bTypeInstance + integer :: iflag + + bTypeInstance%i = 4 + + iflag = 0 + call bTypeInstance%callback(iflag) + if (iflag /= 7) call abort + iflag = 1 + call solver( bTypeInstance, iflag ) + if (iflag /= 7) call abort + + iflag = 2 + call aTypeInstance%callback(iflag) + if (iflag /= 3) call abort + end subroutine test1 + + subroutine test2 + use B + use A + implicit none + type(aType) :: aTypeInstance + type(bType) :: bTypeInstance + integer :: iflag + + bTypeInstance%i = 4 + + iflag = 0 + call bTypeInstance%callback(iflag) + if (iflag /= 7) call abort + iflag = 1 + call solver( bTypeInstance, iflag ) + if (iflag /= 7) call abort + + iflag = 2 + call aTypeInstance%callback(iflag) + if (iflag /= 3) call abort + end subroutine test2 +end program main + + |