gcc/testsuite/gfortran.dg/transfer_simplify_2.f90

   1 ! { dg-do run }
   2 ! { dg-options "-O2" }
   3 ! { dg-add-options ieee }
   4 ! Tests the fix for the meta-bug PR31237 (TRANSFER intrinsic)
   5 ! Exercises gfc_simplify_transfer a random walk through types and shapes
   6 ! and compares its results with the middle-end version that operates on
   7 ! variables.
   8 !
   9   implicit none
  10   call integer4_to_real4
  11   call real4_to_integer8
  12   call integer4_to_integer8
  13   call logical4_to_real8
  14   call real8_to_integer4
  15   call integer8_to_real4
  16   call integer8_to_complex4
  17   call character16_to_complex8
  18   call character16_to_real8
  19   call real8_to_character2
  20   call dt_to_integer1
  21   call character16_to_dt
  22 contains
  23   subroutine integer4_to_real4
  24     integer(4), parameter ::  i1 = 11111_4
  25     integer(4)            ::  i2 = i1
  26     real(4), parameter    ::  r1 = transfer (i1, 1.0_4)
  27     real(4)               ::  r2
  28
  29     r2 = transfer (i2, r2);
  30     if (r1 .ne. r2) call abort ()
  31   end subroutine integer4_to_real4
  32
  33   subroutine real4_to_integer8
  34     real(4), parameter    ::  r1(2) = (/3.14159_4, 0.0_4/)
  35     real(4)               ::  r2(2) = r1
  36     integer(8), parameter ::  i1 = transfer (r1, 1_8)
  37     integer(8)            ::  i2
  38
  39     i2 = transfer (r2, 1_8);
  40     if (i1 .ne. i2) call abort ()
  41   end subroutine real4_to_integer8
  42
  43   subroutine integer4_to_integer8
  44     integer(4), parameter ::  i1(2) = (/11111_4, 22222_4/)
  45     integer(4)            ::  i2(2) = i1
  46     integer(8), parameter ::  i3 = transfer (i1, 1_8)
  47     integer(8)            ::  i4
  48
  49     i4 = transfer (i2, 1_8);
  50     if (i3 .ne. i4) call abort ()
  51   end subroutine integer4_to_integer8
  52
  53   subroutine logical4_to_real8
  54     logical(4), parameter ::  l1(2) = (/.false., .true./)
  55     logical(4)            ::  l2(2) = l1
  56     real(8), parameter    ::  r1 = transfer (l1, 1_8)
  57     real(8)               ::  r2
  58
  59     r2 = transfer (l2, 1_8);
  60     if (r1 .ne. r2) call abort ()
  61   end subroutine logical4_to_real8
  62
  63   subroutine real8_to_integer4
  64     real(8), parameter    ::  r1 = 3.14159_8
  65     real(8)               ::  r2 = r1
  66     integer(4), parameter ::  i1(2) = transfer (r1, 1_4, 2)
  67     integer(4)            ::  i2(2)
  68
  69     i2 = transfer (r2, i2, 2);
  70     if (any (i1 .ne. i2)) call abort ()
  71   end subroutine real8_to_integer4
  72
  73   subroutine integer8_to_real4
  74     integer               ::  k
  75     integer(8), parameter ::  i1(2) = transfer ((/asin (1.0_8), log (1.0_8)/), 0_8)
  76     integer(8)            ::  i2(2) = i1
  77     real(4), parameter    ::  r1(4) = transfer (i1, (/(1.0_4,k=1,4)/))
  78     real(4)               ::  r2(4)
  79
  80     r2 = transfer (i2, r2);
  81     if (any (r1 .ne. r2)) call abort ()
  82   end subroutine integer8_to_real4
  83
  84   subroutine integer8_to_complex4
  85     integer               ::  k
  86     integer(8), parameter ::  i1(2) = transfer ((/asin (1.0_8), log (1.0_8)/), 0_8)
  87     integer(8)            ::  i2(2) = i1
  88     complex(4), parameter ::  z1(2) = transfer (i1, (/((1.0_4,2.0_4),k=1,2)/))
  89     complex(4)            ::  z2(2)
  90
  91     z2 = transfer (i2, z2);
  92     if (any (z1 .ne. z2)) call abort ()
  93   end subroutine integer8_to_complex4
  94
  95   subroutine character16_to_complex8
  96     character(16), parameter ::  c1(2) = (/"abcdefghijklmnop","qrstuvwxyz123456"/)
  97     character(16)            ::  c2(2) = c1
  98     complex(8), parameter    ::  z1(2) = transfer (c1, (1.0_8,1.0_8), 2)
  99     complex(8)               ::  z2(2)
 100
 101     z2 = transfer (c2, z2, 2);
 102     if (any (z1 .ne. z2)) call abort ()
 103   end subroutine character16_to_complex8
 104
 105   subroutine character16_to_real8
 106     character(16), parameter ::  c1 = "abcdefghijklmnop"
 107     character(16)            ::  c2 = c1
 108     real(8), parameter    ::  r1(2) = transfer (c1, 1.0_8, 2)
 109     real(8)               ::  r2(2)
 110
 111     r2 = transfer (c2, r2, 2);
 112     if (any (r1 .ne. r2)) call abort ()
 113   end subroutine character16_to_real8
 114
 115   subroutine real8_to_character2
 116     real(8), parameter    ::  r1 = 3.14159_8
 117     real(8)               ::  r2 = r1
 118     character(2), parameter ::  c1(4) = transfer (r1, "ab", 4)
 119     character(2)            ::  c2(4)
 120
 121     c2 = transfer (r2, "ab", 4);
 122     if (any (c1 .ne. c2)) call abort ()
 123   end subroutine real8_to_character2
 124
 125   subroutine dt_to_integer1
 126     integer, parameter    :: i1(4) = (/1_4,2_4,3_4,4_4/)
 127     real, parameter       :: r1(4) = (/1.0_4,2.0_4,3.0_4,4.0_4/)
 128     type :: mytype
 129       integer(4) :: i(4)
 130       real(4) :: x(4)
 131     end type mytype
 132     type (mytype), parameter :: dt1 = mytype (i1, r1)
 133     type (mytype)            :: dt2 = dt1
 134     integer(1), parameter :: i2(32) = transfer (dt1, 1_1, 32)
 135     integer(1)            :: i3(32)
 136
 137     i3 = transfer (dt2, 1_1, 32);
 138     if (any (i2 .ne. i3)) call abort ()
 139   end subroutine dt_to_integer1
 140
 141   subroutine character16_to_dt
 142     character(16), parameter ::  c1 = "abcdefghijklmnop"
 143     character(16)            ::  c2 = c1
 144     type :: mytype
 145       real(4) :: x(2)
 146     end type mytype
 147
 148     type (mytype), parameter :: dt1(2) = transfer (c1, mytype ((/1.0,2.0,3.0,4.0/)), 2)
 149     type (mytype)            :: dt2(2)
 150
 151     dt2 = transfer (c2, dt2);
 152     if (any (dt1(1)%x .ne. dt2(1)%x)) call abort ()
 153     if (any (dt1(2)%x .ne. dt2(2)%x)) call abort ()
 154   end subroutine character16_to_dt
 155
 156 end