This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
VAX: test changes for VAX floats
authorJarkko Hietaniemi <jhi@iki.fi>
Mon, 27 Jun 2016 22:57:14 +0000 (18:57 -0400)
committerJarkko Hietaniemi <jhi@iki.fi>
Sat, 2 Jul 2016 00:43:13 +0000 (20:43 -0400)
The hexfp (literals or %a) seems to be partially working: simple cases
seem to work, but there are failures.

t/base/num.t
t/op/inc.t
t/op/infnan.t
t/op/numconvert.t
t/op/pack.t
t/op/sprintf.t
t/op/sprintf2.t
t/op/time.t
t/opbasic/arith.t

index 8a61fb9..6ccc0cf 100644 (file)
@@ -176,12 +176,14 @@ $a = 0.00049999999999999999999999999999999999999;
 $b = 0.0005000000000000000104;
 print $a <= $b ? "ok 46\n" : "not ok 46\n";
 
-if ($^O eq 'ultrix' || $^O eq 'VMS') {
+if ($^O eq 'ultrix' || $^O eq 'VMS' ||
+    (pack("d", 1) =~ /^[\x80\x10]\x40/)  # VAX D_FLOAT, G_FLOAT.
+    ) {
   # Ultrix enters looong nirvana over this. VMS blows up when configured with
   # D_FLOAT (but with G_FLOAT or IEEE works fine).  The test should probably
   # make the number of 0's a function of NV_DIG, but that's not in Config and 
   # we probably don't want to suck Config into a base test anyway.
-  print "ok 47\n";
+  print "ok 47 # skipped on $^O\n";
 } else {
   $a = 0.00000000000000000000000000000000000000000000000000000000000000000001;
   print $a > 0 ? "ok 47\n" : "not ok 47\n";
index a98307a..e362ed1 100644 (file)
@@ -191,6 +191,11 @@ SKIP: {
         ($Config{longdblkind} == 6 || $Config{longdblkind} == 5)) {
         skip "the double-double format is weird", 1;
     }
+    if ($Config{doublekind} == 9  ||
+        $Config{doublekind} == 10 ||
+        $Config{doublekind} == 11) {
+        skip "the VAX format is not IEEE", 1;
+    }
 
 # I'm sure that there's an IBM format with a 48 bit mantissa
 # IEEE doubles have a 53 bit mantissa
index dc1ff22..06fb60d 100644 (file)
@@ -16,6 +16,11 @@ BEGIN {
         # but Inf is completely broken (e.g. Inf + 0 -> NaN).
         skip_all "$^O with long doubles does not have sane inf/nan";
     }
+    if ($Config{doublekind} == 9 ||
+        $Config{doublekind} == 10 ||
+        $Config{doublekind} == 11) {
+        skip_all "the doublekind $Config{doublekind} does not have inf/nan";
+    }
 }
 
 my $PInf = "Inf"  + 0;
index bfdb488..e62cac3 100644 (file)
@@ -39,6 +39,9 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
+    if (pack("d", 1) =~ /^[\x80\10]\x40/) {
+        skip_all("VAX float cannot do infinity");
+    }
 }
 
 use strict;
