URL
https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk
Subversion Repositories openrisc_me
[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [gfortran.dg/] [where_operator_assign_1.f90] - Rev 414
Go to most recent revision | Compare with Previous | Blame | View Log
! { dg-do compile }
! Tests the fix for PR30407, in which operator assignments did not work
! in WHERE blocks or simple WHERE statements. This is the test provided
! by the reporter.
!
! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
!==============================================================================
MODULE kind_mod
IMPLICIT NONE
PRIVATE
INTEGER, PUBLIC, PARAMETER :: I4=SELECTED_INT_KIND(9)
INTEGER, PUBLIC, PARAMETER :: TF=KIND(.TRUE._I4)
END MODULE kind_mod
!==============================================================================
MODULE pointer_mod
USE kind_mod, ONLY : I4
IMPLICIT NONE
PRIVATE
TYPE, PUBLIC :: pvt
INTEGER(I4), POINTER, DIMENSION(:) :: vect
END TYPE pvt
INTERFACE ASSIGNMENT(=)
MODULE PROCEDURE p_to_p
END INTERFACE
PUBLIC :: ASSIGNMENT(=)
CONTAINS
!---------------------------------------------------------------------------
PURE ELEMENTAL SUBROUTINE p_to_p(a1, a2)
IMPLICIT NONE
TYPE(pvt), INTENT(OUT) :: a1
TYPE(pvt), INTENT(IN) :: a2
a1%vect = a2%vect
END SUBROUTINE p_to_p
!---------------------------------------------------------------------------
END MODULE pointer_mod
!==============================================================================
PROGRAM test_prog
USE pointer_mod, ONLY : pvt, ASSIGNMENT(=)
USE kind_mod, ONLY : I4, TF
IMPLICIT NONE
INTEGER(I4), DIMENSION(12_I4), TARGET :: ia
LOGICAL(TF), DIMENSION(2_I4,3_I4) :: la
TYPE(pvt), DIMENSION(6_I4) :: pv
INTEGER(I4) :: i
! Initialisation...
la(:,1_I4:3_I4:2_I4)=.TRUE._TF
la(:,2_I4)=.FALSE._TF
DO i=1_I4,6_I4
pv(i)%vect => ia((2_I4*i-1_I4):(2_I4*i))
END DO
ia=0_I4
DO i=1_I4,3_I4
WHERE(la((/1_I4,2_I4/),i))
pv((2_I4*i-1_I4):(2_I4*i))= iaef((/(2_I4*i-1_I4),(2_I4*i)/))
ELSEWHERE
pv((2_I4*i-1_I4):(2_I4*i))= iaef((/0_I4,0_I4/))
END WHERE
END DO
if (any (ia .ne. (/1,-1,2,-2,0,0,0,0,5,-5,6,-6/))) call abort ()
CONTAINS
TYPE(pvt) ELEMENTAL FUNCTION iaef(index) RESULT(ans)
USE kind_mod, ONLY : I4
USE pointer_mod, ONLY : pvt, ASSIGNMENT(=)
IMPLICIT NONE
INTEGER(I4), INTENT(IN) :: index
ALLOCATE(ans%vect(2_I4))
ans%vect=(/index,-index/)
END FUNCTION iaef
END PROGRAM test_prog
! { dg-final { cleanup-modules "kind_mod pointer_mod" } }
Go to most recent revision | Compare with Previous | Blame | View Log