| 1 |
694 |
jeremybenn |
! { 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
|
