[Bug fortran/63921] [F08] pointer function as lvalue doesn't work when the function is a type bound function

[pault at gcc dot gnu.org]

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

Paul Thomas <pault at gcc dot gnu.org> changed:

           What    |Removed                     |Added
----------------------------------------------------------------------------
                 CC|                            |pault at gcc dot gnu.org

--- Comment #4 from Paul Thomas <pault at gcc dot gnu.org> ---
(In reply to Dominique d'Humieres from comment #3)
> Reset the importance to normal: as for today there are 854 open PRs and
> several hundreds of them are more or as 'critical' than this one.
> 
> If this PR is really critical for you, you should consider to fix it
> yourself (or hire someone to do it for you).

Dear Mirco,

You will be happy to know that I have a patch for pointer function assignment,
which fixes your problem. It will be submitted tomorrow.

Dominique tested the patch today and recalled your problem report. I have
recast your testcase and it appears below. I might not use this in the
testsuite since it largely duplicates the one that I had written. However, the
line  STENCIL%JMP (1, 1 ) = 10.0d0 + STENCIL%JMP (1, 1 ) is neat and I will
probably add something like it together with an attribution to you.

Dominique also reminded me that PR40054 covers this missing feature from
gfortran.

Thanks for the report.

Paul

! { dg-do run }
!
! Testcase for pointer function assignment from PR63921
! Contributed by Mirco Valentini  <mirco.valent...@polimi.it>
!
MODULE grid
  IMPLICIT NONE
  PRIVATE
  REAL(KIND=8), DIMENSION(100,100), TARGET :: WORKSPACE
  TYPE, PUBLIC :: grid_t
    REAL(KIND=8), DIMENSION(:,:), POINTER :: P => NULL ()
  END TYPE
  PUBLIC :: INIT
CONTAINS
  SUBROUTINE INIT( DAT )
    IMPLICIT NONE
    TYPE(grid_t), INTENT(INOUT) :: DAT
    INTEGER :: I, J
    DAT%P => WORKSPACE
    DO I = 1, 100
      DO J = 1, 100
        DAT%P(I,J) = REAL ((I - 1)*100 + J - 1 )
      END DO
    ENDDO
 END SUBROUTINE INIT
END MODULE grid

MODULE subgrid
  USE :: grid, ONLY: grid_t
  IMPLICIT NONE
  PRIVATE
  TYPE, PUBLIC :: subgrid_t
    INTEGER, DIMENSION(4) :: range
    CLASS(grid_t), POINTER    :: grd => NULL ()
  CONTAINS
    PROCEDURE, PASS :: INIT => LVALUE_INIT
    PROCEDURE, PASS :: JMP => LVALUE_JMP
  END TYPE
CONTAINS
  SUBROUTINE LVALUE_INIT(HOBJ, P, D  )
    IMPLICIT NONE
    CLASS(subgrid_t), INTENT(INOUT) :: HOBJ
    TYPE(grid_t), POINTER, INTENT(IN)    :: P
    INTEGER, DIMENSION(4),   INTENT(IN)    :: D
    HOBJ%range = D
    HOBJ%grd => P
  END SUBROUTINE LVALUE_INIT

  FUNCTION LVALUE_JMP(HOBJ, I, J ) RESULT(P)
    IMPLICIT NONE
    CLASS(subgrid_t), INTENT(INOUT) :: HOBJ
    INTEGER, INTENT(IN) :: I, J
    REAL(KIND=8), POINTER :: P
    P => HOBJ%grd%P( HOBJ%range(1) + I - 1, HOBJ%range(3) + J - 1 )
  END FUNCTION LVALUE_JMP
END MODULE subgrid

PROGRAM test_lvalue
  USE :: grid
  USE :: subgrid
  IMPLICIT NONE
  TYPE(grid_t), POINTER :: GRID
  TYPE(subgrid_t) :: STENCIL
  REAL(KIND=8), POINTER :: real_tmp_ptr
  REAL(KIND=8) :: old_val
  ALLOCATE (GRID)
  CALL INIT (GRID)
  CALL STENCIL%INIT (GRID, [50, 52, 50, 53 ])
  old_val = STENCIL%JMP (1, 1 )

  ! Workaround
  !real_tmp_ptr => STENCIL%JMP( 1, 1 )
  !real_tmp_ptr = 10.0d0 + STENCIL%JMP( 1, 1 )

  ! This failed
  STENCIL%JMP (1, 1 ) = 10.0d0 + STENCIL%JMP (1, 1 )
  if (STENCIL%JMP (1, 1 ) .ne. old_val + 10.0d0) call abort
END PROGRAM test_lvalue