https://gcc.gnu.org/bugzilla/show_bug.cgi?id=125428
Bug ID: 125428
Summary: Finalization in an assignment drops some
initialization code
Product: gcc
Version: 17.0
Status: UNCONFIRMED
Severity: normal
Priority: P3
Component: fortran
Assignee: unassigned at gcc dot gnu.org
Reporter: mikael at gcc dot gnu.org
Target Milestone: ---
Taken from pr125391#17
Tested with gfortran-15.2 and recent master (17.0). The variable used in the
finalization guard at the beginning of save_val is not initialized.
$ gfortran -static y.f90 -o y
$ ./y
Program received signal SIGSEGV: Segmentation fault - invalid memory reference.
Backtrace for this error:
(... blah blah ...)
$ cat y.f90
module m
implicit none
type :: inner
integer :: x = 0
contains
final :: inner_final
end type
type :: outer
type(inner), allocatable :: item
logical :: available
end type
interface outer
module procedure :: constructor_outer
end interface
contains
subroutine inner_final(this)
type(inner), intent(inout) :: this
end subroutine
subroutine save_val(o, i)
class(outer), intent(inout) :: o(:)
type(inner), intent(in) :: i
o(pick_first(o%available, size(o)))%item = i
end subroutine
function pick_first(a, n) result(r)
integer, intent(in) :: n
logical, intent(inout) :: a(n)
integer :: r
r = findloc(a, .true., dim=1)
a(r) = .false.
end function
function constructor_outer() result(r)
type(outer) :: r
allocate(r%item)
r%available = .true.
end function
end module
program p
use m
implicit none
type(outer), allocatable :: x(:)
integer :: failures = 0
allocate(x(5), source = outer())
call save_val(x, inner(-1))
print *, x(1)%available
print *, x(2)%available
if (x(1)%available) then
call add_failure(failures, 1)
else
print *, x(1)%item%x
end if
if (.not. x(2)%available) then
print *, x(2)%item%x
call add_failure(failures, 2)
end if
if (x(1)%item%x /= -1) call add_failure(failures, 4)
if (failures /= 0) error stop failures
contains
subroutine add_failure(var, val)
integer, intent(inout) :: var
integer, intent(in) :: val
var = ior(var, val)
end subroutine
end program
