[Bug fortran/93691] New: Type bound assignment causes too many finalization of derived type when part of other type

[floschiffmann at gmail dot com]

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

            Bug ID: 93691
           Summary: Type bound assignment causes too many finalization of
                    derived type when part of other type
           Product: gcc
           Version: 9.2.0
            Status: UNCONFIRMED
          Severity: normal
          Priority: P3
         Component: fortran
          Assignee: unassigned at gcc dot gnu.org
          Reporter: floschiffmann at gmail dot com
  Target Milestone: ---

Good morning,

when writing a reference counting scheme, I cam across this slightly intricate
bug. I suspect this is related to a problem in the type bound assignment but I
could not pin it down.

The problem:
Type(Inner) has type bound assignment and Final.
   -assignment associates output reference counter to input reference counter
and incrments
   -final decrements reference counter and deallocates reference count pointer
when 0

Type(outer) has type(inner) as member.

If Type(inner) is used by itself everything works correctly
However, if assignment of type(outer) to type(outer) is made, an additional
finalization is invoked (the third with an unassociated reference counter).

Here is the simplest test code I could produce:

! ==============================  BEGIN TEST CODE ========================

MODULE Classes
    IMPLICIT NONE

    TYPE   :: Inner
       INTEGER, POINTER              :: icount
       CONTAINS
       PROCEDURE                     :: init
       PROCEDURE                     :: assignMe
       GENERIC                       :: assignment(=) => assignMe
       FINAL                         :: deleteIt
    END TYPE

   TYPE Outer
      TYPE(Inner)    :: ext
   END TYPE
CONTAINS
   SUBROUTINE init(self)
      CLASS(Inner), INTENT(INOUT)      ::  self

      ALLOCATE(self%icount)
      self%icount=1
   END SUBROUTINE 

! Destrutor, if data is assigned decrement counter and delete once we reach 0
   SUBROUTINE deleteIt(self)
      TYPE(Inner)          ::  self

WRITE(*,*)"FINAL CALLED with icount =", self%icount, "LOC =",LOC(self%icount)
         self%icount=self%icount-1
         IF(self%icount<=0)THEN ! usually == 0 but <=0 better shows the problem
            self%icount=-100
WRITE(*,*)"      DEALLOCATING ICOUNT at LOC=", LOC(self%icount)
            DEALLOCATE(self%icount)
         END IF
   END SUBROUTINE

! The basic assigment routine, set pointer to input data pointer and increment
counter 
   SUBROUTINE assignMe(self, input)
      CLASS(Inner), INTENT(INOUT)      ::  self
      CLASS(Inner), INTENT(IN)      ::  input
         self%icount => input%icount
         self%icount=self%icount+1
   END SUBROUTINE


END MODULE

PROGRAM test

   USE Classes

IMPLICIT NONE

WRITE(*,*)"Direct Call on inner performs only 2 FINALIZATIONS"
   BLOCK
      TYPE(Inner)      :: inner1, inner2
      CALL inner1%init()
      inner2=inner1
   END BLOCK
WRITE(*,*)
WRITE(*,*)"Indirect Call, 3 FINALIZATIONS, last with dangling pointer on
TYPE(inner)%icount"
   BLOCK
      TYPE(Outer)          :: Outer1, Outer2
      CALL Outer1%ext%init()
      Outer2=Outer1
   END BLOCK 
END 

!========================= END TEST CODE ================================


 Note: in Final comparison is for <= 0 to cause double free

best regards
Flo