[Bug fortran/89374] New: gfortran does not respect privacy of types

[juergen.reuter at desy dot de]

https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89374

            Bug ID: 89374
           Summary: gfortran does not respect privacy of types
           Product: gcc
           Version: 9.0
            Status: UNCONFIRMED
          Severity: normal
          Priority: P3
         Component: fortran
          Assignee: unassigned at gcc dot gnu.org
          Reporter: juergen.reuter at desy dot de
  Target Milestone: ---

The following example is from the Intel Forum, cf. 
https://software.intel.com/en-us/forums/intel-fortran-compiler-for-linux-and-mac-os-x/topic/583935
The NAG compiler and now also the Intel compiler report:
Error: abstract.f90, line 69: Cannot extend abstract type ABSTRACT_BUGGY
because it has a private deferred type-bound procedure BUGGY_MULTIPLY_SCALAR
       detected at ::@BUGGY
Error: abstract.f90, line 69: Cannot extend abstract type ABSTRACT_BUGGY
because it has a private deferred type-bound procedure SCALAR_MULTIPLY_BUGGY
       detected at ::@BUGGY
Error: abstract.f90, line 69: Cannot extend abstract type ABSTRACT_BUGGY
because it has a private deferred type-bound procedure BUGGY_ASSIGN_BUGGY
       detected at ::@BUGGY
[NAG Fortran Compiler pass 1 error termination, 3 errors]
If I  undestand this correctly, the abstract types cannot be extended because
they are private, and not public. gfortran doesn't seem to recognize this. 


The code is below 

module type_abstract_buggy
implicit none
private
public :: abstract_buggy

type, abstract :: abstract_buggy
  contains
    ! public methods
    procedure(abstract_printf), public, deferred :: printf
    generic,                    public           :: operator(*) =>
buggy_multiply_scalar, scalar_multiply_buggy
    generic,                    public           :: assignment(=) =>
buggy_assign_buggy
    ! private methods
    procedure(abstract_buggy_multiply_scalar),       pass(lhs), private,
deferred :: buggy_multiply_scalar
    procedure(scalar_multiply_abstract_buggy),       pass(rhs), private,
deferred :: scalar_multiply_buggy
    procedure(abstract_buggy_assign_abstract_buggy), pass(lhs), private,
deferred :: buggy_assign_buggy
endtype abstract_buggy
abstract interface
  subroutine abstract_printf(self)
  import :: abstract_buggy
  class(abstract_buggy), intent(IN) :: self
  endsubroutine abstract_printf

  function abstract_buggy_multiply_scalar(lhs, rhs) result(multy)
  import :: abstract_buggy
  class(abstract_buggy), intent(IN)  :: lhs
  integer,               intent(IN)  :: rhs
  class(abstract_buggy), allocatable :: multy
  endfunction abstract_buggy_multiply_scalar

  function scalar_multiply_abstract_buggy(lhs, rhs) result(multy)
  import :: abstract_buggy
  integer,               intent(IN)  :: lhs
  class(abstract_buggy), intent(IN)  :: rhs
  class(abstract_buggy), allocatable :: multy
  endfunction scalar_multiply_abstract_buggy

  pure subroutine abstract_buggy_assign_abstract_buggy(lhs, rhs)
  import :: abstract_buggy
  class(abstract_buggy), intent(INOUT) :: lhs
  class(abstract_buggy), intent(IN)    :: rhs
  endsubroutine abstract_buggy_assign_abstract_buggy
endinterface
endmodule type_abstract_buggy

module lib_abstract_buggy
use type_abstract_buggy, only : abstract_buggy
implicit none
private
public :: raise_bug
contains
  subroutine raise_bug(bug, scalar)
  class(abstract_buggy), intent(INOUT) :: bug
  integer,               intent(IN)    :: scalar

  call bug%printf()
  bug = bug * scalar
  call bug%printf()
  bug = scalar * bug
  call bug%printf()
  endsubroutine raise_bug
endmodule lib_abstract_buggy

module type_buggy
use type_abstract_buggy, only : abstract_buggy
implicit none
private
public :: buggy

type, extends(abstract_buggy) :: buggy
  private
  real, dimension(:), allocatable :: array
  integer                         :: scalar=0
  contains
    ! public methods
    procedure, pass(self), public :: printf
    ! private methods
    procedure, pass(lhs), private :: buggy_multiply_scalar
    procedure, pass(rhs), private :: scalar_multiply_buggy
    procedure, pass(lhs), private :: buggy_assign_buggy
endtype buggy
interface buggy
  procedure create_buggy
endinterface
contains
  pure function create_buggy(array, scalar) result(bug)
  real, dimension(:), intent(IN) :: array
  integer,            intent(IN) :: scalar
  type(buggy)                    :: bug

  bug%array = array
  bug%scalar = scalar
  return
  endfunction create_buggy

  subroutine printf(self)
  class(buggy), intent(IN) :: self
  integer      :: i

  print "(A)", "Array:"
  do i=1, size(self%array)
    print*, self%array(i)
  enddo
  print "(A,I5)", "Scalar: ", self%scalar
  endsubroutine printf

  function buggy_multiply_scalar(lhs, rhs) result(multy)
  class(buggy), intent(IN)           :: lhs
  integer,      intent(IN)           :: rhs
  class(abstract_buggy), allocatable :: multy
  type(buggy),           allocatable :: multy_tmp

  allocate(buggy :: multy_tmp)
  multy_tmp%array = lhs%array * rhs
  multy_tmp%scalar = lhs%scalar
  call move_alloc(multy_tmp, multy)
  return
  endfunction buggy_multiply_scalar

  pure function scalar_multiply_buggy(lhs, rhs) result(multy)
  integer,      intent(IN)           :: lhs
  class(buggy), intent(IN)           :: rhs
  class(abstract_buggy), allocatable :: multy
  type(buggy),           allocatable :: multy_tmp

  allocate(buggy :: multy_tmp)
  multy_tmp%array = rhs%array * lhs
  multy_tmp%scalar = rhs%scalar
  call move_alloc(multy_tmp, multy)
  return
  endfunction scalar_multiply_buggy

  pure subroutine buggy_assign_buggy(lhs, rhs)
  class(buggy),          intent(INOUT) :: lhs
  class(abstract_buggy), intent(IN)    :: rhs

  select type(rhs)
  class is(buggy)
    if (allocated(rhs%array)) lhs%array = rhs%array
    lhs%scalar = rhs%scalar
  endselect
  return
  endsubroutine buggy_assign_buggy
endmodule type_buggy

program ifort_bug
use lib_abstract_buggy, only : raise_bug
use type_buggy, only : buggy
implicit none
type(buggy) :: bug

bug = buggy(array=[1., 2., 3.], scalar=3)
call raise_bug(bug=bug, scalar=2)
stop
endprogram ifort_bug