gcc/testsuite/gfortran.dg/transfer_simplify_1.f90

   1 ! { dg-do run }
   2 ! { dg-options "-O2" }
   3 ! { dg-skip-if "NaN not supported" { spu-*-* } { "*" } { "" } }
   4 ! Tests that the PRs caused by the lack of gfc_simplify_transfer are
   5 ! now fixed. These were brought together in the meta-bug PR31237
   6 ! (TRANSFER intrinsic).
   7 ! Remaining PRs on 20070409 :-18769 30881 31194 31216 31424 31427
   8 !
   9 program simplify_transfer
  10   CHARACTER(LEN=100) :: buffer="1.0 3.0"
  11   call pr18769 ()
  12   call pr30881 ()
  13   call pr31194 ()
  14   call pr31216 ()
  15   call pr31427 ()
  16 contains
  17   subroutine pr18769 ()
  18 !
  19 ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
  20 !
  21     implicit none
  22     type t
  23        integer :: i
  24     end type t
  25     type (t), parameter :: u = t (42)
  26     integer,  parameter :: idx_list(1) = (/ 1 /)
  27     integer             :: j(1) = transfer (u,  idx_list)
  28     if (j(1) .ne. 42) call abort ()
  29   end subroutine pr18769
  30
  31   subroutine pr30881 ()
  32 !
  33 ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
  34 !
  35     INTEGER, PARAMETER :: K=1
  36     INTEGER ::  I
  37     I=TRANSFER(.TRUE.,K)
  38     SELECT CASE(I)
  39       CASE(TRANSFER(.TRUE.,K))
  40       CASE(TRANSFER(.FALSE.,K))
  41         CALL ABORT()
  42       CASE DEFAULT
  43         CALL ABORT()
  44     END SELECT
  45     I=TRANSFER(.FALSE.,K)
  46     SELECT CASE(I)
  47       CASE(TRANSFER(.TRUE.,K))
  48         CALL ABORT()
  49       CASE(TRANSFER(.FALSE.,K))
  50       CASE DEFAULT
  51       CALL ABORT()
  52     END SELECT
  53   END subroutine pr30881
  54
  55   subroutine pr31194 ()
  56 !
  57 ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
  58 !
  59     real(kind(0d0)) :: NaN = transfer(ishft(int(z'FFF80000',8),32),0d0)
  60     write (buffer,'(e12.5)') NaN
  61     if (buffer(10:12) .ne. "NaN") call abort ()
  62   end subroutine pr31194
  63
  64   subroutine pr31216 ()
  65 !
  66 ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
  67 !
  68     INTEGER :: I
  69     REAL :: C,D
  70     buffer = "  1.0  3.0"
  71     READ(buffer,*) C,D
  72     I=TRANSFER(C/D,I)
  73     SELECT CASE(I)
  74       CASE (TRANSFER(1.0/3.0,1))
  75       CASE DEFAULT
  76         CALL ABORT()
  77     END SELECT
  78   END subroutine pr31216
  79
  80   subroutine pr31427 ()
  81 !
  82 ! Contributed by Michael Richmond <michael.a.richmond@nasa.gov>
  83 !
  84     INTEGER(KIND=1) :: i(1)
  85     i = (/ TRANSFER("a", 0_1) /)
  86     if (i(1) .ne. ichar ("a")) call abort ()
  87   END subroutine pr31427
  88 end program simplify_transfer