1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
#!./perl -w
$|=1;
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
print "1..0\n";
exit 0;
}
}
use Opcode qw(
opcodes opdesc opmask verify_opset
opset opset_to_ops opset_to_hex invert_opset
opmask_add full_opset empty_opset define_optag
);
use strict;
my $t = 1;
my $last_test; # initalised at end
print "1..$last_test\n";
my($s1, $s2, $s3);
my(@o1, @o2, @o3);
# --- opset_to_ops and opset
my @empty_l = opset_to_ops(empty_opset);
print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++;
my @full_l1 = opset_to_ops(full_opset);
print @full_l1 == opcodes() ? "ok $t\n" : "not ok $t\n"; $t++;
my @full_l2 = @full_l1; # = opcodes(); # XXX to be fixed
print "@full_l1" eq "@full_l2" ? "ok $t\n" : "not ok $t\n"; $t++;
@empty_l = opset_to_ops(opset(':none'));
print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++;
my @full_l3 = opset_to_ops(opset(':all'));
print @full_l1 == @full_l3 ? "ok $t\n" : "not ok $t\n"; $t++;
print "@full_l1" eq "@full_l3" ? "ok $t\n" : "not ok $t\n"; $t++;
die $t unless $t == 7;
$s1 = opset( 'padsv');
$s2 = opset($s1, 'padav');
$s3 = opset($s2, '!padav');
print $s1 eq $s2 ? "not ok $t\n" : "ok $t\n"; ++$t;
print $s1 eq $s3 ? "ok $t\n" : "not ok $t\n"; ++$t;
# --- define_optag
print eval { opset(':_tst_') } ? "not ok $t\n" : "ok $t\n"; ++$t;
define_optag(":_tst_", opset(qw(padsv padav padhv)));
print eval { opset(':_tst_') } ? "ok $t\n" : "not ok $t\n"; ++$t;
# --- opdesc and opcodes
die $t unless $t == 11;
print opdesc("gv") eq "glob value" ? "ok $t\n" : "not ok $t\n"; $t++;
my @desc = opdesc(':_tst_','stub');
print "@desc" eq "private variable private array private hash stub"
? "ok $t\n" : "not ok $t\n#@desc\n"; $t++;
print opcodes() ? "ok $t\n" : "not ok $t\n"; $t++;
print "ok $t\n"; ++$t;
# --- invert_opset
$s1 = opset(qw(fileno padsv padav));
@o2 = opset_to_ops(invert_opset($s1));
print @o2 == opcodes-3 ? "ok $t\n" : "not ok $t\n"; $t++;
# --- opmask
die $t unless $t == 16;
print opmask() eq empty_opset() ? "ok $t\n" : "not ok $t\n"; $t++; # work
print length opmask() == int((opcodes()+7)/8) ? "ok $t\n" : "not ok $t\n"; $t++;
# --- verify_opset
print verify_opset($s1) && !verify_opset(42) ? "ok $t\n":"not ok $t\n"; $t++;
# --- opmask_add
opmask_add(opset(qw(fileno))); # add to global op_mask
print eval 'fileno STDOUT' ? "not ok $t\n" : "ok $t\n"; $t++; # fail
print $@ =~ /'fileno' trapped/ ? "ok $t\n" : "not ok $t\n# $@\n"; $t++;
# --- check use of bit vector ops on opsets
$s1 = opset('padsv');
$s2 = opset('padav');
$s3 = opset('padsv', 'padav', 'padhv');
# Non-negated
print (($s1 | $s2) eq opset($s1,$s2) ? "ok $t\n":"not ok $t\n"); $t++;
print (($s2 & $s3) eq opset($s2) ? "ok $t\n":"not ok $t\n"); $t++;
print (($s2 ^ $s3) eq opset('padsv','padhv') ? "ok $t\n":"not ok $t\n"); $t++;
# Negated, e.g., with possible extra bits in last byte beyond last op bit.
# The extra bits mean we can't just say ~mask eq invert_opset(mask).
@o1 = opset_to_ops( ~ $s3);
@o2 = opset_to_ops(invert_opset $s3);
print "@o1" eq "@o2" ? "ok $t\n":"not ok $t\n"; $t++;
# --- finally, check some opname assertions
foreach(@full_l1) { die "bad opname: $_" if /\W/ or /^\d/ }
print "ok $last_test\n";
BEGIN { $last_test = 25 }
|
