http://gcc.gnu.org/bugzilla/show_bug.cgi?id=55763
Bug #: 55763
Summary: Issues with some simpler CLASS(*) programs
Classification: Unclassified
Product: gcc
Version: 4.8.0
Status: UNCONFIRMED
Keywords: ice-on-valid-code, rejects-valid
Severity: normal
Priority: P3
Component: fortran
AssignedTo: unassig...@gcc.gnu.org
ReportedBy: bur...@gcc.gnu.org
CC: pa...@gcc.gnu.org
There are some known bigger issues of CLASS(*) which are tracked elsewhere.
This is about simpler issues.
The following program by Reinhold Bader fails with a bogus:
type is (integer)
1
alloc_scalar_01_pos.f90:27.15:
class default
2
Error: The DEFAULT CASE at (1) cannot be followed by a second DEFAULT CASE at
(2)
!----------------------------
module mod_alloc_scalar_01
contains
subroutine construct(this)
class(*), allocatable, intent(out) :: this
integer :: this_i
this_i = 4
allocate(this, source=this_i)
end subroutine
end module
program alloc_scalar_01
use mod_alloc_scalar_01
implicit none
class(*), allocatable :: mystuff
call construct(mystuff)
call construct(mystuff)
select type(mystuff)
type is (integer)
if (mystuff == 4) then
write(*,*) 'OK'
else
write(*,*) 'FAIL 1'
end if
class default
write(*,*) 'FAIL 2'
end select
end program
!----------------------------
While the following program by the same author causes an ICE (segmentation
fault) at
0x5573ac get_unique_type_string
../../gcc/fortran/class.c:447
0x557ef8 get_unique_hashed_string
../../gcc/fortran/class.c:470
0x558087 gfc_find_derived_vtab(gfc_symbol*)
../../gcc/fortran/class.c:1833
0x625d18 gfc_conv_procedure_call(gfc_se*, gfc_symbol*, gfc_actual_arglist*,
gfc_expr*, vec<tree_node*, va_gc, vl_embed>*)
../../gcc/fortran/trans-expr.c:4308
!----------------------------
module mod_alloc_scalar_02
contains
subroutine construct(this)
class(*), allocatable, intent(out) :: this
integer :: this_i
this_i = 4
allocate(this, source=this_i)
end subroutine
subroutine out(this)
class(*) :: this
select type(this)
type is (integer)
if (this == 4) then
write(*,*) 'OK'
else
write(*,*) 'FAIL 1'
end if
class default
write(*,*) 'FAIL 2'
end select
end subroutine
end module
program alloc_scalar_02
use mod_alloc_scalar_02
implicit none
class(*), allocatable :: mystuff
call construct(mystuff)
call out(mystuff)
end program
!----------------------------
And the following MOVE_ALLOC code, which moves TYPE(integer) to CLASS(*) fails
with:
call move_alloc(i2, i1)
1
Error: The FROM and TO arguments of the MOVE_ALLOC intrinsic at (1) must be of
the same kind 4/0
!----------------------------
program mvall_03
implicit none
integer, parameter :: n1 = 100, n2 = 200
class(*), allocatable :: i1(:)
integer, allocatable :: i2(:)
allocate(real :: i1(n1))
allocate(i2(n2))
i2 = 2
call move_alloc(i2, i1)
if (size(i1) /= n2 .or. allocated(i2)) then
write(*,*) 'FAIL'
else
write(*,*) 'OK'
end if
end program
!----------------------------
And finally, the following program - again by Reinhold Bader - gives an ICE
(segfault) at
vector_comp => field
0x62d477 gfc_trans_pointer_assignment(gfc_expr*, gfc_expr*)
../../gcc/fortran/trans-expr.c:6523
!----------------------------
program change_field_type
use, intrinsic :: iso_c_binding
implicit none
TYPE, BIND(C) :: scalar_vector
REAL(kind=c_float) :: scalar
REAL(kind=c_float) :: vec(3)
END TYPE
TYPE, BIND(C) :: scalar_vector_matrix
REAL(kind=c_float) :: scalar
REAL(kind=c_float) :: vec(3)
REAL(kind=c_float) :: mat(3,3)
END TYPE
CLASS(*), ALLOCATABLE, TARGET :: one_d_field(:)
real, pointer :: v1(:)
allocate(one_d_field(3), &
source = (/ scalar_vector( 1.0, (/ -1.0, 0.0, 1.0 /) ), &
scalar_vector( 1.1, (/ -1.2, 0.2, 0.9 /) ), &
scalar_vector( 1.2, (/ -1.4, 0.4, 0.8 /) ) /) )
call extract_vec(one_d_field, 1, v1, 2)
print *, v1
deallocate(one_d_field) ! v1 becomes undefined
allocate(one_d_field(1), &
source = (/ scalar_vector_matrix( 1.0, (/ -1.0, 0.0, 1.0 /), &
reshape( (/ 1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0 /), &
(/3, 3/) ) ) /) )
call extract_vec(one_d_field, 2, v1, 1)
print *, v1
deallocate(one_d_field) ! v1 becomes undefined
contains
subroutine extract_vec(field, tag, vector_comp, ic)
use, intrinsic :: iso_c_binding
CLASS(*), TARGET :: field(:)
REAL(kind=c_float), POINTER :: vector_comp(:)
INTEGER(kind=c_int), value :: tag, ic
type(scalar_vector), pointer :: sv(:)
type(scalar_vector_matrix), pointer :: svm(:)
select type (field)
type is (real(c_float))
vector_comp => field
class default
select case (tag)
case (1)
sv => field
vector_comp => sv(:)%vec(ic)
case (2)
svm => field
vector_comp => svm(:)%vec(ic)
end select
end select
end subroutine
end program
!----------------------------
