Tcl Source Code

Artifact Content
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Artifact 8c65b21f2b96f3a575bbdabd65acc443c5b76572:

Attachment "binary_flag.patch" to ticket [1565751fff] added by patthoyts 2006-09-29 04:31:32.
Index: generic/tclBinary.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBinary.c,v
retrieving revision 1.29
diff -c -r1.29 tclBinary.c
*** generic/tclBinary.c	10 Aug 2006 12:15:30 -0000	1.29
--- generic/tclBinary.c	28 Sep 2006 21:26:05 -0000
***************
*** 14,19 ****
--- 14,20 ----
   */
  
  #include "tclInt.h"
+ #include "tclTomMath.h"
  
  #include <math.h>
  
***************
*** 26,31 ****
--- 27,39 ----
  #define BINARY_NOCOUNT -2	/* No count was specified in format. */
  
  /*
+  * The following flags may be ORed together and returned by GetFormatSpec
+  */
+ 
+ #define BINARY_SIGNED 0		/* Field to be read as signed data */
+ #define BINARY_UNSIGNED 1	/* Field to be read as unsigned data */
+ 
+ /*
   * The following defines the maximum number of different (integer) numbers
   * placed in the object cache by 'binary scan' before it bails out and
   * switches back to Plan A (creating a new object for each value.)
***************
*** 54,62 ****
  			    Tcl_Obj *src, unsigned char **cursorPtr);
  static void		FreeByteArrayInternalRep(Tcl_Obj *objPtr);
  static int		GetFormatSpec(char **formatPtr, char *cmdPtr,
! 			    int *countPtr);
  static Tcl_Obj *	ScanNumber(unsigned char *buffer, int type,
! 			    Tcl_HashTable **numberCachePtr);
  static int		SetByteArrayFromAny(Tcl_Interp *interp,
  			    Tcl_Obj *objPtr);
  static void		UpdateStringOfByteArray(Tcl_Obj *listPtr);
--- 62,70 ----
  			    Tcl_Obj *src, unsigned char **cursorPtr);
  static void		FreeByteArrayInternalRep(Tcl_Obj *objPtr);
  static int		GetFormatSpec(char **formatPtr, char *cmdPtr,
! 			    int *countPtr, int *flagsPtr);
  static Tcl_Obj *	ScanNumber(unsigned char *buffer, int type,
! 			    int flags, Tcl_HashTable **numberCachePtr);
  static int		SetByteArrayFromAny(Tcl_Interp *interp,
  			    Tcl_Obj *objPtr);
  static void		UpdateStringOfByteArray(Tcl_Obj *listPtr);
***************
*** 563,568 ****
--- 571,577 ----
      char cmd;			/* Current format character. */
      int count;			/* Count associated with current format
  				 * character. */
+     int flags;			/* Format field flags */
      char *format;		/* Pointer to current position in format
  				 * string. */
      Tcl_Obj *resultPtr = NULL;	/* Object holding result buffer. */
