Passing class arrays as dummy argument - not working - gfortran 4.8 and 5.3

[Paolo Orsini <paolo dot orsini at gmail dot com>]

Hi,

I tried to report this bug into GCC Bugzilla, however I couldn't
create an account  ("User account creation has been restricted).

The bug I found is related to passing class arrays, as dummy arguments.
Please see sample code below.

The code compiles ok, but when it runs the values passed down to the
calling function through a class array, are wrong. This happens
specifically for class members that are pointer arrays, allocated with
"allocate".

!****************************************************************************************
module ClassExample_class

  implicit none

  private

  type, public :: class_example_type
    double precision :: value
    double precision, pointer :: ar(:)
  end type class_example_type


end module ClassExample_class

!*****************************************************************************!
!*****************************************************************************!

module ClassExampleExt1_class

  use ClassExample_class

  implicit none

  private

  type, public, extends(class_example_type) :: class_example_ext1_type
    double precision :: val_ext1
    double precision, pointer :: ar_ext1(:)
  end type class_example_ext1_type

end module ClassExampleExt1_class

!*****************************************************************************!
!*****************************************************************************!

module ClassExampleExt2_class

  use ClassExampleExt1_class

  implicit none

  private

  type, public, extends(class_example_ext1_type) :: class_example_ext2_type
    double precision :: val_ext2
    double precision, pointer :: ar_ext2(:)
  end type class_example_ext2_type

end module ClassExampleExt2_class


!*****************************************************************************!
!*****************************************************************************!

module ArrayAnalysis_module

  implicit none

  private

  public :: PrintClassArrayOneDim,CheckClassArrayPassingError

contains
!*****************************************************************************!
subroutine PrintClassArrayOneDim(class_array_dummy)

  use ClassExampleExt2_class

  implicit none

  class(class_example_ext2_type) :: class_array_dummy(:)
  integer :: icount1,sub_array_idx

  do icount1 =1,size(class_array_dummy,1)
    !base
    write(*,*) "array idx counter = ",icount1, &
       " value = ", &
        class_array_dummy(icount1)%value, &
       " ar = ", &
        class_array_dummy(icount1)%ar(2)
    !ext 1
    write(*,*) "array idx counter = ",icount1,&
      " val_ext1 = ", &
        class_array_dummy(icount1)%val_ext1, &
       " ar_ext1 = ", &
        class_array_dummy(icount1)%ar_ext1(2)
    !ext 2
    write(*,*) "array idx counter = ",icount1, &
      " val_ext2 = ", &
        class_array_dummy(icount1)%val_ext2, &
       " ar_ext2 = ", &
        class_array_dummy(icount1)%ar_ext2(2)
  end do

end subroutine PrintClassArrayOneDim
!*****************************************************************************!
subroutine CheckClassArrayPassingError(class_array_dummy)

  use ClassExampleExt2_class

  implicit none

  class(class_example_ext2_type) :: class_array_dummy(:)
  integer :: icount1,sub_array_idx

  do icount1 =1,size(class_array_dummy)
  !do icount1 =1,3

    if ( class_array_dummy(icount1)%value /= 1.0 ) then
      call PrintErrorMsg(icount1,0,class_array_dummy(icount1)%value,0)
    end if

    if ( class_array_dummy(icount1)%val_ext1 /= 1.0 ) then
      call PrintErrorMsg(icount1,0,class_array_dummy(icount1)%val_ext1,1)
    end if

    if ( class_array_dummy(icount1)%val_ext2 /= 1.0 ) then
      call PrintErrorMsg(icount1,0,class_array_dummy(icount1)%val_ext2,2)
    end if

    do sub_array_idx =1,size(class_array_dummy(icount1)%ar)
      if (class_array_dummy(icount1)%ar(sub_array_idx) /=1.0 ) then
        call PrintErrorMsg(icount1,sub_array_idx, &
           class_array_dummy(icount1)%ar(sub_array_idx),0)
      end if
    end do

    do sub_array_idx =1,size(class_array_dummy(icount1)%ar_ext1)
      if (class_array_dummy(icount1)%ar_ext1(sub_array_idx) /=1.0 ) then
        call PrintErrorMsg(icount1,sub_array_idx, &
           class_array_dummy(icount1)%ar_ext1(sub_array_idx),1)
      end if
    end do

    do sub_array_idx =1,size(class_array_dummy(icount1)%ar_ext2)
      if (class_array_dummy(icount1)%ar_ext2(sub_array_idx) /=1.0 ) then
        call PrintErrorMsg(icount1,sub_array_idx, &
           class_array_dummy(icount1)%ar_ext1(sub_array_idx),2)
      end if
    end do

  end do

end subroutine CheckClassArrayPassingError
!*****************************************************************************!
subroutine PrintErrorMsg(icount,sub_array_idx,value,level)

  implicit none

  integer :: icount,sub_array_idx,level
  double precision :: value

  write(*,*) "compiler bug detected"
  write(*,*) "class level Ext = ",level
  write(*,*) "class array idx = ",icount
  write(*,*) "sub-array idx  = ", sub_array_idx
  write(*,*) "wrong passed value  = ", value

  stop

end subroutine PrintErrorMsg

end module ArrayAnalysis_module

!*****************************************************************************!
!*****************************************************************************!

Program g48_class_arrays_bug

  use ClassExampleExt2_class
  use ArrayAnalysis_module

  implicit none

  integer :: icount1,icount2
  integer :: n1,n2

  class(class_example_ext2_type), pointer :: class_array(:)

  n1 = 3
  allocate(class_array(n1))

  do icount1 = 1,n1
    !base
    class_array(icount1)%value = 1.0d0
    allocate(class_array(icount1)%ar(3))
    class_array(icount1)%ar(1:3) = 1.0d0
    !class_array(icount1)%ar = 1.0d0
    !ext-1
    class_array(icount1)%val_ext1 = 1.0
    allocate(class_array(icount1)%ar_ext1(3))
    class_array(icount1)%ar_ext1(1:3) = 1.0
    !ext-2
    class_array(icount1)%val_ext2 = 1.0
    allocate(class_array(icount1)%ar_ext2(3))
    class_array(icount1)%ar_ext2(1:3) = 1.0
  end do

  call PrintClassArrayOneDim(class_array)
  call CheckClassArrayPassingError(class_array)

end program

!*****************************************************************************************

The exact two gfrotran versions I tried are:

GNU Fortran (Ubuntu 4.8.4-2ubuntu1~14.04) 4.8.4
Copyright (C) 2013 Free Software Foundation, Inc.

and

GNU Fortran (Ubuntu 5.3.1-14ubuntu2) 5.3.1 20160413
Copyright (C) 2015 Free Software Foundation, Inc.

Note that for the 5.3.1 version. when the code is running, still
passing garbage via the class array, it also print the following
warning:
"Note: The following floating-point exceptions are signalling: IEEE_DENORMAL"

I hope this helps,

Please don't hesitate to get in touch if you have any question.

Paolo