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

4 files changed, 30 insertions, 10 deletions

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;