TIP #343 IMPLEMENTATION - A Binary Specifier for [format/scan]

9 files changed, 68 insertions, 16 deletions

diff --git a/ChangeLog b/ChangeLog
index 27d1f3c..ea3da59 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+2008-12-10  Alexandre Ferrieux 	<ferrieux@users.sourceforge.net>
+
+	TIP #343 IMPLEMENTATION - A Binary Specifier for [format/scan]
+
+	* doc/format.n
+	* doc/scan.n
+	* generic/tclInt.h
+	* generic/tclScan.c
+	* generic/tclStrToD.c
+	* generic/tclStringObj.c
+	* tests/format.test
+	* tests/scan.test
+	
 2008-12-10  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
 
 	TIP #341 IMPLEMENTATION
diff --git a/doc/format.n b/doc/format.n
index dab6b8b..efb3a4d 100644
--- a/doc/format.n
+++ b/doc/format.n
@@ -5,7 +5,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: format.n,v 1.21 2008/10/17 10:22:25 dkf Exp $
+'\" RCS: @(#) $Id: format.n,v 1.22 2008/12/10 18:21:46 ferrieux Exp $
 '\" 
 .so man.macros
 .TH format n 8.1 Tcl "Tcl Built-In Commands"
@@ -87,6 +87,8 @@ Requests an alternate output form. For \fBo\fR and \fBO\fR
 conversions it guarantees that the first digit is always \fB0\fR.
 For \fBx\fR or \fBX\fR conversions, \fB0x\fR or \fB0X\fR (respectively)
 will be added to the beginning of the result unless it is zero.
+For \fBb\fR conversions, \fB0b\fR
+will be added to the beginning of the result unless it is zero.
 For all floating-point conversions (\fBe\fR, \fBE\fR, \fBf\fR,
 \fBg\fR, and \fBG\fR) it guarantees that the result always 
 has a decimal point.
@@ -161,6 +163,9 @@ for \fBx\fR and
 .QW 0123456789ABCDEF
 for \fBX\fR).
 .TP 10
+\fBb\fR
+Convert integer to binary string, using digits 0 and 1.
+.TP 10
 \fBc\fR
 Convert integer to the Unicode character it represents.
 .TP 10
@@ -203,6 +208,7 @@ which will then be converted to the corresponding character value.
 .IP [3]
 The size modifiers are ignored when formatting floating-point values.
 The \fBll\fR modifier has no \fBsprintf\fR counterpart.
+The \fBb\fR specifier has no \fBsprintf\fR counterpart.
 .SH EXAMPLES
 .PP
 Convert the numeric value of a UNICODE character to the character
diff --git a/doc/scan.n b/doc/scan.n
index 4612467..f37ca59 100644
--- a/doc/scan.n
+++ b/doc/scan.n
@@ -6,7 +6,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: scan.n,v 1.26 2008/10/17 10:22:25 dkf Exp $
+'\" RCS: @(#) $Id: scan.n,v 1.27 2008/12/10 18:21:46 ferrieux Exp $
 '\" 
 .so man.macros
 .TH scan n 8.4 Tcl "Tcl Built-In Commands"
@@ -104,6 +104,12 @@ The input substring must be a hexadecimal integer.
 It is read in and the integer value is stored in the variable,
 truncated as required by the size modifier value.
 .TP 10
+\fBb\fR
+.
+The input substring must be a binary integer.
+It is read in and the integer value is stored in the variable,
+truncated as required by the size modifier value.
+.TP 10
 \fBu\fR
 .
 The input substring must be a decimal integer.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 73a8bab..e373a6c 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.408 2008/12/05 14:27:36 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.409 2008/12/10 18:21:47 ferrieux Exp $
  */
 
 #ifndef _TCLINT
