3 ! Tests the fix for the meta-bug PR31237 (TRANSFER intrinsic)
4 ! Exercises gfc_simplify_transfer a random walk through types and shapes
5 ! and compares its results with the middle-end version that operates on
10 call real4_to_integer8
11 call integer4_to_integer8
12 call logical4_to_real8
13 call real8_to_integer4
14 call integer8_to_real4
15 call integer8_to_complex4
16 call character16_to_complex8
17 call character16_to_real8
18 call real8_to_character2
20 call character16_to_dt
22 subroutine integer4_to_real4
23 integer(4), parameter :: i1 = 11111_4
25 real(4), parameter :: r1 = transfer (i1, 1.0_4)
28 r2 = transfer (i2, r2);
29 if (r1 .ne. r2) call abort ()
30 end subroutine integer4_to_real4
32 subroutine real4_to_integer8
33 real(4), parameter :: r1(2) = (/3.14159_4, 0.0_4/)
35 integer(8), parameter :: i1 = transfer (r1, 1_8)
38 i2 = transfer (r2, 1_8);
39 if (i1 .ne. i2) call abort ()
40 end subroutine real4_to_integer8
42 subroutine integer4_to_integer8
43 integer(4), parameter :: i1(2) = (/11111_4, 22222_4/)
44 integer(4) :: i2(2) = i1
45 integer(8), parameter :: i3 = transfer (i1, 1_8)
48 i4 = transfer (i2, 1_8);
49 if (i3 .ne. i4) call abort ()
50 end subroutine integer4_to_integer8
52 subroutine logical4_to_real8
53 logical(4), parameter :: l1(2) = (/.false., .true./)
54 logical(4) :: l2(2) = l1
55 real(8), parameter :: r1 = transfer (l1, 1_8)
58 r2 = transfer (l2, 1_8);
59 if (r1 .ne. r2) call abort ()
60 end subroutine logical4_to_real8
62 subroutine real8_to_integer4
63 real(8), parameter :: r1 = 3.14159_8
65 integer(4), parameter :: i1(2) = transfer (r1, 1_4, 2)
68 i2 = transfer (r2, i2, 2);
69 if (any (i1 .ne. i2)) call abort ()
70 end subroutine real8_to_integer4
72 subroutine integer8_to_real4
74 integer(8), parameter :: i1(2) = transfer ((/asin (1.0_8), log (1.0_8)/), 0_8)
75 integer(8) :: i2(2) = i1
76 real(4), parameter :: r1(4) = transfer (i1, (/(1.0_4,k=1,4)/))
79 r2 = transfer (i2, r2);
80 if (any (r1 .ne. r2)) call abort ()
81 end subroutine integer8_to_real4
83 subroutine integer8_to_complex4
85 integer(8), parameter :: i1(2) = transfer ((/asin (1.0_8), log (1.0_8)/), 0_8)
86 integer(8) :: i2(2) = i1
87 complex(4), parameter :: z1(2) = transfer (i1, (/((1.0_4,2.0_4),k=1,2)/))
90 z2 = transfer (i2, z2);
91 if (any (z1 .ne. z2)) call abort ()
92 end subroutine integer8_to_complex4
94 subroutine character16_to_complex8
95 character(16), parameter :: c1(2) = (/"abcdefghijklmnop","qrstuvwxyz1234567890"/)
96 character(16) :: c2(2) = c1
97 complex(8), parameter :: z1(2) = transfer (c1, (1.0_8,1.0_8), 2)
100 z2 = transfer (c2, z2, 2);
101 if (any (z1 .ne. z2)) call abort ()
102 end subroutine character16_to_complex8
104 subroutine character16_to_real8
105 character(16), parameter :: c1 = "abcdefghijklmnop"
106 character(16) :: c2 = c1
107 real(8), parameter :: r1(2) = transfer (c1, 1.0_8, 2)
110 r2 = transfer (c2, r2, 2);
111 if (any (r1 .ne. r2)) call abort ()
112 end subroutine character16_to_real8
114 subroutine real8_to_character2
115 real(8), parameter :: r1 = 3.14159_8
117 character(2), parameter :: c1(4) = transfer (r1, "ab", 4)
118 character(2) :: c2(4)
120 c2 = transfer (r2, "ab", 4);
121 if (any (c1 .ne. c2)) call abort ()
122 end subroutine real8_to_character2
124 subroutine dt_to_integer1
125 integer, parameter :: i1(4) = (/1_4,2_4,3_4,4_4/)
126 real, parameter :: r1(4) = (/1.0_4,2.0_4,3.0_4,4.0_4/)
131 type (mytype), parameter :: dt1 = mytype (i1, r1)
132 type (mytype) :: dt2 = dt1
133 integer(1), parameter :: i2(32) = transfer (dt1, 1_1, 32)
136 i3 = transfer (dt2, 1_1, 32);
137 if (any (i2 .ne. i3)) call abort ()
138 end subroutine dt_to_integer1
140 subroutine character16_to_dt
141 character(16), parameter :: c1 = "abcdefghijklmnop"
142 character(16) :: c2 = c1
147 type (mytype), parameter :: dt1(2) = transfer (c1, mytype ((/1.0,2.0,3.0,4.0/)), 2)
148 type (mytype) :: dt2(2)
150 dt2 = transfer (c2, dt2);
151 if (any (dt1(1)%x .ne. dt2(1)%x)) call abort ()
152 if (any (dt1(2)%x .ne. dt2(2)%x)) call abort ()
153 end subroutine character16_to_dt