REV2: Binary number support

To: perl5-porters@perl.org
Message-ID: <199811301543.KAA15689@vulcan.maker.com>

p4raw-id: //depot/cfgperl@2546

diff --git a/pod/perldata.pod b/pod/perldata.pod
index 9e41c2c..7b9a323 100644 (file)
--- a/pod/perldata.pod
+++ b/pod/perldata.pod
@@ -245,6 +245,7 @@ integer formats:
     .23E-10
     0xffff             # hex
     0377               # octal
+    0b111000           # binary
     4_294_967_296      # underline for legibility
 
 String literals are usually delimited by either single or double

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index aa3539b..bdcb7cf 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -40,6 +40,12 @@ maintenance versions.
 
 =head1 Core Changes
 
+Binary numbers are now supported as literals, in s?printf formats, and
+C<oct()>:
+
+       $answer = 0b101010;
+       printf "The answer is: %b\n", oct("0b101010");
+
 The length argument of C<syswrite()> is now optional.
 
 Better 64-bit support -- but full support still a distant goal.  One

diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 300379f..c781611 100644 (file)
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -2237,8 +2237,9 @@ See the L</use> function, which C<no> is the opposite of.
 =item oct
 
 Interprets EXPR as an octal string and returns the corresponding
-value.  (If EXPR happens to start off with C<0x>, interprets it as
-a hex string instead.)  The following will handle decimal, octal, and
+value.  (If EXPR happens to start off with C<0x>, interprets it as a
+hex string.  If EXPR starts off with C<0b>, it is interpreted as a
+binary string.)  The following will handle decimal, binary, octal, and
 hex in the standard Perl or C notation:
 
     $val = oct($val) if $val =~ /^0/;
@@ -3644,6 +3645,7 @@ In addition, Perl permits the following widely-supported conversions:
    %X  like %x, but using upper-case letters
    %E  like %e, but using an upper-case "E"
    %G  like %g, but with an upper-case "E" (if applicable)