index a2da636..df16464 100644 (file)
@@ -50,6 +50,8 @@ for my $size ( 16, 32, 64 ) {
 my $IsTwosComplement = pack('i', -1) eq "\xFF" x $Config{intsize};
 print "# \$IsTwosComplement = $IsTwosComplement\n";
 
+my $vax_float = (pack("d", 1) =~ /^[\x80\x10]\x40/);
+
 sub is_valid_error
 {
   my $err = shift;
@@ -295,7 +297,7 @@ sub list_eq ($$) {
     # Is this a stupid thing to do on VMS, VOS and other unusual platforms?
 
     skip("-- the IEEE infinity model is unavailable in this configuration.", 1)
-       if (($^O eq 'VMS') && !defined($Config{useieee}));
+       if (($^O eq 'VMS') && !defined($Config{useieee}) || $vax_float);
 
     skip("-- $^O has serious fp indigestion on w-packed infinities", 1)
        if (
@@ -320,7 +322,7 @@ sub list_eq ($$) {
  SKIP: {
 
     skip("-- the full range of an IEEE double may not be available in this configuration.", 3)
-       if (($^O eq 'VMS') && !defined($Config{useieee}));
+       if (($^O eq 'VMS') && !defined($Config{useieee}) || $vax_float);
 
     skip("-- $^O does not like 2**1023", 3)
        if (($^O eq 'ultrix'));
@@ -1340,7 +1342,7 @@ SKIP: {
                        | [Bb]  (?{ '101' })
                        | [Hh]  (?{ 'b8' })
                        | [svnSiIlVNLqQjJ]  (?{ 10111 })
-                       | [FfDd]  (?{ 1.36514538e67 })
+                       | [FfDd]  (?{ 1.36514538e37 })
                        | [pP]  (?{ "try this buffer" })
                        /x; $^R } @codes;
    my @end = (0x12345678, 0x23456781, 0x35465768, 0x15263748);
@@ -1531,8 +1533,11 @@ is(unpack('c'), 65, "one-arg unpack (change #18751)"); # defaulting to $_
     my (@y) = unpack("%b10a", "abcd");
     is($x[1], $y[1], "checksum advance ok");
 
-    # verify that the checksum is not overflowed with C0
-    is(unpack("C0%128U", "abcd"), unpack("U0%128U", "abcd"), "checksum not overflowed");
+    SKIP: {
+        skip("-- VAX float", 1) if $vax_float;
+        # verify that the checksum is not overflowed with C0
+        is(unpack("C0%128U", "abcd"), unpack("U0%128U", "abcd"), "checksum not overflowed");
+    }
 }
 
 my $U_1FFC_bytes = byte_utf8a_to_utf8n("\341\277\274");
index 7ccb88d..4aef466 100644 (file)
@@ -111,18 +111,29 @@ for (@tests) {
     if ($comment =~ s/\s+skip:\s*(.*)//) {
        my $os  = $1;
        my $osv = exists $Config{osvers} ? $Config{osvers} : "0";
+       my $archname = $Config{archname};
        # >comment skip: all<
        if ($os =~ /\ball\b/i) {
            $skip = 1;
-       # >comment skip: VMS hpux:10.20<
-       } elsif ($os =~ /\b$^O(?::(\S+))?\b/i) {
-           my $vsn = defined $1 ? $1 : "0";
-           # Only compare on the the first pair of digits, as numeric
-           # compares do not like 2.6.10-3mdksmp or 2.6.8-24.10-default
-           s/^(\d+(\.\d+)?).*/$1/ for $osv, $vsn;
-           $skip = $vsn ? ($osv <= $vsn ? 1 : 0) : 1;
+       } elsif ($os =~ /\b$^O(?::(\S+))\b/i) {
+            my $cond = $1;
+            if ($cond =~ m{^/(.+)/$}) {
+                # >comment skip: solaris:/86/<
+                my $vsr = $1;
+                $skip = $Config{archname} =~ /$vsr/;
+            } elsif ($cond =~ /^\d/) {
+                # >comment skip: VMS hpux:10.20<
+                my $vsn = $cond;
+                # Only compare on the the first pair of digits, as numeric
+                # compares do not like 2.6.10-3mdksmp or 2.6.8-24.10-default
+                s/^(\d+(\.\d+)?).*/$1/ for $osv, $vsn;
+                $skip = $vsn ? ($osv <= $vsn ? 1 : 0) : 1;
+            } else {
+                # >comment skip: netbsd:vax-netbsd<
+                $skip = $cond eq $archname;
+            }
        }
-       $skip and $comment =~ s/$/, failure expected on $^O $osv/;
+       $skip and $comment =~ s/$/, failure expected on $^O $osv $archname/;
     }
 
     if ($x eq ">$result<") {
@@ -163,9 +174,11 @@ for (@tests) {
 #
 # Tests that are expected to fail on a certain OS can be marked as such
 # by trailing the comment with a skip: section. Skips are tags separated
-# bu space consisting of a $^O optionally trailed with :osvers. In the
-# latter case, all os-levels below that are expected to fail. A special
-# tag 'all' is allowed for todo tests that should fail on any system
+# by space consisting of a $^O optionally trailed with :osvers or :archname.
+# In the osvers case, all os-levels below that are expected to fail.
+# In the archname case, an exact match is expected, unless the archname
+# begins (and ends) with a "/", in which case a regexp is expected.
+# A special tag 'all' is allowed for todo tests that should fail on any system
 #
 # >%G<   >1234567e96<  >1.23457E+102<   >exponent too big skip: os390<
 # >%.0g< >-0.0<        >-0<             >No minus skip: MSWin32 VMS hpux:10.20<
@@ -420,7 +433,7 @@ __END__
 > %.0g<     >[]<          > 0 MISSING<
 >%.2g<      >[]<          >0 MISSING<
 >%.2gC<      >[]<          >0C MISSING<
->%.0g<      >-0.0<        >-0<            >C99 standard mandates minus sign but C89 does not skip: MSWin32 VMS hpux:10.20 openbsd netbsd:1.5 irix darwin freebsd:4.9 android<
+>%.0g<      >-0.0<        >-0<            >C99 standard mandates minus sign but C89 does not skip: MSWin32 VMS netbsd:vax-netbsd hpux:10.20 openbsd netbsd:1.5 irix darwin freebsd:4.9 android<
 >%.0g<      >12345.6789<  >1e+04<
 >%#.0g<     >12345.6789<  >1.e+04<
 >%.2g<      >12345.6789<  >1.2e+04<
index 43ed919..d975630 100644 (file)
@@ -529,10 +529,15 @@ for my $num (0, -1, 1) {
     }
 }
 
-# test that %f doesn't panic with +Inf, -Inf, NaN [perl #45383]
-foreach my $n (2**1e100, -2**1e100, 2**1e100/2**1e100) { # +Inf, -Inf, NaN
-    eval { my $f = sprintf("%f", $n); };
-    is $@, "", "sprintf(\"%f\", $n)";
+my $vax_float = (pack("d", 1) =~ /^[\x80\x10]\x40/);
+
+SKIP: {
+    if ($vax_float) { skip "VAX float has no Inf or NaN", 3 }
+    # test that %f doesn't panic with +Inf, -Inf, NaN [perl #45383]
+    foreach my $n ('2**1e100', '-2**1e100', '2**1e100/2**1e100') { # +Inf, -Inf, NaN
+        eval { my $f = sprintf("%f", eval $n); };
+        is $@, "", "sprintf(\"%f\", $n)";
+    }
 }
 
 # test %ll formats with and without HAS_QUAD
@@ -595,6 +600,9 @@ $o::count = 0;
 is $o::count,    0, 'sprintf %d string overload count is 0';
 is $o::numcount, 1, 'sprintf %d number overload count is 1';
 
+SKIP: {  # hexfp
+    if ($vax_float) { skip "VAX float no hexfp", scalar @hexfloat }
+
 my $ppc_linux = $Config{archname} =~ /^(?:ppc|power(?:pc)?)(?:64)?-linux/;
 my $irix_ld   = $Config{archname} =~ /^IP\d+-irix-ld$/;
 
@@ -682,6 +690,8 @@ for my $t (@hexfloat) {
     ok($ok, "'$format' '$arg' -> '$result' cf '$expected'");
 }
 
+} # SKIP: # hexfp
+
 # double-double long double %a special testing.
 SKIP: {
     skip("uselongdouble=" . ($Config{uselongdouble} ? 'define' : 'undef')
@@ -696,17 +706,17 @@ SKIP: {
                 && $^O eq 'linux'
                 );
     # [rt.perl.org 125633]
-    like(sprintf("%La\n", (2**1020) + (2**-1072)),
+    like(sprintf("%La\n", eval '(2**1020) + (2**-1072)'),
          qr/^0x1.0{522}1p\+1020$/);
-    like(sprintf("%La\n", (2**1021) + (2**-1072)),
+    like(sprintf("%La\n", eval '(2**1021) + (2**-1072)'),
          qr/^0x1.0{523}8p\+1021$/);
-    like(sprintf("%La\n", (2**1022) + (2**-1072)),
+    like(sprintf("%La\n", eval '(2**1022) + (2**-1072)'),
          qr/^0x1.0{523}4p\+1022$/);
-    like(sprintf("%La\n", (2**1023) + (2**-1072)),
+    like(sprintf("%La\n", eval '(2**1023) + (2**-1072)'),
          qr/^0x1.0{523}2p\+1023$/);
-    like(sprintf("%La\n", (2**1023) + (2**-1073)),
+    like(sprintf("%La\n", eval '(2**1023) + (2**-1073)'),
          qr/^0x1.0{523}1p\+1023$/);
-    like(sprintf("%La\n", (2**1023) + (2**-1074)),
+    like(sprintf("%La\n", eval '(2**1023) + (2**-1074)'),
          qr/^0x1.0{524}8p\+1023$/);
 }
 
index d3b8b9c..c726ebf 100644 (file)
@@ -239,7 +239,11 @@ SKIP: { #rt #73040
     like $warning, qr/^localtime\($small_time_f\) failed/m;
 }
 
-{
+my $is_vax = (pack("d", 1) =~ /^[\x80\x10]\x40/);
+my $has_nan = !$is_vax;
+
+SKIP: {
+    skip("No NaN", 2) unless $has_nan;
     local $^W;
     is scalar gmtime("NaN"), undef, '[perl #123495] gmtime(NaN)';
     is scalar localtime("NaN"), undef, 'localtime(NaN)';
index 7992260..8aa1e16 100644 (file)
@@ -426,12 +426,13 @@ if ($^O eq 'VMS') {
   eval {require Config; import Config};
   $vms_no_ieee = 1 unless defined($Config{useieee});
 }
+my $vax_float = (pack("d",1) =~ /^[\x80\x10]\x40/);
 
 if ($^O eq 'vos') {
   print "not ok ", $T++, " # TODO VOS raises SIGFPE instead of producing infinity.\n";
 }
-elsif ($vms_no_ieee) {
- print $T++, " # SKIP -- the IEEE infinity model is unavailable in this configuration.\n"
+elsif ($vms_no_ieee || $vax_float) {
+ print "ok ", $T++, " # SKIP -- the IEEE infinity model is unavailable in this configuration.\n"
 }
 elsif ($^O eq 'ultrix') {
   print "not ok ", $T++, " # TODO Ultrix enters deep nirvana instead of producing infinity.\n";
@@ -460,6 +461,9 @@ else {
 # [perl #120426]
 # small numbers shouldn't round to zero if they have extra floating digits
 
+if ($vax_float) {
+for (1..8) { print "ok ", $T++, " # SKIP -- VAX not IEEE\n" }
+} else {
 try $T++,  0.153e-305 != 0.0,              '0.153e-305';
 try $T++,  0.1530e-305 != 0.0,             '0.1530e-305';
 try $T++,  0.15300e-305 != 0.0,            '0.15300e-305';
@@ -469,6 +473,7 @@ try $T++,  0.1530001e-305 != 0.0,          '0.1530001e-305';
 try $T++,  1.17549435100e-38 != 0.0,       'min single';
 # For flush-to-zero systems this may flush-to-zero, see PERL_SYS_FPU_INIT
 try $T++,  2.2250738585072014e-308 != 0.0, 'min double';
+}
 
 # string-to-nv should equal float literals
 try $T++, "1.23"   + 0 ==  1.23,  '1.23';