gcc/testsuite/gfortran.dg/associated_target_7.f90

   1 ! { dg-do run }
   2 !
   3 ! associated_target_7.f90: Test the fix for PR98565.
   4 !
   5 ! Contributed by Yves Secretan  <yves.secretan@ete.inrs.ca>
   6 !
   7 MODULE PS_SN0N_M
   8
   9    IMPLICIT NONE
  10    PRIVATE
  11
  12    TYPE, PUBLIC :: DT_GRID_T
  13        INTEGER :: NNT
  14    CONTAINS
  15        ! PASS
  16    END TYPE DT_GRID_T
  17
  18    TYPE, PUBLIC :: LM_ELEM_T
  19        CLASS(DT_GRID_T), POINTER :: PGRID
  20    CONTAINS
  21        PROCEDURE, PUBLIC :: REQPGRID => LM_ELEM_REGPGRID
  22    END TYPE LM_ELEM_T
  23
  24    TYPE, PUBLIC :: PS_SN0N_T
  25       CLASS(DT_GRID_T), POINTER :: PGRID
  26
  27    CONTAINS
  28       PROCEDURE, PUBLIC :: ASGOELE  => PS_SN0N_ASGOELE
  29    END TYPE PS_SN0N_T
  30
  31
  32 CONTAINS
  33    !------------------------------------------------------------------------
  34    !------------------------------------------------------------------------
  35    FUNCTION LM_ELEM_REGPGRID(SELF) RESULT(PGRID)
  36    CLASS(DT_GRID_T), POINTER :: PGRID
  37    CLASS(LM_ELEM_T), INTENT(IN) :: SELF
  38    PGRID => SELF%PGRID
  39    RETURN
  40    END FUNCTION LM_ELEM_REGPGRID
  41
  42    !------------------------------------------------------------------------
  43    !------------------------------------------------------------------------
  44    FUNCTION PS_SN0N_ASGOELE(SELF, OELE) RESULT(ERMSG)
  45
  46    INTEGER :: ERMSG
  47    CLASS(PS_SN0N_T), INTENT(IN) :: SELF
  48    CLASS(LM_ELEM_T), INTENT(IN) :: OELE
  49
  50    !CLASS(DT_GRID_T), POINTER :: PGRID
  51    LOGICAL :: ISOK
  52    !------------------------------------------------------------------------
  53
  54    ! ASSOCIATED with temp variable compiles
  55    !PGRID => OELE%REQPGRID()
  56    !ISOK = ASSOCIATED(SELF%PGRID, PGRID)
  57
  58    ! ASSOCIATE without temp variable crashes with ICE
  59    ISOK = ASSOCIATED(SELF%PGRID, OELE%REQPGRID())
  60    ERMSG = 0
  61    IF (ISOK) ERMSG = 1
  62
  63    RETURN
  64    END FUNCTION PS_SN0N_ASGOELE
  65
  66 END MODULE PS_SN0N_M
  67
  68
  69    USE PS_SN0N_M
  70    CLASS(PS_SN0N_T), ALLOCATABLE :: SELF
  71    CLASS(LM_ELEM_T), ALLOCATABLE :: OELE
  72    TYPE (DT_GRID_T), TARGET :: GRID1 = DT_GRID_T (42)
  73    TYPE (DT_GRID_T), TARGET :: GRID2 = DT_GRID_T (84)
  74
  75    ALLOCATE (PS_SN0N_T :: SELF)
  76    ALLOCATE (LM_ELEM_T :: OELE)
  77    SELF%PGRID => GRID1
  78
  79    OELE%PGRID => NULL ()
  80    IF (SELF%ASGOELE (OELE) .NE. 0) STOP 1
  81
  82    OELE%PGRID => GRID2
  83    IF (SELF%ASGOELE (OELE) .NE. 0) STOP 2
  84
  85    OELE%PGRID => GRID1
  86    IF (SELF%ASGOELE (OELE) .NE. 1) STOP 3
  87 END