+   %b  an unsigned integer, in binary
    %p  a pointer (outputs the Perl value's address in hexadecimal)
    %n  special: *stores* the number of characters output so far
         into the next variable in the parameter list 

diff --git a/pp.c b/pp.c
index 004ba8c..44114e7 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -1822,6 +1822,8 @@ PP(pp_oct)
        tmps++;
     if (*tmps == 'x')
        value = scan_hex(++tmps, 99, &argtype);
+    else if (*tmps == 'b')
+       value = scan_bin(++tmps, 99, &argtype);
     else
        value = scan_oct(tmps, 99, &argtype);
     XPUSHu(value);

diff --git a/proto.h b/proto.h
index b22451a..333bd23 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -541,6 +541,7 @@ VIRTUAL OP* scalar _((OP* o));
 VIRTUAL OP*    scalarkids _((OP* o));
 VIRTUAL OP*    scalarseq _((OP* o));
 VIRTUAL OP*    scalarvoid _((OP* o));
+VIRTUAL UV     scan_bin _((char* start, I32 len, I32* retlen));
 VIRTUAL UV     scan_hex _((char* start, I32 len, I32* retlen));
 VIRTUAL char*  scan_num _((char* s));
 VIRTUAL UV     scan_oct _((char* start, I32 len, I32* retlen));

diff --git a/sv.c b/sv.c
index fdeed68..6d900ce 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -4645,6 +4645,10 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs,
            base = 10;
            goto uns_integer;
 
+       case 'b':
+           base = 2;
+           goto uns_integer;
+
        case 'O':
            intsize = 'l';
            /* FALL THROUGH */
@@ -4700,6 +4704,14 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs,
                if (alt && *eptr != '0')
                    *--eptr = '0';
                break;
+           case 2:
+               do {
+                   dig = uv & 1;
+                   *--eptr = '0' + dig;
+               } while (uv >>= 1);
+               if (alt && *eptr != '0')
+                   *--eptr = '0';
+               break;
            default:            /* it had better be ten or less */
                do {
                    dig = uv % base;

diff --git a/t/op/oct.t b/t/op/oct.t
index 6623089..06bf8db 100755 (executable)
--- a/t/op/oct.t
+++ b/t/op/oct.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..9\n";
+print "1..11\n";
 
 print +(oct('01234') == 01234) ? "ok" : "not ok", " 1\n";
 print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 2\n";
@@ -11,3 +11,5 @@ print +(hex('80000000') == 0x80000000) ? "ok" : "not ok", " 6\n";
 print +(oct('1234') == 668) ? "ok" : "not ok", " 7\n";
 print +(hex('1234') == 4660) ? "ok" : "not ok", " 8\n";
 print +(hex('0x1234') == 0x1234) ? "ok" : "not ok", " 9\n";
+print +(oct('b11100') == 28) ? "ok" : "not ok", " 10\n";
+print +(oct('b101010') == 0b101010) ? "ok" : "not ok", " 11\n";

diff --git a/t/op/sprintf.t b/t/op/sprintf.t
index b9b4751..ef5b94c 100755 (executable)
--- a/t/op/sprintf.t
+++ b/t/op/sprintf.t
@@ -14,8 +14,8 @@ $SIG{__WARN__} = sub {
 };
 
 $w = 0;
-$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f","hi",123,0,456,0,ord('A'),3.0999);
-if ($x eq ' hi 123 %foo   456 0A3.1' && $w == 0) {
+$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f %b","hi",123,0,456,0,ord('A'),3.0999,11);
+if ($x eq ' hi 123 %foo   456 0A3.1 1011' && $w == 0) {
     print "ok 1\n";
 } else {
     print "not ok 1 '$x'\n";

diff --git a/t/pragma/warn/util b/t/pragma/warn/util
index 649a292..b63f89e 100644 (file)
--- a/t/pragma/warn/util
+++ b/t/pragma/warn/util
@@ -6,6 +6,8 @@
      Illegal hex digit ignored 
        my $a = hex "0xv9" ;
 
+     Illegal binary digit ignored
+      my $a = oct "0b9" ;
 
 __END__
 # util.c
@@ -19,3 +21,9 @@ use warning 'unsafe' ;
 *a =  hex "0xv9" ;
 EXPECT
 Illegal hex digit ignored at - line 3.
+########
+# util.c
+use warning 'unsafe' ;
+*a =  oct "0b9" ;
+EXPECT
+Illegal binary digit ignored at - line 3.

diff --git a/toke.c b/toke.c
index b9fa540..f91b4cd 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -5899,7 +5899,7 @@ scan_str(char *start)
 
   Read a number in any of the formats that Perl accepts:
 
-  0(x[0-7A-F]+)|([0-7]+)
+  0(x[0-7A-F]+)|([0-7]+)|(b[01])
   [\d_]+(\.[\d_]*)?[Ee](\d+)
 
   Underbars (_) are allowed in decimal numbers.  If -w is on,
@@ -5933,18 +5933,19 @@ scan_num(char *start)
       croak("panic: scan_num");
       
     /* if it starts with a 0, it could be an octal number, a decimal in
-       0.13 disguise, or a hexadecimal number.
+       0.13 disguise, or a hexadecimal number, or a binary number.
     */
     case '0':
        {
          /* variables:
             u          holds the "number so far"
-            shift      the power of 2 of the base (hex == 4, octal == 3)
+            shift      the power of 2 of the base
+                       (hex == 4, octal == 3, binary == 1)
             overflowed was the number more than we can hold?
 
             Shift is used when we add a digit.  It also serves as an "are
-            we in octal or hex?" indicator to disallow hex characters when
-            in octal mode.
+            we in octal/hex/binary?" indicator to disallow hex characters
+            when in octal mode.
           */
            UV u;
            I32 shift;
@@ -5954,6 +5955,9 @@ scan_num(char *start)
            if (s[1] == 'x') {
                shift = 4;
                s += 2;
+           } else if (s[1] == 'b') {
+               shift = 1;
+               s += 2;
            }
            /* check for a decimal in disguise */
            else if (s[1] == '.')
@@ -5963,7 +5967,7 @@ scan_num(char *start)
                shift = 3;
            u = 0;
 
-           /* read the rest of the octal number */
+           /* read the rest of the number */
            for (;;) {
                UV n, b;        /* n is used in the overflow test, b is the digit we're adding on */
 
@@ -5980,13 +5984,21 @@ scan_num(char *start)
 
                /* 8 and 9 are not octal */
                case '8': case '9':
-                   if (shift != 4)
+                   if (shift == 3)
                        yyerror("Illegal octal digit");
+                   else
+                       if (shift == 1)
+                           yyerror("Illegal binary digit");
                    /* FALL THROUGH */
 
                /* octal digits */
-               case '0': case '1': case '2': case '3': case '4':
+               case '2': case '3': case '4':
                case '5': case '6': case '7':
+                   if (shift == 1)
+                       yyerror("Illegal binary digit");
+                   /* FALL THROUGH */
+
+               case '0': case '1':
                    b = *s++ & 15;              /* ASCII digit -> value of digit */
                    goto digit;
 
@@ -6007,7 +6019,8 @@ scan_num(char *start)
                    if (!overflowed && (n >> shift) != u
                        && !(PL_hints & HINT_NEW_BINARY)) {
                        warn("Integer overflow in %s number",
-                            (shift == 4) ? "hex" : "octal");
+                            (shift == 4) ? "hex"
+                            : ((shift == 3) ? "octal" : "binary"));
                        overflowed = TRUE;
                    }
                    u = n | b;          /* add the digit to the end */

diff --git a/util.c b/util.c
index cc4591e..4b3d32d 100644 (file)
--- a/util.c
+++ b/util.c
@@ -2395,6 +2395,29 @@ same_dirent(char *a, char *b)
 #endif /* !HAS_RENAME */
 
 UV
+scan_bin(char *start, I32 len, I32 *retlen)
+{
+    register char *s = start;
+    register UV retval = 0;
+    bool overflowed = FALSE;
+    while (len && *s >= '0' && *s <= '1') {
+      register UV n = retval << 1;
+      if (!overflowed && (n >> 1) != retval) {
+          warn("Integer overflow in binary number");
+          overflowed = TRUE;
+      }
+      retval = n | (*s++ - '0');
+      len--;
+    }
+    if (len && (*s >= '2' || *s <= '9')) {
+      dTHR;
+      if (ckWARN(WARN_UNSAFE))
+          warner(WARN_UNSAFE, "Illegal binary digit ignored");
+    }
+    *retlen = s - start;
+    return retval;
+}
+UV
 scan_oct(char *start, I32 len, I32 *retlen)
 {
     register char *s = start;