Commit | Line | Data |
ddb9d9dc |
1 | #!./perl |
2 | |
3 | # |
55497cff |
4 | # test the bit operators '&', '|', '^', '~', '<<', and '>>' |
ddb9d9dc |
5 | # |
6 | |
d1f8c7a4 |
7 | BEGIN { |
8 | chdir 't' if -d 't'; |
20822f61 |
9 | @INC = '../lib'; |
add36b05 |
10 | require "./test.pl"; |
d1f8c7a4 |
11 | } |
12 | |
add36b05 |
13 | # Tests don't have names yet. |
14 | # If you find tests are failing, please try adding names to tests to track |
15 | # down where the failure is, and supply your new names as a patch. |
16 | # (Just-in-time test naming) |
17 | plan tests => 145; |
ddb9d9dc |
18 | |
19 | # numerics |
add36b05 |
20 | ok ((0xdead & 0xbeef) == 0x9ead); |
21 | ok ((0xdead | 0xbeef) == 0xfeef); |
22 | ok ((0xdead ^ 0xbeef) == 0x6042); |
23 | ok ((~0xdead & 0xbeef) == 0x2042); |
55497cff |
24 | |
25 | # shifts |
add36b05 |
26 | ok ((257 << 7) == 32896); |
27 | ok ((33023 >> 7) == 257); |
55497cff |
28 | |
29 | # signed vs. unsigned |
add36b05 |
30 | ok ((~0 > 0 && do { use integer; ~0 } == -1)); |
d1f8c7a4 |
31 | |
32 | my $bits = 0; |
33 | for (my $i = ~0; $i; $i >>= 1) { ++$bits; } |
34 | my $cusp = 1 << ($bits - 1); |
35 | |
add36b05 |
36 | |
37 | ok (($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0); |
38 | ok (($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0); |
39 | ok (($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0); |
40 | ok ((1 << ($bits - 1)) == $cusp && |
41 | do { use integer; 1 << ($bits - 1) } == -$cusp); |
42 | ok (($cusp >> 1) == ($cusp / 2) && |
43 | do { use integer; abs($cusp >> 1) } == ($cusp / 2)); |
ddb9d9dc |
44 | |
9d116dd7 |
45 | $Aaz = chr(ord("A") & ord("z")); |
46 | $Aoz = chr(ord("A") | ord("z")); |
47 | $Axz = chr(ord("A") ^ ord("z")); |
48 | |
ddb9d9dc |
49 | # short strings |
add36b05 |
50 | is (("AAAAA" & "zzzzz"), ($Aaz x 5)); |
51 | is (("AAAAA" | "zzzzz"), ($Aoz x 5)); |
52 | is (("AAAAA" ^ "zzzzz"), ($Axz x 5)); |
ddb9d9dc |
53 | |
54 | # long strings |
55 | $foo = "A" x 150; |
56 | $bar = "z" x 75; |
9d116dd7 |
57 | $zap = "A" x 75; |
58 | # & truncates |
add36b05 |
59 | is (($foo & $bar), ($Aaz x 75 )); |
9d116dd7 |
60 | # | does not truncate |
add36b05 |
61 | is (($foo | $bar), ($Aoz x 75 . $zap)); |
9d116dd7 |
62 | # ^ does not truncate |
add36b05 |
63 | is (($foo ^ $bar), ($Axz x 75 . $zap)); |
9d116dd7 |
64 | |
0c57e439 |
65 | # |
add36b05 |
66 | is ("ok \xFF\xFF\n" & "ok 19\n", "ok 19\n"); |
67 | is ("ok 20\n" | "ok \0\0\n", "ok 20\n"); |
68 | is ("o\000 \0001\000" ^ "\000k\0002\000\n", "ok 21\n"); |
0c57e439 |
69 | |
70 | # |
add36b05 |
71 | is ("ok \x{FF}\x{FF}\n" & "ok 22\n", "ok 22\n"); |
72 | is ("ok 23\n" | "ok \x{0}\x{0}\n", "ok 23\n"); |
73 | is ("o\x{0} \x{0}4\x{0}" ^ "\x{0}k\x{0}2\x{0}\n", "ok 24\n"); |
0c57e439 |
74 | |
75 | # |
add36b05 |
76 | is (sprintf("%vd", v4095 & v801), 801); |
77 | is (sprintf("%vd", v4095 | v801), 4095); |
78 | is (sprintf("%vd", v4095 ^ v801), 3294); |
0c57e439 |
79 | |
80 | # |
add36b05 |
81 | is (sprintf("%vd", v4095.801.4095 & v801.4095), '801.801'); |
82 | is (sprintf("%vd", v4095.801.4095 | v801.4095), '4095.4095.4095'); |
83 | is (sprintf("%vd", v801.4095 ^ v4095.801.4095), '3294.3294.4095'); |
2a4ebaa6 |
84 | # |
add36b05 |
85 | is (sprintf("%vd", v120.300 & v200.400), '72.256'); |
86 | is (sprintf("%vd", v120.300 | v200.400), '248.444'); |
87 | is (sprintf("%vd", v120.300 ^ v200.400), '176.188'); |
2a4ebaa6 |
88 | # |
89 | my $a = v120.300; |
90 | my $b = v200.400; |
91 | $a ^= $b; |
add36b05 |
92 | is (sprintf("%vd", $a), '176.188'); |
2a4ebaa6 |
93 | my $a = v120.300; |
94 | my $b = v200.400; |
95 | $a |= $b; |
add36b05 |
96 | is (sprintf("%vd", $a), '248.444'); |
3da1940a |
97 | |
1d68d6cd |
98 | # |
99 | # UTF8 ~ behaviour |
3da1940a |
100 | # |
101 | |
210db7fc |
102 | my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; |
103 | |
3da1940a |
104 | my @not36; |
105 | |
f0da931d |
106 | for (0x100...0xFFF) { |
1d68d6cd |
107 | $a = ~(chr $_); |
210db7fc |
108 | if ($Is_EBCDIC) { |
109 | push @not36, sprintf("%#03X", $_) |
110 | if $a ne chr(~$_) or length($a) != 1; |
111 | } |
112 | else { |
113 | push @not36, sprintf("%#03X", $_) |
114 | if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_); |
115 | } |
3da1940a |
116 | } |
add36b05 |
117 | is (join (', ', @not36), ''); |
1d68d6cd |
118 | |
3da1940a |
119 | my @not37; |
120 | |
1d68d6cd |
121 | for my $i (0xEEE...0xF00) { |
122 | for my $j (0x0..0x120) { |
123 | $a = ~(chr ($i) . chr $j); |
210db7fc |
124 | if ($Is_EBCDIC) { |
125 | push @not37, sprintf("%#03X %#03X", $i, $j) |
126 | if $a ne chr(~$i).chr(~$j) or |
127 | length($a) != 2; |
128 | } |
129 | else { |
130 | push @not37, sprintf("%#03X %#03X", $i, $j) |
131 | if $a ne chr(~$i).chr(~$j) or |
132 | length($a) != 2 or |
133 | ~$a ne chr($i).chr($j); |
134 | } |
1d68d6cd |
135 | } |
136 | } |
add36b05 |
137 | is (join (', ', @not37), ''); |
138 | |
139 | SKIP: { |
140 | skip "EBCDIC" if $Is_EBCDIC; |
141 | is (~chr(~0), "\0"); |
3da1940a |
142 | } |
f0da931d |
143 | |
a1ca4561 |
144 | |
145 | my @not39; |
146 | |
147 | for my $i (0x100..0x120) { |
148 | for my $j (0x100...0x120) { |
149 | push @not39, sprintf("%#03X %#03X", $i, $j) |
150 | if ~(chr($i)|chr($j)) ne (~chr($i)&~chr($j)); |
151 | } |
152 | } |
add36b05 |
153 | is (join (', ', @not39), ''); |
a1ca4561 |
154 | |
155 | my @not40; |
156 | |
157 | for my $i (0x100..0x120) { |
158 | for my $j (0x100...0x120) { |
159 | push @not40, sprintf("%#03X %#03X", $i, $j) |
160 | if ~(chr($i)&chr($j)) ne (~chr($i)|~chr($j)); |
161 | } |
162 | } |
add36b05 |
163 | is (join (', ', @not40), ''); |
164 | |
299b089d |
165 | |
166 | # More variations on 19 and 22. |
add36b05 |
167 | is ("ok \xFF\x{FF}\n" & "ok 41\n", "ok 41\n"); |
168 | is ("ok \x{FF}\xFF\n" & "ok 42\n", "ok 42\n"); |
66a74c25 |
169 | |
170 | # Tests to see if you really can do casts negative floats to unsigned properly |
171 | $neg1 = -1.0; |
add36b05 |
172 | ok (~ $neg1 == 0); |
66a74c25 |
173 | $neg7 = -7.0; |
add36b05 |
174 | ok (~ $neg7 == 6); |
891f9566 |
175 | |
891f9566 |
176 | |
177 | # double magic tests |
178 | |
179 | sub TIESCALAR { bless { value => $_[1], orig => $_[1] } } |
180 | sub STORE { $_[0]{store}++; $_[0]{value} = $_[1] } |
181 | sub FETCH { $_[0]{fetch}++; $_[0]{value} } |
182 | sub stores { tied($_[0])->{value} = tied($_[0])->{orig}; |
183 | delete(tied($_[0])->{store}) || 0 } |
184 | sub fetches { delete(tied($_[0])->{fetch}) || 0 } |
185 | |
186 | # numeric double magic tests |
187 | |
188 | tie $x, "main", 1; |
189 | tie $y, "main", 3; |
190 | |
191 | is(($x | $y), 3); |
192 | is(fetches($x), 1); |
193 | is(fetches($y), 1); |
194 | is(stores($x), 0); |
195 | is(stores($y), 0); |
196 | |
197 | is(($x & $y), 1); |
198 | is(fetches($x), 1); |
199 | is(fetches($y), 1); |
200 | is(stores($x), 0); |
201 | is(stores($y), 0); |
202 | |
203 | is(($x ^ $y), 2); |
204 | is(fetches($x), 1); |
205 | is(fetches($y), 1); |
206 | is(stores($x), 0); |
207 | is(stores($y), 0); |
208 | |
209 | is(($x |= $y), 3); |
210 | is(fetches($x), 2); |
211 | is(fetches($y), 1); |
212 | is(stores($x), 1); |
213 | is(stores($y), 0); |
214 | |
215 | is(($x &= $y), 1); |
216 | is(fetches($x), 2); |
217 | is(fetches($y), 1); |
218 | is(stores($x), 1); |
219 | is(stores($y), 0); |
220 | |
221 | is(($x ^= $y), 2); |
222 | is(fetches($x), 2); |
223 | is(fetches($y), 1); |
224 | is(stores($x), 1); |
225 | is(stores($y), 0); |
226 | |
227 | is(~~$y, 3); |
228 | is(fetches($y), 1); |
229 | is(stores($y), 0); |
230 | |
231 | { use integer; |
232 | |
233 | is(($x | $y), 3); |
234 | is(fetches($x), 1); |
235 | is(fetches($y), 1); |
236 | is(stores($x), 0); |
237 | is(stores($y), 0); |
238 | |
239 | is(($x & $y), 1); |
240 | is(fetches($x), 1); |
241 | is(fetches($y), 1); |
242 | is(stores($x), 0); |
243 | is(stores($y), 0); |
244 | |
245 | is(($x ^ $y), 2); |
246 | is(fetches($x), 1); |
247 | is(fetches($y), 1); |
248 | is(stores($x), 0); |
249 | is(stores($y), 0); |
250 | |
251 | is(($x |= $y), 3); |
252 | is(fetches($x), 2); |
253 | is(fetches($y), 1); |
254 | is(stores($x), 1); |
255 | is(stores($y), 0); |
256 | |
257 | is(($x &= $y), 1); |
258 | is(fetches($x), 2); |
259 | is(fetches($y), 1); |
260 | is(stores($x), 1); |
261 | is(stores($y), 0); |
262 | |
263 | is(($x ^= $y), 2); |
264 | is(fetches($x), 2); |
265 | is(fetches($y), 1); |
266 | is(stores($x), 1); |
267 | is(stores($y), 0); |
268 | |
269 | is(~$y, -4); |
270 | is(fetches($y), 1); |
271 | is(stores($y), 0); |
272 | |
273 | } # end of use integer; |
274 | |
275 | # stringwise double magic tests |
276 | |
277 | tie $x, "main", "a"; |
278 | tie $y, "main", "c"; |
279 | |
280 | is(($x | $y), ("a" | "c")); |
281 | is(fetches($x), 1); |
282 | is(fetches($y), 1); |
283 | is(stores($x), 0); |
284 | is(stores($y), 0); |
285 | |
286 | is(($x & $y), ("a" & "c")); |
287 | is(fetches($x), 1); |
288 | is(fetches($y), 1); |
289 | is(stores($x), 0); |
290 | is(stores($y), 0); |
291 | |
292 | is(($x ^ $y), ("a" ^ "c")); |
293 | is(fetches($x), 1); |
294 | is(fetches($y), 1); |
295 | is(stores($x), 0); |
296 | is(stores($y), 0); |
297 | |
298 | is(($x |= $y), ("a" | "c")); |
299 | is(fetches($x), 2); |
300 | is(fetches($y), 1); |
301 | is(stores($x), 1); |
302 | is(stores($y), 0); |
303 | |
304 | is(($x &= $y), ("a" & "c")); |
305 | is(fetches($x), 2); |
306 | is(fetches($y), 1); |
307 | is(stores($x), 1); |
308 | is(stores($y), 0); |
309 | |
310 | is(($x ^= $y), ("a" ^ "c")); |
311 | is(fetches($x), 2); |
312 | is(fetches($y), 1); |
313 | is(stores($x), 1); |
314 | is(stores($y), 0); |
315 | |
316 | is(~~$y, "c"); |
317 | is(fetches($y), 1); |
318 | is(stores($y), 0); |
d0a21e00 |
319 | |
320 | $a = "\0\x{100}"; chop($a); |
321 | ok(utf8::is_utf8($a)); # make sure UTF8 flag is still there |
322 | $a = ~$a; |
323 | is($a, "\xFF", "~ works with utf-8"); |