http://gcc.gnu.org/bugzilla/show_bug.cgi?id=58851
--- Comment #3 from paul.richard.thomas at gmail dot com <paul.richard.thomas
at gmail dot com> ---
I had changed the testcase to:
! { dg-do run }
!
! PR fortran/58793
!
! Contributed by Vladimir Fuka
!
! Had the wrong value for the storage_size for complex
!
module m
use iso_fortran_env
implicit none
integer, parameter :: c1 = real_kinds(1)
integer, parameter :: c2 = real_kinds(2)
integer, parameter :: c3 = real_kinds(size(real_kinds)-1)
integer, parameter :: c4 = real_kinds(size(real_kinds))
real(c1) :: r1
real(c2) :: r2
real(c3) :: r3
real(c4) :: r4
contains
subroutine s(o, k)
class(*) :: o
integer :: k
integer :: sz
select case (k)
case (4)
sz = storage_size(r1)*2
case (8)
sz = storage_size(r2)*2
case (10)
sz = storage_size(r3)*2
case (16)
sz = storage_size(r4)*2
case default
call abort()
end select
if (storage_size(o) /= sz) call abort()
select type (o)
type is (complex(c1))
if (storage_size(o) /= sz) call abort()
type is (complex(c2))
if (storage_size(o) /= sz) call abort()
type is (complex(c3))
if (storage_size(o) /= sz) call abort()
type is (complex(c4))
if (storage_size(o) /= sz) call abort()
end select
end subroutine s
end module m
program p
use m
call s((1._c1, 2._c1), c1)
call s((1._c2, 2._c2), c2)
call s((1._c3, 2._c3), c3)
call s((1._c4, 2._c4), c4)
end program p
Is it not the case that the select type (o) is unnecessary for the test?
That is ' if (storage_size(o) /= sz) call abort()' is all that is needed?
Cheers
Paul
On 23 October 2013 17:44, burnus at gcc dot gnu.org
<[email protected]> wrote:
> http://gcc.gnu.org/bugzilla/show_bug.cgi?id=58851
>
> Tobias Burnus <burnus at gcc dot gnu.org> changed:
>
> What |Removed |Added
> ----------------------------------------------------------------------------
> CC| |burnus at gcc dot gnu.org
>
> --- Comment #2 from Tobias Burnus <burnus at gcc dot gnu.org> ---
> How about the following (untested)? It has a bit less coverage but hopefully
> it
> is still sufficient. Additionally, it should be portable.
>
> --- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_13.f90
> +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_13.f90
> @@ -20,0 +21,8 @@ contains
> + real(c1) :: rc1
> + real(c2) :: rc2
> + real(c3) :: rc3
> + real(c4) :: rc4
> + complex(c1) :: cc1
> + complex(c2) :: cc2
> + complex(c3) :: cc3
> + complex(c4) :: cc4
> @@ -22,10 +30,14 @@ contains
> - select case (k)
> - case (4)
> - sz = 32*2
> - case (8)
> - sz = 64*2
> - case (10,16)
> - sz = 128*2
> - case default
> - call abort()
> - end select
> + if (k == c1) then
> + sz = storage_size(cc1)
> + if (sz /= 2*storage_size(rc1)) call abort()
> + elseif (k == c2) then
> + sz = storage_size(cc2)
> + if (sz /= 2*storage_size(rc2)) call abort()
> + elseif (k == c3) then
> + sz = storage_size(cc3)
> + if (sz /= 2*storage_size(rc3)) call abort()
> + elseif (k == c4) then
> + sz = storage_size(cc4)
> + if (sz /= 2*storage_size(rc4)) call abort()
> + endif
> + if (sz < 2) call abort()
>
> --
> You are receiving this mail because:
> You are on the CC list for the bug.
> You are the assignee for the bug.
