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