gcc/testsuite/gfortran.dg/transfer_simplify_1.f90

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