https://gcc.gnu.org/bugzilla/show_bug.cgi?id=93924
--- Comment #10 from Paul Thomas <pault at gcc dot gnu.org> ---
(In reply to Paul Thomas from comment #9)
> Created attachment 50057 [details]
> Patch that "fixes" all versions of the problem
>
> The attached patch has a fragment of my finalize on assignment patch in the
> second chunk. The changes are small and few so could be applied manually.
>
> Whatever is the legality or otherwise, this fixes all versions of the
> problem and regtests OK.
>
> Please do what you will with this. If it is still open in a few weeks time,
> I will take it. At the present, I have too many open PRs.
>
> Paul
Final remarks for the time being in comments below:
module cs
implicit none
private
public classStar_map_ifc
public apply, selector
integer, target :: integer_target
abstract interface
function classStar_map_ifc(x) result(y)
class(*), pointer :: y
class(*), target, intent(in) :: x
end function classStar_map_ifc
end interface
contains
function fun(x) result(y)
class(*), pointer :: y
class(*), target, intent(in) :: x
select type (x)
type is (integer)
integer_target = x ! One way of overcoming dangling target business
y => integer_target
class default
y => null()
end select
end function fun
function apply(f, x) result(y)
procedure(classStar_map_ifc) :: f
integer, intent(in) :: x
integer :: y
class(*), pointer :: p
y = 0 ! Get rid of 'y' undefined warning
p => f(x)
select type (p)
type is (integer)
y = p
end select
end function apply
function selector() result(f)
procedure(classStar_map_ifc), pointer :: f
f => fun
end function selector
end module cs
program classStar_map
use cs
implicit none
integer :: x, y
procedure(classStar_map_ifc), pointer :: f
x = 123654
f => selector() ! Fixed by second chunk in patch (suppresses
class assignment)
y = apply(f, x) ! Fixed by first chunk in patch (passing
procedure)
print *, x, y
end program classStar_map
