[Bug fortran/55763] New: Issues with some simpler CLASS(*) programs

burnus at gcc dot gnu.org gcc-bugzilla@gcc.gnu.org
Thu Dec 20 16:18:00 GMT 2012


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: unassigned@gcc.gnu.org
        ReportedBy: burnus@gcc.gnu.org
                CC: pault@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
!----------------------------



More information about the Gcc-bugs mailing list