t/comp/fold.t

   1 #!./perl -w
   2
   3 # Uncomment this for testing, but don't leave it in for "production", as
   4 # we've not yet verified that use works.
   5 # use strict;
   6
   7 print "1..13\n";
   8 my $test = 0;
   9
  10 # Historically constant folding was performed by evaluating the ops, and if
  11 # they threw an exception compilation failed. This was seen as buggy, because
  12 # even illegal constants in unreachable code would cause failure. So now
  13 # illegal expressions are reported at runtime, if the expression is reached,
  14 # making constant folding consistent with many other languages, and purely an
  15 # optimisation rather than a behaviour change.
  16
  17
  18 sub failed {
  19     my ($got, $expected, $name) = @_;
  20
  21     print "not ok $test - $name\n";
  22     my @caller = caller(1);
  23     print "# Failed test at $caller[1] line $caller[2]\n";
  24     if (defined $got) {
  25         print "# Got '$got'\n";
  26     } else {
  27         print "# Got undef\n";
  28     }
  29     print "# Expected $expected\n";
  30     return;
  31 }
  32
  33 sub like {
  34     my ($got, $pattern, $name) = @_;
  35     $test = $test + 1;
  36     if (defined $got && $got =~ $pattern) {
  37         print "ok $test - $name\n";
  38         # Principle of least surprise - maintain the expected interface, even
  39         # though we aren't using it here (yet).
  40         return 1;
  41     }
  42     failed($got, $pattern, $name);
  43 }
  44
  45 sub is {
  46     my ($got, $expect, $name) = @_;
  47     $test = $test + 1;
  48     if (defined $got && $got eq $expect) {
  49         print "ok $test - $name\n";
  50         return 1;
  51     }
  52     failed($got, "'$expect'", $name);
  53 }
  54
  55 my $a;
  56 $a = eval '$b = 0/0 if 0; 3';
  57 is ($a, 3, 'constants in conditionals don\'t affect constant folding');
  58 is ($@, '', 'no error');
  59
  60 my $b = 0;
  61 $a = eval 'if ($b) {return sqrt -3} 3';
  62 is ($a, 3, 'variables in conditionals don\'t affect constant folding');
  63 is ($@, '', 'no error');
  64
  65 $a = eval q{
  66         $b = eval q{if ($b) {return log 0} 4};
  67         is ($b, 4, 'inner eval folds constant');
  68         is ($@, '', 'no error');
  69         5;
  70 };
  71 is ($a, 5, 'outer eval folds constant');
  72 is ($@, '', 'no error');
  73
  74 # warn and die hooks should be disabled during constant folding
  75
  76 {
  77     my $c = 0;
  78     local $SIG{__WARN__} = sub { $c++   };
  79     local $SIG{__DIE__}  = sub { $c+= 2 };
  80     eval q{
  81         is($c, 0, "premature warn/die: $c");
  82         my $x = "a"+5;
  83         is($c, 1, "missing warn hook");
  84         is($x, 5, "a+5");
  85         $c = 0;
  86         $x = 1/0;
  87     };
  88     like ($@, qr/division/, "eval caught division");
  89     is($c, 2, "missing die hook");
  90 }