source: trunk/third/perl/t/op/bop.t @ 18450

Revision 18450, 4.8 KB checked in by zacheiss, 22 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r18449, which included commits to RCS files with non-trunk default branches.
  • Property svn:executable set to *
Line 
1#!./perl
2
3#
4# test the bit operators '&', '|', '^', '~', '<<', and '>>'
5#
6
7BEGIN {
8    chdir 't' if -d 't';
9    @INC = '../lib';
10}
11
12print "1..44\n";
13
14# numerics
15print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n");
16print ((0xdead | 0xbeef) == 0xfeef ? "ok 2\n" : "not ok 2\n");
17print ((0xdead ^ 0xbeef) == 0x6042 ? "ok 3\n" : "not ok 3\n");
18print ((~0xdead & 0xbeef) == 0x2042 ? "ok 4\n" : "not ok 4\n");
19
20# shifts
21print ((257 << 7) == 32896 ? "ok 5\n" : "not ok 5\n");
22print ((33023 >> 7) == 257 ? "ok 6\n" : "not ok 6\n");
23
24# signed vs. unsigned
25print ((~0 > 0 && do { use integer; ~0 } == -1)
26       ? "ok 7\n" : "not ok 7\n");
27
28my $bits = 0;
29for (my $i = ~0; $i; $i >>= 1) { ++$bits; }
30my $cusp = 1 << ($bits - 1);
31
32print ((($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0)
33       ? "ok 8\n" : "not ok 8\n");
34print ((($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0)
35       ? "ok 9\n" : "not ok 9\n");
36print ((($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0)
37       ? "ok 10\n" : "not ok 10\n");
38print (((1 << ($bits - 1)) == $cusp &&
39        do { use integer; 1 << ($bits - 1) } == -$cusp)
40       ? "ok 11\n" : "not ok 11\n");
41print ((($cusp >> 1) == ($cusp / 2) &&
42       do { use integer; abs($cusp >> 1) } == ($cusp / 2))
43       ? "ok 12\n" : "not ok 12\n");
44
45$Aaz = chr(ord("A") & ord("z"));
46$Aoz = chr(ord("A") | ord("z"));
47$Axz = chr(ord("A") ^ ord("z"));
48
49# short strings
50print (("AAAAA" & "zzzzz") eq ($Aaz x 5) ? "ok 13\n" : "not ok 13\n");
51print (("AAAAA" | "zzzzz") eq ($Aoz x 5) ? "ok 14\n" : "not ok 14\n");
52print (("AAAAA" ^ "zzzzz") eq ($Axz x 5) ? "ok 15\n" : "not ok 15\n");
53
54# long strings
55$foo = "A" x 150;
56$bar = "z" x 75;
57$zap = "A" x 75;
58# & truncates
59print (($foo & $bar) eq ($Aaz x 75 ) ? "ok 16\n" : "not ok 16\n");
60# | does not truncate
61print (($foo | $bar) eq ($Aoz x 75 . $zap) ? "ok 17\n" : "not ok 17\n");
62# ^ does not truncate
63print (($foo ^ $bar) eq ($Axz x 75 . $zap) ? "ok 18\n" : "not ok 18\n");
64
65#
66print "ok \xFF\xFF\n" & "ok 19\n";
67print "ok 20\n" | "ok \0\0\n";
68print "o\000 \0001\000" ^ "\000k\0002\000\n";
69
70#
71print "ok \x{FF}\x{FF}\n" & "ok 22\n";
72print "ok 23\n" | "ok \x{0}\x{0}\n";
73print "o\x{0} \x{0}4\x{0}" ^ "\x{0}k\x{0}2\x{0}\n";
74
75#
76print "ok 25\n" if sprintf("%vd", v4095 & v801) eq 801;
77print "ok 26\n" if sprintf("%vd", v4095 | v801) eq 4095;
78print "ok 27\n" if sprintf("%vd", v4095 ^ v801) eq 3294;
79
80#
81print "ok 28\n" if sprintf("%vd", v4095.801.4095 & v801.4095) eq '801.801';
82print "ok 29\n" if sprintf("%vd", v4095.801.4095 | v801.4095) eq '4095.4095.4095';
83print "ok 30\n" if sprintf("%vd", v801.4095 ^ v4095.801.4095) eq '3294.3294.4095';
84#
85print "ok 31\n" if sprintf("%vd", v120.300 & v200.400) eq '72.256';
86print "ok 32\n" if sprintf("%vd", v120.300 | v200.400) eq '248.444';
87print "ok 33\n" if sprintf("%vd", v120.300 ^ v200.400) eq '176.188';
88#
89my $a = v120.300;
90my $b = v200.400;
91$a ^= $b;
92print "ok 34\n" if sprintf("%vd", $a) eq '176.188';
93my $a = v120.300;
94my $b = v200.400;
95$a |= $b;
96print "ok 35\n" if sprintf("%vd", $a) eq '248.444';
97
98#
99# UTF8 ~ behaviour
100#
101
102my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
103
104my @not36;
105
106for (0x100...0xFFF) {
107  $a = ~(chr $_);
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  }
116}
117if (@not36) {
118    print "# test 36 failed\n";
119    print "not ";
120}
121print "ok 36\n";
122
123my @not37;
124
125for my $i (0xEEE...0xF00) {
126  for my $j (0x0..0x120) {
127    $a = ~(chr ($i) . chr $j);
128    if ($Is_EBCDIC) {
129        push @not37, sprintf("%#03X %#03X", $i, $j)
130            if $a ne chr(~$i).chr(~$j) or
131               length($a) != 2;
132    }
133    else {
134        push @not37, sprintf("%#03X %#03X", $i, $j)
135            if $a ne chr(~$i).chr(~$j) or
136               length($a) != 2 or
137               ~$a ne chr($i).chr($j);
138    }
139  }
140}
141if (@not37) {
142    print "# test 37 failed\n";
143    print "not ";
144}
145print "ok 37\n";
146
147print "not " unless ~chr(~0) eq "\0" or $Is_EBCDIC;
148print "ok 38\n";
149
150my @not39;
151
152for my $i (0x100..0x120) {
153    for my $j (0x100...0x120) {
154        push @not39, sprintf("%#03X %#03X", $i, $j)
155            if ~(chr($i)|chr($j)) ne (~chr($i)&~chr($j));
156    }
157}
158if (@not39) {
159    print "# test 39 failed\n";
160    print "not ";
161}
162print "ok 39\n";
163
164my @not40;
165
166for my $i (0x100..0x120) {
167    for my $j (0x100...0x120) {
168        push @not40, sprintf("%#03X %#03X", $i, $j)
169            if ~(chr($i)&chr($j)) ne (~chr($i)|~chr($j));
170    }
171}
172if (@not40) {
173    print "# test 40 failed\n";
174    print "not ";
175}
176print "ok 40\n";
177
178# More variations on 19 and 22.
179print "ok \xFF\x{FF}\n" & "ok 41\n";
180print "ok \x{FF}\xFF\n" & "ok 42\n";
181
182# Tests to see if you really can do casts negative floats to unsigned properly
183$neg1 = -1.0;
184print ((~ $neg1 == 0) ? "ok 43\n" : "not ok 43\n");
185$neg7 = -7.0;
186print ((~ $neg7 == 6) ? "ok 44\n" : "not ok 44\n");
Note: See TracBrowser for help on using the repository browser.