gcc/testsuite/gfortran.dg/temporary_3.f90

   1 ! { dg-do run }
   2 ! { dg-require-visibility "" }
   3 !
   4 ! Tests the fix for PR68846 in which compiler generated temporaries were
   5 ! receiving the attributes of dummy arguments. This test is the original.
   6 ! The simplified versions by Gerhard Steinmetz are gratefully acknowledged.
   7 !
   8 ! Contributed by Mirco Valentini  <mirco.valentini@polimi.it>
   9 !
  10 MODULE grid
  11   IMPLICIT NONE
  12   PRIVATE
  13   REAL(KIND=8), DIMENSION(100,100), TARGET :: WORKSPACE
  14   TYPE, PUBLIC :: grid_t
  15     REAL(KIND=8), DIMENSION(:,:), POINTER :: P => NULL ()
  16   END TYPE
  17   PUBLIC :: INIT
  18 CONTAINS
  19   SUBROUTINE INIT (DAT)
  20     IMPLICIT NONE
  21     TYPE(grid_t), INTENT(INOUT) :: DAT
  22     INTEGER :: I, J
  23     DAT%P => WORKSPACE
  24     DO I = 1, 100
  25       DO J = 1, 100
  26         DAT%P(I,J) = REAL ((I-1)*100+J-1)
  27       END DO
  28     ENDDO
  29   END SUBROUTINE INIT
  30 END MODULE grid
  31
  32 MODULE subgrid
  33   USE :: grid, ONLY: grid_t
  34   IMPLICIT NONE
  35   PRIVATE
  36   TYPE, PUBLIC :: subgrid_t
  37     INTEGER, DIMENSION(4) :: range
  38     CLASS(grid_t), POINTER    :: grd => NULL ()
  39   CONTAINS
  40     PROCEDURE, PASS :: INIT => LVALUE_INIT
  41     PROCEDURE, PASS :: JMP => LVALUE_JMP
  42   END TYPE
  43 CONTAINS
  44   SUBROUTINE LVALUE_INIT (HOBJ, P, D)
  45     IMPLICIT NONE
  46     CLASS(subgrid_t),      INTENT(INOUT) :: HOBJ
  47     TYPE(grid_t), POINTER, INTENT(INOUT) :: P
  48     INTEGER, DIMENSION(4), INTENT(IN)    :: D
  49     HOBJ%range = D
  50     HOBJ%grd => P
  51   END SUBROUTINE LVALUE_INIT
  52
  53   FUNCTION LVALUE_JMP(HOBJ, I, J) RESULT(P)
  54     IMPLICIT NONE
  55     CLASS(subgrid_t), INTENT(INOUT) :: HOBJ
  56     INTEGER, INTENT(IN) :: I, J
  57     REAL(KIND=8), POINTER :: P
  58     P => HOBJ%grd%P(HOBJ%range(1)+I-1, HOBJ%range(3)+J-1)
  59   END FUNCTION LVALUE_JMP
  60 END MODULE subgrid
  61
  62 MODULE geom
  63   IMPLICIT NONE
  64 CONTAINS
  65   SUBROUTINE fillgeom_03( subgrid, value  )
  66     USE :: subgrid, ONLY: subgrid_t
  67     IMPLICIT NONE
  68     TYPE(subgrid_T), intent(inout) :: subgrid
  69     REAL(kind=8),    intent(in) :: value
  70     INTEGER :: I, J
  71     DO i = 1, 3
  72       DO J = 1, 4
  73         subgrid%jmp(i,j) = value ! Dummy argument '_F.DA0' with INTENT(IN)
  74                                  ! in pointer association context or ICE
  75                                  ! in trans_decl.c, depending on INTENT of
  76                                  ! 'VALUE'
  77       ENDDO
  78     ENDDO
  79   END SUBROUTINE fillgeom_03
  80 END MODULE geom
  81
  82 PROGRAM test_lvalue
  83   USE :: grid
  84   USE :: subgrid
  85   USE :: geom
  86   IMPLICIT NONE
  87   TYPE(grid_t), POINTER :: GRD => NULL()
  88   TYPE(subgrid_t) :: STENCIL
  89   REAL(KIND=8), POINTER :: real_tmp_ptr
  90   REAL(KIND=8), DIMENSION(10,10), TARGET :: AA
  91   REAL(KIND=8), DIMENSION(3,4) :: VAL
  92   INTEGER :: I, J, chksum
  93   integer, parameter :: r1 = 50
  94   integer, parameter :: r2 = 52
  95   integer, parameter :: r3 = 50
  96   integer, parameter :: r4 = 53
  97   DO I = 1, 3
  98     DO J = 1, 4
  99       VAL(I,J) = dble(I)*dble(J)
 100     ENDDO
 101   ENDDO
 102
 103   ALLOCATE (GRD)
 104   CALL INIT (GRD)
 105   chksum = sum([([((i-1)*100 + j -1, j=1,100)], i = 1,100)])
 106   if (int(sum(grd%p)) .ne. chksum) stop 1
 107
 108   CALL STENCIL%INIT (GRD, [r1, r2, r3, r4])
 109   if (.not.associated (stencil%grd, grd)) stop 2
 110   if (int(sum(grd%p)) .ne. chksum) stop 3
 111
 112   CALL fillgeom_03(stencil, 42.0_8)
 113   if (any (int (grd%p(r1:r2,r3:r4)) .ne. 42)) stop 4
 114
 115   chksum = chksum - sum([([((i - 1) * 100 + j -1, j=r3,r4)], i = r1,r2)]) &
 116            + (r4 - r3 + 1) * (r2 - r1 +1) * 42
 117   if (int(sum(grd%p)) .ne. chksum) stop 5
 118
 119   deallocate (grd)
 120 END PROGRAM test_lvalue
 121
 122