***************
*** 608,614 ****
  	length = 0;
  	while (*format != '\0') {
  	    str = format;
! 	    if (!GetFormatSpec(&format, &cmd, &count)) {
  		break;
  	    }
  	    switch (cmd) {
--- 617,624 ----
  	length = 0;
  	while (*format != '\0') {
  	    str = format;
! 	    flags = 0;
! 	    if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
  		break;
  	    }
  	    switch (cmd) {
***************
*** 770,776 ****
  	cursor = buffer;
  	maxPos = cursor;
  	while (*format != 0) {
! 	    if (!GetFormatSpec(&format, &cmd, &count)) {
  		break;
  	    }
  	    if ((count == 0) && (cmd != '@')) {
--- 780,787 ----
  	cursor = buffer;
  	maxPos = cursor;
  	while (*format != 0) {
! 	    flags = 0;
! 	    if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
  		break;
  	    }
  	    if ((count == 0) && (cmd != '@')) {
***************
*** 1028,1034 ****
  	offset = 0;
  	while (*format != '\0') {
  	    str = format;
! 	    if (!GetFormatSpec(&format, &cmd, &count)) {
  		goto done;
  	    }
  	    switch (cmd) {
--- 1039,1046 ----
  	offset = 0;
  	while (*format != '\0') {
  	    str = format;
! 	    flags = 0;
! 	    if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
  		goto done;
  	    }
  	    switch (cmd) {
***************
*** 1240,1246 ****
  		    if ((length - offset) < size) {
  			goto done;
  		    }
! 		    valuePtr = ScanNumber(buffer+offset, cmd, &numberCachePtr);
  		    offset += size;
  		} else {
  		    if (count == BINARY_ALL) {
--- 1252,1258 ----
  		    if ((length - offset) < size) {
  			goto done;
  		    }
! 		    valuePtr = ScanNumber(buffer+offset, cmd, flags, &numberCachePtr);
  		    offset += size;
  		} else {
  		    if (count == BINARY_ALL) {
***************
*** 1252,1258 ****
  		    valuePtr = Tcl_NewObj();
  		    src = buffer+offset;
  		    for (i = 0; i < count; i++) {
! 			elementPtr = ScanNumber(src, cmd, &numberCachePtr);
  			src += size;
  			Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
  		    }
--- 1264,1270 ----
  		    valuePtr = Tcl_NewObj();
  		    src = buffer+offset;
  		    for (i = 0; i < count; i++) {
! 			elementPtr = ScanNumber(src, cmd, flags, &numberCachePtr);
  			src += size;
  			Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
  		    }
***************
*** 1373,1379 ****
  GetFormatSpec(
      char **formatPtr,		/* Pointer to format string. */
      char *cmdPtr,		/* Pointer to location of command char. */
!     int *countPtr)		/* Pointer to repeat count value. */
  {
      /*
       * Skip any leading blanks.
--- 1385,1392 ----
  GetFormatSpec(
      char **formatPtr,		/* Pointer to format string. */
      char *cmdPtr,		/* Pointer to location of command char. */
!     int *countPtr,		/* Pointer to repeat count value. */
!     int *flagsPtr)		/* Pointer to field flags */
  {
      /*
       * Skip any leading blanks.
***************
*** 1397,1402 ****
--- 1410,1419 ----
  
      *cmdPtr = **formatPtr;
      (*formatPtr)++;
+     if (**formatPtr == 'u') {
+ 	(*formatPtr)++;
+ 	(*flagsPtr) |= BINARY_UNSIGNED;
+     }
      if (**formatPtr == '*') {
  	(*formatPtr)++;
  	(*countPtr) = BINARY_ALL;
***************
*** 1778,1783 ****
--- 1795,1801 ----
  ScanNumber(
      unsigned char *buffer,	/* Buffer to scan number from. */
      int type,			/* Format character from "binary scan" */
+     int flags,			/* Format field flags */
      Tcl_HashTable **numberCachePtrPtr)
  				/* Place to look for cache of scanned
  				 * value objects, or NULL if too many
***************
*** 1794,1799 ****
--- 1812,1818 ----
       * the exact size of the integer types. So, we have to handle sign
       * extension explicitly by checking the high bit and padding with 1's as
       * needed.
+      * This practice is disabled if the BINARY_UNSIGNED flag is set.
       */
  
      switch (type) {
***************
*** 1806,1813 ****
  	 */
  
  	value = buffer[0];
! 	if (value & 0x80) {
! 	    value |= -0x100;
  	}
  	goto returnNumericObject;
  
--- 1825,1834 ----
  	 */
  
  	value = buffer[0];
! 	if (!(flags & BINARY_UNSIGNED)) {
! 	    if (value & 0x80) {
! 		value |= -0x100;
! 	    }
  	}
  	goto returnNumericObject;
  
***************
*** 1824,1831 ****
  	} else {
  	    value = (long) (buffer[1] + (buffer[0] << 8));
  	}
! 	if (value & 0x8000) {
! 	    value |= -0x10000;
  	}
  	goto returnNumericObject;
  
--- 1845,1854 ----
  	} else {
  	    value = (long) (buffer[1] + (buffer[0] << 8));
  	}
! 	if (!(flags & BINARY_UNSIGNED)) {
! 	    if (value & 0x8000) {
! 		value |= -0x10000;
! 	    }
  	}
  	goto returnNumericObject;
  
***************
*** 1851,1861 ****
  	/*
  	 * Check to see if the value was sign extended properly on systems
  	 * where an int is more than 32-bits.
  	 */
  
! 	if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
! 	    value -= (((unsigned int)1)<<31);
! 	    value -= (((unsigned int)1)<<31);
  	}
  
      returnNumericObject:
--- 1874,1890 ----
  	/*
  	 * Check to see if the value was sign extended properly on systems
  	 * where an int is more than 32-bits.
+ 	 * We avoid caching unsigned integers as we cannot distinguish between
+ 	 * 32bit signed and unsigned in the hash (short and char are ok).
  	 */
  
! 	if ((flags & BINARY_UNSIGNED)) {
! 	    return Tcl_NewWideIntObj((unsigned long)value);
! 	} else {
! 	    if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
! 		value -= (((unsigned int)1)<<31);
! 		value -= (((unsigned int)1)<<31);
! 	    }
  	}
  
      returnNumericObject:
***************
*** 1920,1926 ****
  		    | (((Tcl_WideUInt) buffer[1]) << 48)
  		    | (((Tcl_WideUInt) buffer[0]) << 56);
  	}
! 	return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
  
  	/*
  	 * Do not cache double values; they are already too large to use as
--- 1949,1964 ----
  		    | (((Tcl_WideUInt) buffer[1]) << 48)
  		    | (((Tcl_WideUInt) buffer[0]) << 56);
  	}
! 	if (flags & BINARY_UNSIGNED) {
! 	    Tcl_Obj *bigObj = NULL;
! 	    mp_int big;
! 
! 	    TclBNInitBignumFromWideUInt(&big, uwvalue);
! 	    bigObj = Tcl_NewBignumObj(&big);
! 	    return bigObj;
! 	} else {
! 	    return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
! 	}
  
  	/*
  	 * Do not cache double values; they are already too large to use as
Index: tests/binary.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/binary.test,v
retrieving revision 1.28
diff -c -r1.28 binary.test
*** tests/binary.test	5 Apr 2006 15:17:39 -0000	1.28
--- tests/binary.test	28 Sep 2006 21:26:06 -0000
***************
*** 905,910 ****
--- 905,934 ----
      set arg2 bar
      list [binary scan \x70\x87\x05 c2c* arg1 arg2] $arg1 $arg2
  } {2 {112 -121} 5}
+ test binary-26.11 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1}
+     list [binary scan \x52\xa3 cu* arg1] $arg1
+ } {1 {82 163}}
+ test binary-26.12 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1}
+     list [binary scan \x52\xa3 cu arg1] $arg1
+ } {1 82}
+ test binary-26.13 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1}
+     list [binary scan \xff cu arg1] $arg1
+ } {1 255}
+ test binary-26.14 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1 arg2}
+     set arg1 foo
+     set arg2 bar
+     list [binary scan \x80\x80 cuc arg1 arg2] $arg1 $arg2
+ } {2 128 -128}
+ test binary-26.15 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1 arg2}
+     set arg1 foo
+     set arg2 bar
+     list [binary scan \x80\x80 ccu arg1 arg2] $arg1 $arg2
+ } {2 -128 128}
  
  test binary-27.1 {Tcl_BinaryObjCmd: scan} {
      list [catch {binary scan abc s} msg] $msg
***************
*** 945,950 ****
--- 969,990 ----
      set arg2 bar
      list [binary scan \x52\xa3\x53\x54\x05 s2c* arg1 arg2] $arg1 $arg2
  } {2 {-23726 21587} 5}
+ test binary-27.10 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1}
+     list [binary scan \x52\xa3\x53\x54 su* arg1] $arg1
+ } {1 {41810 21587}}
+ test binary-27.11 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1 arg2}
+     set arg1 foo
+     set arg2 bar
+     list [binary scan \xff\xff\xff\xff sus arg1 arg2] $arg1 $arg2
+ } {2 65535 -1}
+ test binary-27.12 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1 arg2}
+     set arg1 foo
+     set arg2 bar
+     list [binary scan \xff\xff\xff\xff ssu arg1 arg2] $arg1 $arg2
+ } {2 -1 65535}
  
  test binary-28.1 {Tcl_BinaryObjCmd: scan} {
      list [catch {binary scan abc S} msg] $msg
***************
*** 985,990 ****
--- 1025,1038 ----
      set arg2 bar
      list [binary scan \x52\xa3\x53\x54\x05 S2c* arg1 arg2] $arg1 $arg2
  } {2 {21155 21332} 5}
+ test binary-28.10 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1}
+     list [binary scan \x52\xa3\x53\x54 Su* arg1] $arg1
+ } {1 {21155 21332}}
+ test binary-28.11 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1}
+     list [binary scan \xa3\x52\x54\x53 Su* arg1] $arg1
+ } {1 {41810 21587}}
  
  test binary-29.1 {Tcl_BinaryObjCmd: scan} {
      list [catch {binary scan abc i} msg] $msg
***************
*** 1025,1030 ****
--- 1073,1090 ----
      set arg2 bar
      list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 i2c* arg1 arg2] $arg1 $arg2
  } {2 {1414767442 67305985} 5}
+ test binary-29.10 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1 arg2}
+     list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff iui arg1 arg2] $arg1 $arg2
+ } {2 4294967295 -1}
+ test binary-29.11 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1 arg2}
+     list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff iiu arg1 arg2] $arg1 $arg2
+ } {2 -1 4294967295}
+ test binary-29.12 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1 arg2}
+     list [binary scan \x80\x00\x00\x00\x00\x00\x00\x80 iuiu arg1 arg2] $arg1 $arg2
+ } {2 128 2147483648}
  
  test binary-30.1 {Tcl_BinaryObjCmd: scan} {
      list [catch {binary scan abc I} msg] $msg
***************
*** 1065,1070 ****
--- 1125,1142 ----
      set arg2 bar
      list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 I2c* arg1 arg2] $arg1 $arg2
  } {2 {1386435412 16909060} 5}
+ test binary-30.10 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1 arg2}
+     list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff IuI arg1 arg2] $arg1 $arg2
+ } {2 4294967295 -1}
+ test binary-30.11 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1 arg2}
+     list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff IIu arg1 arg2] $arg1 $arg2
+ } {2 -1 4294967295}
+ test binary-30.12 {Tcl_BinaryObjCmd: scan} {
+     catch {unset arg1 arg2}
+     list [binary scan \x80\x00\x00\x00\x00\x00\x00\x80 IuIu arg1 arg2] $arg1 $arg2
+ } {2 2147483648 128}
  
  test binary-31.1 {Tcl_BinaryObjCmd: scan} {
      list [catch {binary scan abc f} msg] $msg
***************
*** 1384,1389 ****
--- 1456,1481 ----
      catch {unset arg1}
      list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 I5 arg1] $arg1
  } {1 {16843010 -2130640639 25297153 16876033 16843137}}
+ test binary-39.6 {ScanNumber: no sign extension} {
+     catch {unset arg1}
+     list [binary scan \x52\xa3 cu2 arg1] $arg1
+ } {1 {82 163}}
+ test binary-39.7 {ScanNumber: no sign extension} {
+     catch {unset arg1}
+     list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 su4 arg1] $arg1
+ } {1 {513 33025 386 33409}}
+ test binary-39.8 {ScanNumber: no sign extension} {
+     catch {unset arg1}
+     list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 Su4 arg1] $arg1
+ } {1 {258 385 33281 33154}}
+ test binary-39.9 {ScanNumber: no sign extension} {
+     catch {unset arg1}
+     list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 iu5 arg1] $arg1
+ } {1 {33620225 16843137 16876033 25297153 2164326657}}
+ test binary-39.10 {ScanNumber: no sign extension} {
+     catch {unset arg1}
+     list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 Iu5 arg1] $arg1
+ } {1 {16843010 2164326657 25297153 16876033 16843137}}
  
  test binary-40.3 {ScanNumber: NaN} \
      -body {
***************
*** 1463,1468 ****
--- 1555,1580 ----
      binary scan [binary format W [expr {wide(3) << 31}]] W x
      set x
  } 6442450944
+ test binary-43.5 {Tcl_BinaryObjCmd: scan wide int} {} {
+     catch {unset arg1}
+     list [binary scan \x80[string repeat \x00 7] W arg1] $arg1
+ } {1 -9223372036854775808}
+ test binary-43.6 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
+     catch {unset arg1}
+     list [binary scan \x80[string repeat \x00 7] Wu arg1] $arg1
+ } {1 9223372036854775808}
+ test binary-43.7 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
+     catch {unset arg1}
+     list [binary scan [string repeat \x00 7]\x80 wu arg1] $arg1
+ } {1 9223372036854775808}
+ test binary-43.8 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
+     catch {unset arg1 arg2}
+     list [binary scan \x80[string repeat \x00 7]\x80[string repeat \x00 7] WuW arg1 arg2] $arg1 $arg2
+ } {2 9223372036854775808 -9223372036854775808}
+ test binary-43.9 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
+     catch {unset arg1 arg2}
+     list [binary scan [string repeat \x00 7]\x80[string repeat \x00 7]\x80 wuw arg1 arg2] $arg1 $arg2
+ } {2 9223372036854775808 -9223372036854775808}
  
  test binary-45.1 {Tcl_BinaryObjCmd: combined wide int handling} {
      binary scan [binary format sws 16450 -1 19521] c* x