This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
op/bop.t: Fix test failing on EBCDIC
[perl5.git] / t / op / bop.t
CommitLineData
ddb9d9dc
PP
1#!./perl
2
3#
55497cff 4# test the bit operators '&', '|', '^', '~', '<<', and '>>'
ddb9d9dc
PP
5#
6
760c7c2f
KW
7use warnings;
8no warnings 'deprecated';
9
d1f8c7a4
CS
10BEGIN {
11 chdir 't' if -d 't';
624c42e2
N
12 require "./test.pl";
13 set_up_inc('../lib');
14 require "./charset_tools.pl";
784fea9c 15 require Config;
d1f8c7a4
CS
16}
17
add36b05
NC
18# Tests don't have names yet.
19# If you find tests are failing, please try adding names to tests to track
20# down where the failure is, and supply your new names as a patch.
21# (Just-in-time test naming)
dc529e65 22plan tests => 192 + (10*13*2) + 5 + 31;
ddb9d9dc
PP
23
24# numerics
add36b05
NC
25ok ((0xdead & 0xbeef) == 0x9ead);
26ok ((0xdead | 0xbeef) == 0xfeef);
27ok ((0xdead ^ 0xbeef) == 0x6042);
28ok ((~0xdead & 0xbeef) == 0x2042);
55497cff
PP
29
30# shifts
add36b05
NC
31ok ((257 << 7) == 32896);
32ok ((33023 >> 7) == 257);
55497cff
PP
33
34# signed vs. unsigned
add36b05 35ok ((~0 > 0 && do { use integer; ~0 } == -1));
d1f8c7a4
CS
36
37my $bits = 0;
38for (my $i = ~0; $i; $i >>= 1) { ++$bits; }
39my $cusp = 1 << ($bits - 1);
40
add36b05
NC
41
42ok (($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0);
43ok (($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0);
44ok (($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0);
45ok ((1 << ($bits - 1)) == $cusp &&
46 do { use integer; 1 << ($bits - 1) } == -$cusp);
47ok (($cusp >> 1) == ($cusp / 2) &&
48 do { use integer; abs($cusp >> 1) } == ($cusp / 2));
ddb9d9dc 49
9d116dd7
JH
50$Aaz = chr(ord("A") & ord("z"));
51$Aoz = chr(ord("A") | ord("z"));
52$Axz = chr(ord("A") ^ ord("z"));
53
ddb9d9dc 54# short strings
add36b05
NC
55is (("AAAAA" & "zzzzz"), ($Aaz x 5));
56is (("AAAAA" | "zzzzz"), ($Aoz x 5));
57is (("AAAAA" ^ "zzzzz"), ($Axz x 5));
ddb9d9dc
PP
58
59# long strings
60$foo = "A" x 150;
61$bar = "z" x 75;
9d116dd7
JH
62$zap = "A" x 75;
63# & truncates
add36b05 64is (($foo & $bar), ($Aaz x 75 ));
9d116dd7 65# | does not truncate
add36b05 66is (($foo | $bar), ($Aoz x 75 . $zap));
9d116dd7 67# ^ does not truncate
add36b05 68is (($foo ^ $bar), ($Axz x 75 . $zap));
9d116dd7 69
b35338b6
KW
70# string constants. These tests expect the bit patterns of these strings in
71# ASCII, so convert to that.
72sub _and($) { $_[0] & native_to_uni("+0") }
73sub _oar($) { $_[0] | native_to_uni("+0") }
74sub _xor($) { $_[0] ^ native_to_uni("+0") }
75is _and native_to_uni("waf"), native_to_uni('# '), 'str var & const str'; # [perl #20661]
76is _and native_to_uni("waf"), native_to_uni('# '), 'str var & const str again'; # [perl #20661]
77is _oar native_to_uni("yit"), native_to_uni('{yt'), 'str var | const str';
78is _oar native_to_uni("yit"), native_to_uni('{yt'), 'str var | const str again';
79is _xor native_to_uni("yit"), native_to_uni('RYt'), 'str var ^ const str';
80is _xor native_to_uni("yit"), native_to_uni('RYt'), 'str var ^ const str again';
81
82SKIP: {
83 skip "Converting a numeric doesn't work with EBCDIC unlike the above tests",
84 3 if $::IS_EBCDIC;
85 is _and 0, '0', 'num var & const str'; # [perl #20661]
86 is _oar 0, '0', 'num var | const str';
87 is _xor 0, '0', 'num var ^ const str';
88}
b20c4ee1 89
5ee80e13
FC
90# But don’t mistake a COW for a constant when assigning to it
91%h=(150=>1);
92$i=(keys %h)[0];
93$i |= 105;
94is $i, 255, '[perl #108480] $cow |= number';
95$i=(keys %h)[0];
96$i &= 105;
97is $i, 0, '[perl #108480] $cow &= number';
98$i=(keys %h)[0];
99$i ^= 105;
100is $i, 255, '[perl #108480] $cow ^= number';
101
0c57e439 102#
add36b05
NC
103is ("ok \xFF\xFF\n" & "ok 19\n", "ok 19\n");
104is ("ok 20\n" | "ok \0\0\n", "ok 20\n");
105is ("o\000 \0001\000" ^ "\000k\0002\000\n", "ok 21\n");
0c57e439
GS
106
107#
add36b05
NC
108is ("ok \x{FF}\x{FF}\n" & "ok 22\n", "ok 22\n");
109is ("ok 23\n" | "ok \x{0}\x{0}\n", "ok 23\n");
110is ("o\x{0} \x{0}4\x{0}" ^ "\x{0}k\x{0}2\x{0}\n", "ok 24\n");
0c57e439
GS
111
112#
add36b05
NC
113is (sprintf("%vd", v4095 & v801), 801);
114is (sprintf("%vd", v4095 | v801), 4095);
115is (sprintf("%vd", v4095 ^ v801), 3294);
0c57e439
GS
116
117#
add36b05
NC
118is (sprintf("%vd", v4095.801.4095 & v801.4095), '801.801');
119is (sprintf("%vd", v4095.801.4095 | v801.4095), '4095.4095.4095');
120is (sprintf("%vd", v801.4095 ^ v4095.801.4095), '3294.3294.4095');
2a4ebaa6 121#
add36b05
NC
122is (sprintf("%vd", v120.300 & v200.400), '72.256');
123is (sprintf("%vd", v120.300 | v200.400), '248.444');
124is (sprintf("%vd", v120.300 ^ v200.400), '176.188');
2a4ebaa6 125#
51f0b9cd
JH
126{
127 my $a = v120.300;
128 my $b = v200.400;
129 $a ^= $b;
130 is (sprintf("%vd", $a), '176.188');
131}
132{
133 my $a = v120.300;
134 my $b = v200.400;
135 $a |= $b;
136 is (sprintf("%vd", $a), '248.444');
137}
3da1940a 138
1d68d6cd
SC
139#
140# UTF8 ~ behaviour
3da1940a
JH
141#
142
c0236afe 143{
b35338b6 144 my @not36;
3da1940a 145
b35338b6
KW
146 for (0x100...0xFFF) {
147 $a = ~(chr $_);
148 push @not36, sprintf("%#03X", $_)
149 if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_);
150 }
151 is (join (', ', @not36), '');
1d68d6cd 152
b35338b6 153 my @not37;
3da1940a 154
b35338b6
KW
155 for my $i (0xEEE...0xF00) {
156 for my $j (0x0..0x120) {
157 $a = ~(chr ($i) . chr $j);
158 push @not37, sprintf("%#03X %#03X", $i, $j)
159 if $a ne chr(~$i).chr(~$j) or
160 length($a) != 2 or
161 ~$a ne chr($i).chr($j);
162 }
210db7fc 163 }
b35338b6 164 is (join (', ', @not37), '');
add36b05 165
b35338b6 166 is (~chr(~0), "\0");
f0da931d 167
a1ca4561 168
b35338b6 169 my @not39;
a1ca4561 170
b35338b6
KW
171 for my $i (0x100..0x120) {
172 for my $j (0x100...0x120) {
173 push @not39, sprintf("%#03X %#03X", $i, $j)
174 if ~(chr($i)|chr($j)) ne (~chr($i)&~chr($j));
175 }
a1ca4561 176 }
b35338b6 177 is (join (', ', @not39), '');
a1ca4561 178
b35338b6 179 my @not40;
a1ca4561 180
b35338b6
KW
181 for my $i (0x100..0x120) {
182 for my $j (0x100...0x120) {
183 push @not40, sprintf("%#03X %#03X", $i, $j)
184 if ~(chr($i)&chr($j)) ne (~chr($i)|~chr($j));
185 }
a1ca4561 186 }
b35338b6 187 is (join (', ', @not40), '');
a1ca4561 188}
add36b05 189
299b089d
JH
190
191# More variations on 19 and 22.
add36b05
NC
192is ("ok \xFF\x{FF}\n" & "ok 41\n", "ok 41\n");
193is ("ok \x{FF}\xFF\n" & "ok 42\n", "ok 42\n");
66a74c25
JO
194
195# Tests to see if you really can do casts negative floats to unsigned properly
196$neg1 = -1.0;
add36b05 197ok (~ $neg1 == 0);
66a74c25 198$neg7 = -7.0;
add36b05 199ok (~ $neg7 == 6);
891f9566 200
891f9566
YST
201
202# double magic tests
203
204sub TIESCALAR { bless { value => $_[1], orig => $_[1] } }
205sub STORE { $_[0]{store}++; $_[0]{value} = $_[1] }
206sub FETCH { $_[0]{fetch}++; $_[0]{value} }
207sub stores { tied($_[0])->{value} = tied($_[0])->{orig};
208 delete(tied($_[0])->{store}) || 0 }
209sub fetches { delete(tied($_[0])->{fetch}) || 0 }
210
211# numeric double magic tests
212
213tie $x, "main", 1;
214tie $y, "main", 3;
215
216is(($x | $y), 3);
217is(fetches($x), 1);
218is(fetches($y), 1);
219is(stores($x), 0);
220is(stores($y), 0);
221
222is(($x & $y), 1);
223is(fetches($x), 1);
224is(fetches($y), 1);
225is(stores($x), 0);
226is(stores($y), 0);
227
228is(($x ^ $y), 2);
229is(fetches($x), 1);
230is(fetches($y), 1);
231is(stores($x), 0);
232is(stores($y), 0);
233
234is(($x |= $y), 3);
235is(fetches($x), 2);
236is(fetches($y), 1);
237is(stores($x), 1);
238is(stores($y), 0);
239
240is(($x &= $y), 1);
241is(fetches($x), 2);
242is(fetches($y), 1);
243is(stores($x), 1);
244is(stores($y), 0);
245
246is(($x ^= $y), 2);
247is(fetches($x), 2);
248is(fetches($y), 1);
249is(stores($x), 1);
250is(stores($y), 0);
251
252is(~~$y, 3);
253is(fetches($y), 1);
254is(stores($y), 0);
255
256{ use integer;
257
258is(($x | $y), 3);
259is(fetches($x), 1);
260is(fetches($y), 1);
261is(stores($x), 0);
262is(stores($y), 0);
263
264is(($x & $y), 1);
265is(fetches($x), 1);
266is(fetches($y), 1);
267is(stores($x), 0);
268is(stores($y), 0);
269
270is(($x ^ $y), 2);
271is(fetches($x), 1);
272is(fetches($y), 1);
273is(stores($x), 0);
274is(stores($y), 0);
275
276is(($x |= $y), 3);
277is(fetches($x), 2);
278is(fetches($y), 1);
279is(stores($x), 1);
280is(stores($y), 0);
281
282is(($x &= $y), 1);
283is(fetches($x), 2);
284is(fetches($y), 1);
285is(stores($x), 1);
286is(stores($y), 0);
287
288is(($x ^= $y), 2);
289is(fetches($x), 2);
290is(fetches($y), 1);
291is(stores($x), 1);
292is(stores($y), 0);
293
294is(~$y, -4);
295is(fetches($y), 1);
296is(stores($y), 0);
297
298} # end of use integer;
299
300# stringwise double magic tests
301
302tie $x, "main", "a";
303tie $y, "main", "c";
304
305is(($x | $y), ("a" | "c"));
306is(fetches($x), 1);
307is(fetches($y), 1);
308is(stores($x), 0);
309is(stores($y), 0);
310
311is(($x & $y), ("a" & "c"));
312is(fetches($x), 1);
313is(fetches($y), 1);
314is(stores($x), 0);
315is(stores($y), 0);
316
317is(($x ^ $y), ("a" ^ "c"));
318is(fetches($x), 1);
319is(fetches($y), 1);
320is(stores($x), 0);
321is(stores($y), 0);
322
323is(($x |= $y), ("a" | "c"));
324is(fetches($x), 2);
325is(fetches($y), 1);
326is(stores($x), 1);
327is(stores($y), 0);
328
329is(($x &= $y), ("a" & "c"));
330is(fetches($x), 2);
331is(fetches($y), 1);
332is(stores($x), 1);
333is(stores($y), 0);
334
335is(($x ^= $y), ("a" ^ "c"));
336is(fetches($x), 2);
337is(fetches($y), 1);
338is(stores($x), 1);
339is(stores($y), 0);
340
341is(~~$y, "c");
342is(fetches($y), 1);
343is(stores($y), 0);
d0a21e00
GA
344
345$a = "\0\x{100}"; chop($a);
346ok(utf8::is_utf8($a)); # make sure UTF8 flag is still there
347$a = ~$a;
348is($a, "\xFF", "~ works with utf-8");
80ff368f
RGS
349
350# [rt.perl.org 33003]
784fea9c
NC
351# This would cause a segfault without malloc wrap
352SKIP: {
353 skip "No malloc wrap checks" unless $Config::Config{usemallocwrap};
aaa63dae 354 like( runperl(prog => 'eval q($#a>>=1); print 1'), qr/^1\n?/ );
784fea9c 355}
1a787b95
ST
356
357# [perl #37616] Bug in &= (string) and/or m//
358{
359 $a = "aa";
360 $a &= "a";
361 ok($a =~ /a+$/, 'ASCII "a" is NUL-terminated');
362
363 $b = "bb\x{100}";
364 $b &= "b";
365 ok($b =~ /b+$/, 'Unicode "b" is NUL-terminated');
366}
794a0d33
JH
367
368{
369 $a = chr(0x101) x 0x101;
370 $b = chr(0x0FF) x 0x0FF;
371
372 $c = $a | $b;
373 is($c, chr(0x1FF) x 0xFF . chr(0x101) x 2);
374
375 $c = $b | $a;
376 is($c, chr(0x1FF) x 0xFF . chr(0x101) x 2);
377
378 $c = $a & $b;
379 is($c, chr(0x001) x 0x0FF);
380
381 $c = $b & $a;
382 is($c, chr(0x001) x 0x0FF);
383
384 $c = $a ^ $b;
385 is($c, chr(0x1FE) x 0x0FF . chr(0x101) x 2);
386
387 $c = $b ^ $a;
388 is($c, chr(0x1FE) x 0x0FF . chr(0x101) x 2);
389}
390
391{
392 $a = chr(0x101) x 0x101;
393 $b = chr(0x0FF) x 0x0FF;
394
395 $a |= $b;
396 is($a, chr(0x1FF) x 0xFF . chr(0x101) x 2);
397}
398
399{
400 $a = chr(0x101) x 0x101;
401 $b = chr(0x0FF) x 0x0FF;
402
403 $b |= $a;
404 is($b, chr(0x1FF) x 0xFF . chr(0x101) x 2);
405}
406
407{
408 $a = chr(0x101) x 0x101;
409 $b = chr(0x0FF) x 0x0FF;
410
411 $a &= $b;
412 is($a, chr(0x001) x 0x0FF);
413}
414
415{
416 $a = chr(0x101) x 0x101;
417 $b = chr(0x0FF) x 0x0FF;
418
419 $b &= $a;
420 is($b, chr(0x001) x 0x0FF);
421}
422
423{
424 $a = chr(0x101) x 0x101;
425 $b = chr(0x0FF) x 0x0FF;
426
427 $a ^= $b;
428 is($a, chr(0x1FE) x 0x0FF . chr(0x101) x 2);
429}
430
431{
432 $a = chr(0x101) x 0x101;
433 $b = chr(0x0FF) x 0x0FF;
434
435 $b ^= $a;
436 is($b, chr(0x1FE) x 0x0FF . chr(0x101) x 2);
437}
438
8c8eee82 439
b6e8d7fe
FC
440# New string- and number-specific bitwise ops
441{
442 use feature "bitwise";
443 no warnings "experimental::bitwise";
444 is "22" & "66", 2, 'numeric & with strings';
445 is "22" | "66", 86, 'numeric | with strings';
446 is "22" ^ "66", 84, 'numeric ^ with strings';
447 is ~"22" & 0xff, 233, 'numeric ~ with string';
448 is 22 &. 66, 22, '&. with numbers';
449 is 22 |. 66, 66, '|. with numbers';
450 is 22 ^. 66, "\4\4", '^. with numbers';
b35338b6
KW
451 if ($::IS_EBCDIC) {
452 # ord('2') is 0xF2 on EBCDIC
453 is ~.22, "\x0d\x0d", '~. with number';
454 }
455 else {
456 # ord('2') is 0x32 on ASCII
457 is ~.22, "\xcd\xcd", '~. with number';
458 }
b6e8d7fe
FC
459 $_ = "22";
460 is $_ &= "66", 2, 'numeric &= with strings';
461 $_ = "22";
462 is $_ |= "66", 86, 'numeric |= with strings';
463 $_ = "22";
464 is $_ ^= "66", 84, 'numeric ^= with strings';
465 $_ = 22;
466 is $_ &.= 66, 22, '&.= with numbers';
467 $_ = 22;
468 is $_ |.= 66, 66, '|.= with numbers';
469 $_ = 22;
470 is $_ ^.= 66, "\4\4", '^.= with numbers';
471
472 # signed vs. unsigned
473 ok ((~0 > 0 && do { use integer; ~0 } == -1));
474
475 my $bits = 0;
476 for (my $i = ~0; $i; $i >>= 1) { ++$bits; }
477 my $cusp = 1 << ($bits - 1);
478
479 ok (($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0);
480 ok (($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0);
481 ok (($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0);
482 ok ((1 << ($bits - 1)) == $cusp &&
483 do { use integer; 1 << ($bits - 1) } == -$cusp);
484 ok (($cusp >> 1) == ($cusp / 2) &&
485 do { use integer; abs($cusp >> 1) } == ($cusp / 2));
486}
487
8c8eee82
BM
488# ref tests
489
490my %res;
491
492for my $str ("x", "\x{100}") {
493 for my $chr (qw/S A H G X ( * F/) {
494 for my $op (qw/| & ^/) {
495 my $co = ord $chr;
496 my $so = ord $str;
497 $res{"$chr$op$str"} = eval qq/chr($co $op $so)/;
498 }
499 }
500 $res{"undef|$str"} = $str;
501 $res{"undef&$str"} = "";
502 $res{"undef^$str"} = $str;
503}
504
505sub PVBM () { "X" }
51f0b9cd 5061 if index "foo", PVBM;
8c8eee82
BM
507
508my $warn = 0;
509local $^W = 1;
510local $SIG{__WARN__} = sub { $warn++ };
511
512sub is_first {
513 my ($got, $orig, $op, $str, $name) = @_;
514 is(substr($got, 0, 1), $res{"$orig$op$str"}, $name);
515}
516
517for (
518 # [object to test, first char of stringification, name]
519 [undef, "undef", "undef" ],
520 [\1, "S", "scalar ref" ],
521 [[], "A", "array ref" ],
522 [{}, "H", "hash ref" ],
523 [qr/x/, "(", "qr//" ],
524 [*foo, "*", "glob" ],
525 [\*foo, "G", "glob ref" ],
526 [PVBM, "X", "PVBM" ],
527 [\PVBM, "S", "PVBM ref" ],
528 [bless([], "Foo"), "F", "object" ],
529) {
530 my ($val, $orig, $type) = @$_;
531
532 for (["x", "string"], ["\x{100}", "utf8"]) {
533 my ($str, $desc) = @$_;
534
535 $warn = 0;
536
537 is_first($val | $str, $orig, "|", $str, "$type | $desc");
538 is_first($val & $str, $orig, "&", $str, "$type & $desc");
539 is_first($val ^ $str, $orig, "^", $str, "$type ^ $desc");
540
541 is_first($str | $val, $orig, "|", $str, "$desc | $type");
542 is_first($str & $val, $orig, "&", $str, "$desc & $type");
543 is_first($str ^ $val, $orig, "^", $str, "$desc ^ $type");
544
545 my $new;
546 ($new = $val) |= $str;
547 is_first($new, $orig, "|", $str, "$type |= $desc");
548 ($new = $val) &= $str;
549 is_first($new, $orig, "&", $str, "$type &= $desc");
550 ($new = $val) ^= $str;
551 is_first($new, $orig, "^", $str, "$type ^= $desc");
552
553 ($new = $str) |= $val;
554 is_first($new, $orig, "|", $str, "$desc |= $type");
555 ($new = $str) &= $val;
556 is_first($new, $orig, "&", $str, "$desc &= $type");
557 ($new = $str) ^= $val;
558 is_first($new, $orig, "^", $str, "$desc ^= $type");
559
560 if ($orig eq "undef") {
561 # undef |= and undef ^= don't warn
562 is($warn, 10, "no duplicate warnings");
563 }
564 else {
565 is($warn, 0, "no warnings");
566 }
567 }
568}
569
bccb768e
FC
570delete $SIG{__WARN__};
571
8c8eee82
BM
572my $strval;
573
574{
575 package Bar;
576 use overload q/""/ => sub { $strval };
577
578 package Baz;
579 use overload q/|/ => sub { "y" };
580}
581
51f0b9cd 582ok(!eval { 1 if bless([], "Bar") | "x"; 1 },"string overload can't use |");
8c8eee82
BM
583like($@, qr/no method found/, "correct error");
584is(eval { bless([], "Baz") | "x" }, "y", "| overload works");
585
586my $obj = bless [], "Bar";
587$strval = "x";
588eval { $obj |= "Q" };
589$strval = "z";
590is("$obj", "z", "|= doesn't break string overload");
1e6bda93
FC
591
592# [perl #29070]
b35338b6
KW
593$^A .= new version ~$_ for eval sprintf('"\\x%02x"', 0xff - ord("1")),
594 $::IS_EBCDIC ? v13 : v205, # 255 - ord('2')
595 eval sprintf('"\\x%02x"', 0xff - ord("3"));
1e6bda93 596is $^A, "123", '~v0 clears vstring magic on retval';
b3498293
JH
597
598{
599 my $w = $Config::Config{ivsize} * 8;
600
601 fail("unexpected w $w") unless $w == 32 || $w == 64;
602
603 is(1 << 1, 2, "UV 1 left shift 1");
604 is(1 >> 1, 0, "UV 1 right shift 1");
605
606 is(0x7b << -4, 0x007, "UV left negative shift == right shift");
607 is(0x7b >> -4, 0x7b0, "UV right negative shift == left shift");
608
609 is(0x7b << 0, 0x07b, "UV left zero shift == identity");
610 is(0x7b >> 0, 0x07b, "UV right zero shift == identity");
611
612 is(0x0 << -1, 0x0, "zero left negative shift == zero");
613 is(0x0 >> -1, 0x0, "zero right negative shift == zero");
614
615 cmp_ok(1 << $w - 1, '==', 2 ** ($w - 1), # not is() because NV stringify.
616 "UV left $w - 1 shift == 2 ** ($w - 1)");
617 is(1 << $w, 0, "UV left shift $w == zero");
618 is(1 << $w + 1, 0, "UV left shift $w + 1 == zero");
619
620 is(1 >> $w - 1, 0, "UV right shift $w - 1 == zero");
621 is(1 >> $w, 0, "UV right shift $w == zero");
622 is(1 >> $w + 1, 0, "UV right shift $w + 1 == zero");
623
624 # Negative shiftees get promoted to UVs before shifting. This is
625 # not necessarily the ideal behavior, but that is what is happening.
626 if ($w == 64) {
627 no warnings "portable";
2183d14b 628 no warnings "overflow"; # prevent compile-time warning for ivsize=4
b69687e7
JH
629 is(-1 << 1, 0xFFFF_FFFF_FFFF_FFFE,
630 "neg UV (sic) left shift = 0xFF..E");
631 is(-1 >> 1, 0x7FFF_FFFF_FFFF_FFFF,
632 "neg UV (sic) right right = 0x7F..F");
b3498293
JH
633 } elsif ($w == 32) {
634 no warnings "portable";
b69687e7
JH
635 is(-1 << 1, 0xFFFF_FFFE, "neg left shift == 0xFF..E");
636 is(-1 >> 1, 0x7FFF_FFFF, "neg right right == 0x7F..F");
b3498293
JH
637 }
638
639 {
640 # 'use integer' means use IVs instead of UVs.
641 use integer;
642
b69687e7
JH
643 # No surprises here.
644 is(1 << 1, 2, "IV 1 left shift 1 == 2");
645 is(1 >> 1, 0, "IV 1 right shift 1 == 0");
b3498293 646
b69687e7
JH
647 # The left overshift should behave like without 'use integer',
648 # that is, return zero.
649 is(1 << $w, 0, "IV 1 left shift $w == 0");
650 is(1 << $w + 1, 0, "IV 1 left shift $w + 1 == 0");
651 is(-1 << $w, 0, "IV -1 left shift $w == 0");
652 is(-1 << $w + 1, 0, "IV -1 left shift $w + 1 == 0");
b3498293 653
b69687e7
JH
654 # Even for negative IVs, left shift is multiplication.
655 # But right shift should display the stuckiness to -1.
656 is(-1 << 1, -2, "IV -1 left shift 1 == -2");
b3498293
JH
657 is(-1 >> 1, -1, "IV -1 right shift 1 == -1");
658
659 # As for UVs, negative shifting means the reverse shift.
660 is(-1 << -1, -1, "IV -1 left shift -1 == -1");
661 is(-1 >> -1, -2, "IV -1 right shift -1 == -2");
662
663 # Test also at and around wordsize, expect stuckiness to -1.
664 is(-1 >> $w - 1, -1, "IV -1 right shift $w - 1 == -1");
665 is(-1 >> $w, -1, "IV -1 right shift $w == -1");
666 is(-1 >> $w + 1, -1, "IV -1 right shift $w + 1 == -1");
667 }
668}
b43665ff
FC
669
670# [perl #129287] UTF8 & was not providing a trailing null byte.
671# This test is a bit convoluted, as we want to make sure that the string
672# allocated for &’s target contains memory initialised to something other
673# than a null byte. Uninitialised memory does not make for a reliable
674# test. So we do &. on a longer non-utf8 string first.
675for (["aaa","aaa"],[substr ("a\x{100}",0,1), "a"]) {
676 use feature "bitwise";
677 no warnings "experimental::bitwise", "pack";
678 $byte = substr unpack("P2", pack "P", $$_[0] &. $$_[1]), -1;
679}
680is $byte, "\0", "utf8 &. appends null byte";
dc529e65
TC
681
682# only visible under sanitize
683fresh_perl_is('$x = "UUUUUUUV"; $y = "xxxxxxx"; $x |= $y; print $x',
a37fb5d5
KW
684 ( $::IS_EBCDIC) ? 'XXXXXXXV' : '}}}}}}}V',
685 {}, "[perl #129995] access to freed memory");