@@ -2461,6 +2461,8 @@ typedef struct ProcessGlobalValue {
 				/* Use [scan] rules dealing with 0? prefixes */
 #define TCL_PARSE_NO_WHITESPACE		32
 				/* Reject leading/trailing whitespace */
+#define TCL_PARSE_BINARY_ONLY	64
+				/* Parse binary even without prefix */
 
 /*
  *----------------------------------------------------------------------
diff --git a/generic/tclScan.c b/generic/tclScan.c
index a732b67..d05cb8f 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclScan.c,v 1.29 2008/07/19 22:50:42 nijtmans Exp $
+ * RCS: @(#) $Id: tclScan.c,v 1.30 2008/12/10 18:21:47 ferrieux Exp $
  */
 
 #include "tclInt.h"
@@ -405,6 +405,7 @@ ValidateFormat(
 	case 'i':
 	case 'o':
 	case 'x':
+	case 'b':
 	    break;
 	case 'u':
 	    if (flags & SCAN_BIG) {
@@ -732,6 +733,10 @@ Tcl_ScanObjCmd(
 	    op = 'i';
 	    parseFlag |= TCL_PARSE_HEXADECIMAL_ONLY;
 	    break;
+	case 'b':
+	    op = 'i';
+	    parseFlag |= TCL_PARSE_BINARY_ONLY;
+	    break;
 	case 'u':
 	    op = 'i';
 	    parseFlag |= TCL_PARSE_DECIMAL_ONLY;
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 2b4cde7..8eec7b4 100755
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -14,7 +14,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclStrToD.c,v 1.34 2008/04/01 20:08:22 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclStrToD.c,v 1.35 2008/12/10 18:21:47 ferrieux Exp $
  *
  *----------------------------------------------------------------------
  */
@@ -369,6 +369,8 @@ TclParseNumber(
 		break;
 	    } else if (flags & TCL_PARSE_HEXADECIMAL_ONLY) {
 		goto zerox;
+	    } else if (flags & TCL_PARSE_BINARY_ONLY) {
+		goto zerob;
 	    } else if (flags & TCL_PARSE_OCTAL_ONLY) {
 		goto zeroo;
 	    } else if (isdigit(UCHAR(c))) {
@@ -395,9 +397,9 @@ TclParseNumber(
 	case ZERO:
 	    /*
 	     * Scanned a leading zero (perhaps with a + or -). Acceptable
-	     * inputs are digits, period, X, and E. If 8 or 9 is encountered,
+	     * inputs are digits, period, X, b, and E. If 8 or 9 is encountered,
 	     * the number can't be octal. This state and the OCTAL state
-	     * differ only in whether they recognize 'X'.
+	     * differ only in whether they recognize 'X' and 'b'.
 	     */
 
 	    acceptState = state;
@@ -417,6 +419,9 @@ TclParseNumber(
 		state = ZERO_B;
 		break;
 	    }
+	    if (flags & TCL_PARSE_BINARY_ONLY) {
+		goto zerob;
+	    }
 	    if (c == 'o' || c == 'O') {
 		explicitOctal = 1;
 		state = ZERO_O;
@@ -602,6 +607,7 @@ TclParseNumber(
 	    acceptPoint = p;
 	    acceptLen = len;
 	case ZERO_B:
+	zerob:
 	    if (c == '0') {
 		++numTrailZeros;
 		state = BINARY;
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 6d5f96a..1930ad0 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -33,7 +33,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclStringObj.c,v 1.74 2008/10/26 18:34:04 dkf Exp $ */
+ * RCS: @(#) $Id: tclStringObj.c,v 1.75 2008/12/10 18:21:47 ferrieux Exp $ */
 
 #include "tclInt.h"
 #include "tommath.h"
@@ -1943,7 +1943,8 @@ Tcl_AppendFormatToObj(
 	case 'd':
 	case 'o':
 	case 'x':
-	case 'X': {
+	case 'X':
+	case 'b': {
 	    short int s = 0;	/* Silence compiler warning; only defined and
 				 * used when useShort is true. */
 	    long l;
@@ -2016,6 +2017,9 @@ Tcl_AppendFormatToObj(
 		case 'X':
 		    Tcl_AppendToObj(segment, "0x", 2);
 		    break;
+		case 'b':
+		    Tcl_AppendToObj(segment, "0b", 2);
+		    break;
 		}
 	    }
 
@@ -2074,7 +2078,8 @@ Tcl_AppendFormatToObj(
 	    case 'u':
 	    case 'o':
 	    case 'x':
-	    case 'X': {
+	    case 'X':
+	    case 'b': {
 		Tcl_WideUInt bits = (Tcl_WideUInt)0;
 		int length, numBits = 4, numDigits = 0, base = 16;
 		int index = 0, shift = 0;
@@ -2083,10 +2088,12 @@ Tcl_AppendFormatToObj(
 
 		if (ch == 'u') {
 		    base = 10;
-		}
-		if (ch == 'o') {
+		} else if (ch == 'o') {
 		    base = 8;
 		    numBits = 3;
+		} else if (ch=='b') {
+		    base = 2;
+		    numBits = 1;
 		}
 		if (useShort) {
 		    unsigned short int us = (unsigned short int) s;
diff --git a/tests/format.test b/tests/format.test
index 1b8869a..d2cbcde 100644
--- a/tests/format.test
+++ b/tests/format.test
@@ -10,7 +10,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: format.test,v 1.27 2008/07/19 22:50:39 nijtmans Exp $
+# RCS: @(#) $Id: format.test,v 1.28 2008/12/10 18:21:47 ferrieux Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -77,6 +77,9 @@ test format-1.11 {integer formatting} longIs32bit {
 test format-1.11.1 {integer formatting} longIs64bit {
     format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1
 } {06                   042                  041033               01777777777777777777764}
+test format-1.12 {integer formatting} {
+    format "%b %#b %llb" 5 5 [expr {2**100}]
+} {101 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
 
 test format-2.1 {string formatting} {
     format "%s %s %c %s" abcd {This is a very long test string.} 120 x
diff --git a/tests/scan.test b/tests/scan.test
index ef40d4b..4296366 100644
--- a/tests/scan.test
+++ b/tests/scan.test
@@ -11,7 +11,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: scan.test,v 1.22 2008/07/19 22:50:39 nijtmans Exp $
+# RCS: @(#) $Id: scan.test,v 1.23 2008/12/10 18:21:47 ferrieux Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -248,10 +248,14 @@ test scan-4.40.2 {Tcl_ScanObjCmd, base-16 integer scanning} {
     catch {unset x}
     list [scan {xF} {%x} x] [info exists x]
 } {0 0}
+test scan-4.40.3 {Tcl_ScanObjCmd, base-2 integer scanning} {
+    set x {}
+    list [scan {1001 0b101 100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} {%b %b %llb} x y z] $x $y $z
+} {3 9 5 340282366920938463463374607431768211456}
 test scan-4.41 {Tcl_ScanObjCmd, base-unknown integer scanning} {
     set x {}
-    list [scan {10 010 0x10} {%i%i%i} x y z] $x $y $z
-} {3 10 8 16}
+    list [scan {10 010 0x10 0b10} {%i%i%i%i} x y z t] $x $y $z $t
+} {4 10 8 16 0}
 test scan-4.42 {Tcl_ScanObjCmd, base-unknown integer scanning} {
     set x {}
     list [scan {10 010 0X10} {%i%i%i} x y z] $x $y $z