REV2: Binary number support

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

p4raw-id: //depot/cfgperl@2546

11 files changed, 84 insertions, 14 deletions

diff --git a/pod/perldata.pod b/pod/perldata.pod
index 9e41c2c368..7b9a323338 100644
--- 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 aa3539be8a..bdcb7cf40c 100644
--- 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 300379f6d7..c78161141a 100644
--- 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 004ba8c56f..44114e79f3 100644
--- 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 b22451a7da..333bd239e3 100644
--- 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 fdeed681f5..6d900cee0e 100644
--- 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 66230898ab..06bf8db660 100755
--- 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 b9b4751c79..ef5b94cb11 100755
--- 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 649a2929ce..b63f89e139 100644
--- 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 b9fa540103..f91b4cdcc9 100644
--- 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 cc4591e26b..4b3d32d038 100644
--- 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;