summaryrefslogtreecommitdiffstats
path: root/generic/tclBinary.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclBinary.c')
-rw-r--r--generic/tclBinary.c2351
1 files changed, 1316 insertions, 1035 deletions
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 8d258b3..f321b28 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -1,4 +1,4 @@
-/*
+/*
* tclBinary.c --
*
* This file contains the implementation of the "binary" Tcl built-in
@@ -7,12 +7,13 @@
* Copyright (c) 1997 by Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
-#include "tclPort.h"
+#include "tommath.h"
+
#include <math.h>
/*
@@ -24,21 +25,27 @@
#define BINARY_NOCOUNT -2 /* No count was specified in format. */
/*
- * 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.) Theoretically, it would be possible to keep the cache
- * about for the values that are already in it, but that makes the
- * code slower in practise when overflow happens, and makes little
- * odds the rest of the time (as measured on my machine.) It is also
- * slower (on the sample I tried at least) to grow the cache to hold
- * all items we might want to put in it; presumably the extra cost of
- * managing the memory for the enlarged table outweighs the benefit
- * from allocating fewer objects. This is probably because as the
- * number of objects increases, the likelihood of reuse of any
- * particular one drops, and there is very little gain from larger
- * maximum cache sizes (the value below is chosen to allow caching to
- * work in full with conversion of bytes.) - DKF
+ * 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.)
+ * Theoretically, it would be possible to keep the cache about for the values
+ * that are already in it, but that makes the code slower in practise when
+ * overflow happens, and makes little odds the rest of the time (as measured
+ * on my machine.) It is also slower (on the sample I tried at least) to grow
+ * the cache to hold all items we might want to put in it; presumably the
+ * extra cost of managing the memory for the enlarged table outweighs the
+ * benefit from allocating fewer objects. This is probably because as the
+ * number of objects increases, the likelihood of reuse of any particular one
+ * drops, and there is very little gain from larger maximum cache sizes (the
+ * value below is chosen to allow caching to work in full with conversion of
+ * bytes.) - DKF
*/
#define BINARY_SCAN_MAX_CACHE 260
@@ -47,46 +54,46 @@
* Prototypes for local procedures defined in this file:
*/
-static void DupByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
- Tcl_Obj *copyPtr));
-static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type,
- Tcl_Obj *src, unsigned char **cursorPtr));
-static void CopyNumber _ANSI_ARGS_((CONST VOID *from, VOID *to,
- unsigned int length));
-static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
-static int GetFormatSpec _ANSI_ARGS_((char **formatPtr,
- char *cmdPtr, int *countPtr));
-static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer,
- int type, Tcl_HashTable **numberCachePtr));
-static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr));
-static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr));
-static void DeleteScanNumberCache _ANSI_ARGS_((
- Tcl_HashTable *numberCachePtr));
+static void DupByteArrayInternalRep(Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr);
+static int FormatNumber(Tcl_Interp *interp, int type,
+ 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);
+static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr);
+static int NeedReversing(int format);
+static void CopyNumber(const void *from, void *to,
+ unsigned int length, int type);
/*
- * The following object type represents an array of bytes. An array of
- * bytes is not equivalent to an internationalized string. Conceptually, a
- * string is an array of 16-bit quantities organized as a sequence of properly
- * formed UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
+ * The following object type represents an array of bytes. An array of bytes
+ * is not equivalent to an internationalized string. Conceptually, a string is
+ * an array of 16-bit quantities organized as a sequence of properly formed
+ * UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
* Accessor functions are provided to convert a ByteArray to a String or a
- * String to a ByteArray. Two or more consecutive bytes in an array of bytes
+ * String to a ByteArray. Two or more consecutive bytes in an array of bytes
* may look like a single UTF-8 character if the array is casually treated as
- * a string. But obtaining the String from a ByteArray is guaranteed to
- * produced properly formed UTF-8 sequences so that there is a one-to-one
- * map between bytes and characters.
+ * a string. But obtaining the String from a ByteArray is guaranteed to
+ * produced properly formed UTF-8 sequences so that there is a one-to-one map
+ * between bytes and characters.
*
* Converting a ByteArray to a String proceeds by casting each byte in the
* array to a 16-bit quantity, treating that number as a Unicode character,
- * and storing the UTF-8 version of that Unicode character in the String.
- * For ByteArrays consisting entirely of values 1..127, the corresponding
- * String representation is the same as the ByteArray representation.
+ * and storing the UTF-8 version of that Unicode character in the String. For
+ * ByteArrays consisting entirely of values 1..127, the corresponding String
+ * representation is the same as the ByteArray representation.
*
* Converting a String to a ByteArray proceeds by getting the Unicode
- * representation of each character in the String, casting it to a
- * byte by truncating the upper 8 bits, and then storing the byte in the
- * ByteArray. Converting from ByteArray to String and back to ByteArray
- * is not lossy, but converting an arbitrary String to a ByteArray may be.
+ * representation of each character in the String, casting it to a byte by
+ * truncating the upper 8 bits, and then storing the byte in the ByteArray.
+ * Converting from ByteArray to String and back to ByteArray is not lossy, but
+ * converting an arbitrary String to a ByteArray may be.
*/
Tcl_ObjType tclByteArrayType = {
@@ -98,10 +105,10 @@ Tcl_ObjType tclByteArrayType = {
};
/*
- * The following structure is the internal rep for a ByteArray object.
- * Keeps track of how much memory has been used and how much has been
- * allocated for the byte array to enable growing and shrinking of the
- * ByteArray object with fewer mallocs.
+ * The following structure is the internal rep for a ByteArray object. Keeps
+ * track of how much memory has been used and how much has been allocated for
+ * the byte array to enable growing and shrinking of the ByteArray object with
+ * fewer mallocs.
*/
typedef struct ByteArray {
@@ -109,12 +116,12 @@ typedef struct ByteArray {
* array. */
int allocated; /* The amount of space actually allocated
* minus 1 byte. */
- unsigned char bytes[4]; /* The array of bytes. The actual size of
- * this field depends on the 'allocated' field
+ unsigned char bytes[4]; /* The array of bytes. The actual size of this
+ * field depends on the 'allocated' field
* above. */
} ByteArray;
-#define BYTEARRAY_SIZE(len) \
+#define BYTEARRAY_SIZE(len) \
((unsigned) (sizeof(ByteArray) - 4 + (len)))
#define GET_BYTEARRAY(objPtr) \
((ByteArray *) (objPtr)->internalRep.otherValuePtr)
@@ -123,34 +130,32 @@ typedef struct ByteArray {
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* Tcl_NewByteArrayObj --
*
- * This procedure is creates a new ByteArray object and initializes
- * it from the given array of bytes.
+ * This procedure is creates a new ByteArray object and initializes it
+ * from the given array of bytes.
*
* Results:
- * The newly create object is returned. This object will have no
- * initial string representation. The returned object has a ref count
- * of 0.
+ * The newly create object is returned. This object will have no initial
+ * string representation. The returned object has a ref count of 0.
*
* Side effects:
* Memory allocated for new object and copy of byte array argument.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewByteArrayObj
-
Tcl_Obj *
-Tcl_NewByteArrayObj(bytes, length)
- CONST unsigned char *bytes; /* The array of bytes used to initialize
- * the new object. */
- int length; /* Length of the array of bytes, which must
- * be >= 0. */
+Tcl_NewByteArrayObj(
+ const unsigned char *bytes, /* The array of bytes used to initialize the
+ * new object. */
+ int length) /* Length of the array of bytes, which must be
+ * >= 0. */
{
return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
}
@@ -158,11 +163,11 @@ Tcl_NewByteArrayObj(bytes, length)
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
-Tcl_NewByteArrayObj(bytes, length)
- CONST unsigned char *bytes; /* The array of bytes used to initialize
- * the new object. */
- int length; /* Length of the array of bytes, which must
- * be >= 0. */
+Tcl_NewByteArrayObj(
+ const unsigned char *bytes, /* The array of bytes used to initialize the
+ * new object. */
+ int length) /* Length of the array of bytes, which must be
+ * >= 0. */
{
Tcl_Obj *objPtr;
@@ -173,7 +178,7 @@ Tcl_NewByteArrayObj(bytes, length)
#endif /* TCL_MEM_DEBUG */
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* Tcl_DbNewByteArrayObj --
*
@@ -188,28 +193,27 @@ Tcl_NewByteArrayObj(bytes, length)
* result of calling Tcl_NewByteArrayObj.
*
* Results:
- * The newly create object is returned. This object will have no
- * initial string representation. The returned object has a ref count
- * of 0.
+ * The newly create object is returned. This object will have no initial
+ * string representation. The returned object has a ref count of 0.
*
* Side effects:
* Memory allocated for new object and copy of byte array argument.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
-Tcl_DbNewByteArrayObj(bytes, length, file, line)
- CONST unsigned char *bytes; /* The array of bytes used to initialize
- * the new object. */
- int length; /* Length of the array of bytes, which must
- * be >= 0. */
- CONST char *file; /* The name of the source file calling this
+Tcl_DbNewByteArrayObj(
+ const unsigned char *bytes, /* The array of bytes used to initialize the
+ * new object. */
+ int length, /* Length of the array of bytes, which must be
+ * >= 0. */
+ const char *file, /* The name of the source file calling this
* procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+ int line) /* Line number in the source file; used for
+ * debugging. */
{
Tcl_Obj *objPtr;
@@ -221,15 +225,15 @@ Tcl_DbNewByteArrayObj(bytes, length, file, line)
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
-Tcl_DbNewByteArrayObj(bytes, length, file, line)
- CONST unsigned char *bytes; /* The array of bytes used to initialize
- * the new object. */
- int length; /* Length of the array of bytes, which must
- * be >= 0. */
- CONST char *file; /* The name of the source file calling this
+Tcl_DbNewByteArrayObj(
+ const unsigned char *bytes, /* The array of bytes used to initialize the
+ * new object. */
+ int length, /* Length of the array of bytes, which must be
+ * >= 0. */
+ const char *file, /* The name of the source file calling this
* procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+ int line) /* Line number in the source file; used for
+ * debugging. */
{
return Tcl_NewByteArrayObj(bytes, length);
}
@@ -247,36 +251,32 @@ Tcl_DbNewByteArrayObj(bytes, length, file, line)
* None.
*
* Side effects:
- * The object's old string rep and internal rep is freed.
- * Memory allocated for copy of byte array argument.
+ * The object's old string rep and internal rep is freed. Memory
+ * allocated for copy of byte array argument.
*
*----------------------------------------------------------------------
*/
void
-Tcl_SetByteArrayObj(objPtr, bytes, length)
- Tcl_Obj *objPtr; /* Object to initialize as a ByteArray. */
- CONST unsigned char *bytes; /* The array of bytes to use as the new
+Tcl_SetByteArrayObj(
+ Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */
+ const unsigned char *bytes, /* The array of bytes to use as the new
* value. */
- int length; /* Length of the array of bytes, which must
- * be >= 0. */
+ int length) /* Length of the array of bytes, which must be
+ * >= 0. */
{
- Tcl_ObjType *typePtr;
ByteArray *byteArrayPtr;
if (Tcl_IsShared(objPtr)) {
- panic("Tcl_SetByteArrayObj called with shared object");
- }
- typePtr = objPtr->typePtr;
- if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
- (*typePtr->freeIntRepProc)(objPtr);
+ Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
+ TclFreeIntRep(objPtr);
Tcl_InvalidateStringRep(objPtr);
byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
byteArrayPtr->used = length;
byteArrayPtr->allocated = length;
- memcpy((VOID *) byteArrayPtr->bytes, (VOID *) bytes, (size_t) length);
+ memcpy(byteArrayPtr->bytes, bytes, (size_t) length);
objPtr->typePtr = &tclByteArrayType;
SET_BYTEARRAY(objPtr, byteArrayPtr);
@@ -287,28 +287,30 @@ Tcl_SetByteArrayObj(objPtr, bytes, length)
*
* Tcl_GetByteArrayFromObj --
*
- * Attempt to get the array of bytes from the Tcl object. If the
- * object is not already a ByteArray object, an attempt will be
- * made to convert it to one.
+ * Attempt to get the array of bytes from the Tcl object. If the object
+ * is not already a ByteArray object, an attempt will be made to convert
+ * it to one.
*
* Results:
* Pointer to array of bytes representing the ByteArray object.
*
* Side effects:
- * Frees old internal rep. Allocates memory for new internal rep.
+ * Frees old internal rep. Allocates memory for new internal rep.
*
*----------------------------------------------------------------------
*/
unsigned char *
-Tcl_GetByteArrayFromObj(objPtr, lengthPtr)
- Tcl_Obj *objPtr; /* The ByteArray object. */
- int *lengthPtr; /* If non-NULL, filled with length of the
+Tcl_GetByteArrayFromObj(
+ Tcl_Obj *objPtr, /* The ByteArray object. */
+ int *lengthPtr) /* If non-NULL, filled with length of the
* array of bytes in the ByteArray object. */
{
ByteArray *baPtr;
-
- SetByteArrayFromAny(NULL, objPtr);
+
+ if (objPtr->typePtr != &tclByteArrayType) {
+ SetByteArrayFromAny(NULL, objPtr);
+ }
baPtr = GET_BYTEARRAY(objPtr);
if (lengthPtr != NULL) {
@@ -322,32 +324,32 @@ Tcl_GetByteArrayFromObj(objPtr, lengthPtr)
*
* Tcl_SetByteArrayLength --
*
- * This procedure changes the length of the byte array for this
- * object. Once the caller has set the length of the array, it
- * is acceptable to directly modify the bytes in the array up until
- * Tcl_GetStringFromObj() has been called on this object.
+ * This procedure changes the length of the byte array for this object.
+ * Once the caller has set the length of the array, it is acceptable to
+ * directly modify the bytes in the array up until Tcl_GetStringFromObj()
+ * has been called on this object.
*
* Results:
* The new byte array of the specified length.
*
* Side effects:
- * Allocates enough memory for an array of bytes of the requested
- * size. When growing the array, the old array is copied to the
- * new array; new bytes are undefined. When shrinking, the
- * old array is truncated to the specified length.
+ * Allocates enough memory for an array of bytes of the requested size.
+ * When growing the array, the old array is copied to the new array; new
+ * bytes are undefined. When shrinking, the old array is truncated to the
+ * specified length.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
unsigned char *
-Tcl_SetByteArrayLength(objPtr, length)
- Tcl_Obj *objPtr; /* The ByteArray object. */
- int length; /* New length for internal byte array. */
+Tcl_SetByteArrayLength(
+ Tcl_Obj *objPtr, /* The ByteArray object. */
+ int length) /* New length for internal byte array. */
{
- ByteArray *byteArrayPtr, *newByteArrayPtr;
-
+ ByteArray *byteArrayPtr;
+
if (Tcl_IsShared(objPtr)) {
- panic("Tcl_SetObjLength called with shared object");
+ Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength");
}
if (objPtr->typePtr != &tclByteArrayType) {
SetByteArrayFromAny(NULL, objPtr);
@@ -355,13 +357,9 @@ Tcl_SetByteArrayLength(objPtr, length)
byteArrayPtr = GET_BYTEARRAY(objPtr);
if (length > byteArrayPtr->allocated) {
- newByteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
- newByteArrayPtr->used = length;
- newByteArrayPtr->allocated = length;
- memcpy((VOID *) newByteArrayPtr->bytes,
- (VOID *) byteArrayPtr->bytes, (size_t) byteArrayPtr->used);
- ckfree((char *) byteArrayPtr);
- byteArrayPtr = newByteArrayPtr;
+ byteArrayPtr = (ByteArray *) ckrealloc(
+ (char *) byteArrayPtr, BYTEARRAY_SIZE(length));
+ byteArrayPtr->allocated = length;
SET_BYTEARRAY(objPtr, byteArrayPtr);
}
Tcl_InvalidateStringRep(objPtr);
@@ -370,7 +368,7 @@ Tcl_SetByteArrayLength(objPtr, length)
}
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* SetByteArrayFromAny --
*
@@ -382,24 +380,22 @@ Tcl_SetByteArrayLength(objPtr, length)
* Side effects:
* A ByteArray object is stored as the internal rep of objPtr.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static int
-SetByteArrayFromAny(interp, objPtr)
- Tcl_Interp *interp; /* Not used. */
- Tcl_Obj *objPtr; /* The object to convert to type ByteArray. */
+SetByteArrayFromAny(
+ Tcl_Interp *interp, /* Not used. */
+ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
- Tcl_ObjType *typePtr;
int length;
char *src, *srcEnd;
unsigned char *dst;
ByteArray *byteArrayPtr;
Tcl_UniChar ch;
-
- typePtr = objPtr->typePtr;
- if (typePtr != &tclByteArrayType) {
- src = Tcl_GetStringFromObj(objPtr, &length);
+
+ if (objPtr->typePtr != &tclByteArrayType) {
+ src = TclGetStringFromObj(objPtr, &length);
srcEnd = src + length;
byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
@@ -411,9 +407,7 @@ SetByteArrayFromAny(interp, objPtr)
byteArrayPtr->used = dst - byteArrayPtr->bytes;
byteArrayPtr->allocated = length;
- if ((typePtr != NULL) && (typePtr->freeIntRepProc) != NULL) {
- (*typePtr->freeIntRepProc)(objPtr);
- }
+ TclFreeIntRep(objPtr);
objPtr->typePtr = &tclByteArrayType;
SET_BYTEARRAY(objPtr, byteArrayPtr);
}
@@ -432,26 +426,26 @@ SetByteArrayFromAny(interp, objPtr)
* None.
*
* Side effects:
- * Frees memory.
+ * Frees memory.
*
*----------------------------------------------------------------------
*/
static void
-FreeByteArrayInternalRep(objPtr)
- Tcl_Obj *objPtr; /* Object with internal rep to free. */
+FreeByteArrayInternalRep(
+ Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
ckfree((char *) GET_BYTEARRAY(objPtr));
+ objPtr->typePtr = NULL;
}
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* DupByteArrayInternalRep --
*
- * Initialize the internal representation of a ByteArray Tcl_Obj
- * to a copy of the internal representation of an existing ByteArray
- * object.
+ * Initialize the internal representation of a ByteArray Tcl_Obj to a
+ * copy of the internal representation of an existing ByteArray object.
*
* Results:
* None.
@@ -459,16 +453,16 @@ FreeByteArrayInternalRep(objPtr)
* Side effects:
* Allocates memory.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static void
-DupByteArrayInternalRep(srcPtr, copyPtr)
- Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
- Tcl_Obj *copyPtr; /* Object with internal rep to set. */
+DupByteArrayInternalRep(
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
int length;
- ByteArray *srcArrayPtr, *copyArrayPtr;
+ ByteArray *srcArrayPtr, *copyArrayPtr;
srcArrayPtr = GET_BYTEARRAY(srcPtr);
length = srcArrayPtr->used;
@@ -476,38 +470,37 @@ DupByteArrayInternalRep(srcPtr, copyPtr)
copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
copyArrayPtr->used = length;
copyArrayPtr->allocated = length;
- memcpy((VOID *) copyArrayPtr->bytes, (VOID *) srcArrayPtr->bytes,
- (size_t) length);
+ memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length);
SET_BYTEARRAY(copyPtr, copyArrayPtr);
copyPtr->typePtr = &tclByteArrayType;
}
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* UpdateStringOfByteArray --
*
- * Update the string representation for a ByteArray data object.
- * Note: This procedure does not invalidate an existing old string rep
- * so storage will be lost if this has not already been done.
+ * Update the string representation for a ByteArray data object. Note:
+ * This procedure does not invalidate an existing old string rep so
+ * storage will be lost if this has not already been done.
*
* Results:
* None.
*
* Side effects:
- * The object's string is set to a valid string that results from
- * the ByteArray-to-string conversion.
+ * The object's string is set to a valid string that results from the
+ * ByteArray-to-string conversion.
*
- * The object becomes a string object -- the internal rep is
- * discarded and the typePtr becomes NULL.
+ * The object becomes a string object -- the internal rep is discarded
+ * and the typePtr becomes NULL.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static void
-UpdateStringOfByteArray(objPtr)
- Tcl_Obj *objPtr; /* ByteArray object whose string rep to
+UpdateStringOfByteArray(
+ Tcl_Obj *objPtr) /* ByteArray object whose string rep to
* update. */
{
int i, length, size;
@@ -522,20 +515,23 @@ UpdateStringOfByteArray(objPtr)
/*
* How much space will string rep need?
*/
-
+
size = length;
- for (i = 0; i < length; i++) {
+ for (i = 0; i < length && size >= 0; i++) {
if ((src[i] == 0) || (src[i] > 127)) {
size++;
}
}
+ if (size < 0) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
dst = (char *) ckalloc((unsigned) (size + 1));
objPtr->bytes = dst;
objPtr->length = size;
if (size == length) {
- memcpy((VOID *) dst, (VOID *) src, (size_t) size);
+ memcpy(dst, src, (size_t) size);
dst[size] = '\0';
} else {
for (i = 0; i < length; i++) {
@@ -562,11 +558,11 @@ UpdateStringOfByteArray(objPtr)
*/
int
-Tcl_BinaryObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+Tcl_BinaryObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int arg; /* Index of next argument to consume. */
int value = 0; /* Current integer value to be packed.
@@ -574,19 +570,21 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
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; /* Object holding result buffer. */
+ Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */
unsigned char *buffer; /* Start of result buffer. */
unsigned char *cursor; /* Current position within result buffer. */
unsigned char *maxPos; /* Greatest position within result buffer that
* cursor has visited.*/
- char *errorString, *errorValue, *str;
+ const char *errorString;
+ char *errorValue, *str;
int offset, size, length, index;
- static CONST char *options[] = {
- "format", "scan", NULL
+ static const char *options[] = {
+ "format", "scan", NULL
};
- enum options {
+ enum options {
BINARY_FORMAT, BINARY_SCAN
};
@@ -601,760 +599,765 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
}
switch ((enum options) index) {
- case BINARY_FORMAT: {
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
- return TCL_ERROR;
- }
+ case BINARY_FORMAT:
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
+ return TCL_ERROR;
+ }
- /*
- * To avoid copying the data, we format the string in two passes.
- * The first pass computes the size of the output buffer. The
- * second pass places the formatted data into the buffer.
- */
+ /*
+ * To avoid copying the data, we format the string in two passes. The
+ * first pass computes the size of the output buffer. The second pass
+ * places the formatted data into the buffer.
+ */
- format = Tcl_GetString(objv[2]);
- arg = 3;
- offset = 0;
- length = 0;
- while (*format != '\0') {
- str = format;
- if (!GetFormatSpec(&format, &cmd, &count)) {
- break;
+ format = TclGetString(objv[2]);
+ arg = 3;
+ offset = 0;
+ length = 0;
+ while (*format != '\0') {
+ str = format;
+ flags = 0;
+ if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
+ break;
+ }
+ switch (cmd) {
+ case 'a':
+ case 'A':
+ case 'b':
+ case 'B':
+ case 'h':
+ case 'H':
+ /*
+ * For string-type specifiers, the count corresponds to the
+ * number of bytes in a single argument.
+ */
+
+ if (arg >= objc) {
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ Tcl_GetByteArrayFromObj(objv[arg], &count);
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ arg++;
+ if (cmd == 'a' || cmd == 'A') {
+ offset += count;
+ } else if (cmd == 'b' || cmd == 'B') {
+ offset += (count + 7) / 8;
+ } else {
+ offset += (count + 1) / 2;
+ }
+ break;
+ case 'c':
+ size = 1;
+ goto doNumbers;
+ case 't':
+ case 's':
+ case 'S':
+ size = 2;
+ goto doNumbers;
+ case 'n':
+ case 'i':
+ case 'I':
+ size = 4;
+ goto doNumbers;
+ case 'm':
+ case 'w':
+ case 'W':
+ size = 8;
+ goto doNumbers;
+ case 'r':
+ case 'R':
+ case 'f':
+ size = sizeof(float);
+ goto doNumbers;
+ case 'q':
+ case 'Q':
+ case 'd':
+ size = sizeof(double);
+
+ doNumbers:
+ if (arg >= objc) {
+ goto badIndex;
}
- switch (cmd) {
- case 'a':
- case 'A':
- case 'b':
- case 'B':
- case 'h':
- case 'H': {
- /*
- * For string-type specifiers, the count corresponds
- * to the number of bytes in a single argument.
- */
-
- if (arg >= objc) {
- goto badIndex;
- }
- if (count == BINARY_ALL) {
- Tcl_GetByteArrayFromObj(objv[arg], &count);
- } else if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- arg++;
- if (cmd == 'a' || cmd == 'A') {
- offset += count;
- } else if (cmd == 'b' || cmd == 'B') {
- offset += (count + 7) / 8;
- } else {
- offset += (count + 1) / 2;
- }
- break;
- }
- case 'c': {
- size = 1;
- goto doNumbers;
- }
- case 's':
- case 'S': {
- size = 2;
- goto doNumbers;
- }
- case 'i':
- case 'I': {
- size = 4;
- goto doNumbers;
- }
- case 'w':
- case 'W': {
- size = 8;
- goto doNumbers;
- }
- case 'f': {
- size = sizeof(float);
- goto doNumbers;
- }
- case 'd': {
- size = sizeof(double);
-
- doNumbers:
- if (arg >= objc) {
- goto badIndex;
- }
- /*
- * For number-type specifiers, the count corresponds
- * to the number of elements in the list stored in
- * a single argument. If no count is specified, then
- * the argument is taken as a single non-list value.
- */
+ /*
+ * For number-type specifiers, the count corresponds to the
+ * number of elements in the list stored in a single argument.
+ * If no count is specified, then the argument is taken as a
+ * single non-list value.
+ */
- if (count == BINARY_NOCOUNT) {
- arg++;
- count = 1;
- } else {
- int listc;
- Tcl_Obj **listv;
- if (Tcl_ListObjGetElements(interp, objv[arg++],
- &listc, &listv) != TCL_OK) {
- return TCL_ERROR;
- }
- if (count == BINARY_ALL) {
- count = listc;
- } else if (count > listc) {
- Tcl_AppendResult(interp,
- "number of elements in list does not match count",
- (char *) NULL);
- return TCL_ERROR;
- }
- }
- offset += count*size;
- break;
- }
- case 'x': {
- if (count == BINARY_ALL) {
- Tcl_AppendResult(interp,
- "cannot use \"*\" in format string with \"x\"",
- (char *) NULL);
- return TCL_ERROR;
- } else if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- offset += count;
- break;
- }
- case 'X': {
- if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- if ((count > offset) || (count == BINARY_ALL)) {
- count = offset;
- }
- if (offset > length) {
- length = offset;
- }
- offset -= count;
- break;
- }
- case '@': {
- if (offset > length) {
- length = offset;
- }
- if (count == BINARY_ALL) {
- offset = length;
- } else if (count == BINARY_NOCOUNT) {
- goto badCount;
- } else {
- offset = count;
- }
- break;
+ if (count == BINARY_NOCOUNT) {
+ arg++;
+ count = 1;
+ } else {
+ int listc;
+ Tcl_Obj **listv;
+
+ /* The macro evals its args more than once: avoid arg++ */
+ if (TclListObjGetElements(interp, objv[arg], &listc,
+ &listv) != TCL_OK) {
+ return TCL_ERROR;
}
- default: {
- errorString = str;
- goto badField;
+ arg++;
+
+ if (count == BINARY_ALL) {
+ count = listc;
+ } else if (count > listc) {
+ Tcl_AppendResult(interp,
+ "number of elements in list does not match count",
+ NULL);
+ return TCL_ERROR;
}
}
+ offset += count*size;
+ break;
+
+ case 'x':
+ if (count == BINARY_ALL) {
+ Tcl_AppendResult(interp,
+ "cannot use \"*\" in format string with \"x\"",
+ NULL);
+ return TCL_ERROR;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ offset += count;
+ break;
+ case 'X':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count > offset) || (count == BINARY_ALL)) {
+ count = offset;
+ }
+ if (offset > length) {
+ length = offset;
+ }
+ offset -= count;
+ break;
+ case '@':
+ if (offset > length) {
+ length = offset;
+ }
+ if (count == BINARY_ALL) {
+ offset = length;
+ } else if (count == BINARY_NOCOUNT) {
+ goto badCount;
+ } else {
+ offset = count;
+ }
+ break;
+ default:
+ errorString = str;
+ goto badField;
}
- if (offset > length) {
- length = offset;
- }
- if (length == 0) {
- return TCL_OK;
- }
+ }
+ if (offset > length) {
+ length = offset;
+ }
+ if (length == 0) {
+ return TCL_OK;
+ }
- /*
- * Prepare the result object by preallocating the caclulated
- * number of bytes and filling with nulls.
- */
+ /*
+ * Prepare the result object by preallocating the caclulated number of
+ * bytes and filling with nulls.
+ */
- resultPtr = Tcl_GetObjResult(interp);
- if (Tcl_IsShared(resultPtr)) {
- TclNewObj(resultPtr);
- Tcl_SetObjResult(interp, resultPtr);
- }
- buffer = Tcl_SetByteArrayLength(resultPtr, length);
- memset((VOID *) buffer, 0, (size_t) length);
+ resultPtr = Tcl_NewObj();
+ buffer = Tcl_SetByteArrayLength(resultPtr, length);
+ memset(buffer, 0, (size_t) length);
- /*
- * Pack the data into the result object. Note that we can skip
- * the error checking during this pass, since we have already
- * parsed the string once.
- */
+ /*
+ * Pack the data into the result object. Note that we can skip the
+ * error checking during this pass, since we have already parsed the
+ * string once.
+ */
- arg = 3;
- format = Tcl_GetString(objv[2]);
- cursor = buffer;
- maxPos = cursor;
- while (*format != 0) {
- if (!GetFormatSpec(&format, &cmd, &count)) {
- break;
+ arg = 3;
+ format = TclGetString(objv[2]);
+ cursor = buffer;
+ maxPos = cursor;
+ while (*format != 0) {
+ flags = 0;
+ if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
+ break;
+ }
+ if ((count == 0) && (cmd != '@')) {
+ if (cmd != 'x') {
+ arg++;
}
- if ((count == 0) && (cmd != '@')) {
- if (cmd != 'x') {
- arg++;
- }
- continue;
+ continue;
+ }
+ switch (cmd) {
+ case 'a':
+ case 'A': {
+ char pad = (char) (cmd == 'a' ? '\0' : ' ');
+ unsigned char *bytes;
+
+ bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);
+
+ if (count == BINARY_ALL) {
+ count = length;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
}
- switch (cmd) {
- case 'a':
- case 'A': {
- char pad = (char) (cmd == 'a' ? '\0' : ' ');
- unsigned char *bytes;
-
- bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);
-
- if (count == BINARY_ALL) {
- count = length;
- } else if (count == BINARY_NOCOUNT) {
- count = 1;
+ if (length >= count) {
+ memcpy(cursor, bytes, (size_t) count);
+ } else {
+ memcpy(cursor, bytes, (size_t) length);
+ memset(cursor + length, pad, (size_t) (count - length));
+ }
+ cursor += count;
+ break;
+ }
+ case 'b':
+ case 'B': {
+ unsigned char *last;
+
+ str = TclGetStringFromObj(objv[arg], &length);
+ arg++;
+ if (count == BINARY_ALL) {
+ count = length;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ last = cursor + ((count + 7) / 8);
+ if (count > length) {
+ count = length;
+ }
+ value = 0;
+ errorString = "binary";
+ if (cmd == 'B') {
+ for (offset = 0; offset < count; offset++) {
+ value <<= 1;
+ if (str[offset] == '1') {
+ value |= 1;
+ } else if (str[offset] != '0') {
+ errorValue = str;
+ Tcl_DecrRefCount(resultPtr);
+ goto badValue;
}
- if (length >= count) {
- memcpy((VOID *) cursor, (VOID *) bytes,
- (size_t) count);
- } else {
- memcpy((VOID *) cursor, (VOID *) bytes,
- (size_t) length);
- memset((VOID *) (cursor + length), pad,
- (size_t) (count - length));
+ if (((offset + 1) % 8) == 0) {
+ *cursor++ = (unsigned char) value;
+ value = 0;
}
- cursor += count;
- break;
}
- case 'b':
- case 'B': {
- unsigned char *last;
-
- str = Tcl_GetStringFromObj(objv[arg++], &length);
- if (count == BINARY_ALL) {
- count = length;
- } else if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- last = cursor + ((count + 7) / 8);
- if (count > length) {
- count = length;
- }
- value = 0;
- errorString = "binary";
- if (cmd == 'B') {
- for (offset = 0; offset < count; offset++) {
- value <<= 1;
- if (str[offset] == '1') {
- value |= 1;
- } else if (str[offset] != '0') {
- errorValue = str;
- goto badValue;
- }
- if (((offset + 1) % 8) == 0) {
- *cursor++ = (unsigned char) value;
- value = 0;
- }
- }
- } else {
- for (offset = 0; offset < count; offset++) {
- value >>= 1;
- if (str[offset] == '1') {
- value |= 128;
- } else if (str[offset] != '0') {
- errorValue = str;
- goto badValue;
- }
- if (!((offset + 1) % 8)) {
- *cursor++ = (unsigned char) value;
- value = 0;
- }
- }
+ } else {
+ for (offset = 0; offset < count; offset++) {
+ value >>= 1;
+ if (str[offset] == '1') {
+ value |= 128;
+ } else if (str[offset] != '0') {
+ errorValue = str;
+ Tcl_DecrRefCount(resultPtr);
+ goto badValue;
}
- if ((offset % 8) != 0) {
- if (cmd == 'B') {
- value <<= 8 - (offset % 8);
- } else {
- value >>= 8 - (offset % 8);
- }
+ if (!((offset + 1) % 8)) {
*cursor++ = (unsigned char) value;
+ value = 0;
}
- while (cursor < last) {
- *cursor++ = '\0';
- }
- break;
}
- case 'h':
- case 'H': {
- unsigned char *last;
- int c;
-
- str = Tcl_GetStringFromObj(objv[arg++], &length);
- if (count == BINARY_ALL) {
- count = length;
- } else if (count == BINARY_NOCOUNT) {
- count = 1;
+ }
+ if ((offset % 8) != 0) {
+ if (cmd == 'B') {
+ value <<= 8 - (offset % 8);
+ } else {
+ value >>= 8 - (offset % 8);
+ }
+ *cursor++ = (unsigned char) value;
+ }
+ while (cursor < last) {
+ *cursor++ = '\0';
+ }
+ break;
+ }
+ case 'h':
+ case 'H': {
+ unsigned char *last;
+ int c;
+
+ str = TclGetStringFromObj(objv[arg], &length);
+ arg++;
+ if (count == BINARY_ALL) {
+ count = length;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ last = cursor + ((count + 1) / 2);
+ if (count > length) {
+ count = length;
+ }
+ value = 0;
+ errorString = "hexadecimal";
+ if (cmd == 'H') {
+ for (offset = 0; offset < count; offset++) {
+ value <<= 4;
+ if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
+ errorValue = str;
+ Tcl_DecrRefCount(resultPtr);
+ goto badValue;
}
- last = cursor + ((count + 1) / 2);
- if (count > length) {
- count = length;
+ c = str[offset] - '0';
+ if (c > 9) {
+ c += ('0' - 'A') + 10;
}
- value = 0;
- errorString = "hexadecimal";
- if (cmd == 'H') {
- for (offset = 0; offset < count; offset++) {
- value <<= 4;
- if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
- errorValue = str;
- goto badValue;
- }
- c = str[offset] - '0';
- if (c > 9) {
- c += ('0' - 'A') + 10;
- }
- if (c > 16) {
- c += ('A' - 'a');
- }
- value |= (c & 0xf);
- if (offset % 2) {
- *cursor++ = (char) value;
- value = 0;
- }
- }
- } else {
- for (offset = 0; offset < count; offset++) {
- value >>= 4;
-
- if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
- errorValue = str;
- goto badValue;
- }
- c = str[offset] - '0';
- if (c > 9) {
- c += ('0' - 'A') + 10;
- }
- if (c > 16) {
- c += ('A' - 'a');
- }
- value |= ((c << 4) & 0xf0);
- if (offset % 2) {
- *cursor++ = (unsigned char)(value & 0xff);
- value = 0;
- }
- }
+ if (c > 16) {
+ c += ('A' - 'a');
}
+ value |= (c & 0xf);
if (offset % 2) {
- if (cmd == 'H') {
- value <<= 4;
- } else {
- value >>= 4;
- }
- *cursor++ = (unsigned char) value;
+ *cursor++ = (char) value;
+ value = 0;
}
+ }
+ } else {
+ for (offset = 0; offset < count; offset++) {
+ value >>= 4;
- while (cursor < last) {
- *cursor++ = '\0';
+ if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
+ errorValue = str;
+ Tcl_DecrRefCount(resultPtr);
+ goto badValue;
}
- break;
- }
- case 'c':
- case 's':
- case 'S':
- case 'i':
- case 'I':
- case 'w':
- case 'W':
- case 'd':
- case 'f': {
- int listc, i;
- Tcl_Obj **listv;
-
- if (count == BINARY_NOCOUNT) {
- /*
- * Note that we are casting away the const-ness of
- * objv, but this is safe since we aren't going to
- * modify the array.
- */
-
- listv = (Tcl_Obj**)(objv + arg);
- listc = 1;
- count = 1;
- } else {
- Tcl_ListObjGetElements(interp, objv[arg],
- &listc, &listv);
- if (count == BINARY_ALL) {
- count = listc;
- }
+ c = str[offset] - '0';
+ if (c > 9) {
+ c += ('0' - 'A') + 10;
}
- arg++;
- for (i = 0; i < count; i++) {
- if (FormatNumber(interp, cmd, listv[i], &cursor)
- != TCL_OK) {
- return TCL_ERROR;
- }
+ if (c > 16) {
+ c += ('A' - 'a');
}
- break;
- }
- case 'x': {
- if (count == BINARY_NOCOUNT) {
- count = 1;
+ value |= ((c << 4) & 0xf0);
+ if (offset % 2) {
+ *cursor++ = (unsigned char)(value & 0xff);
+ value = 0;
}
- memset(cursor, 0, (size_t) count);
- cursor += count;
- break;
}
- case 'X': {
- if (cursor > maxPos) {
- maxPos = cursor;
- }
- if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- if ((count == BINARY_ALL)
- || (count > (cursor - buffer))) {
- cursor = buffer;
- } else {
- cursor -= count;
- }
- break;
+ }
+ if (offset % 2) {
+ if (cmd == 'H') {
+ value <<= 4;
+ } else {
+ value >>= 4;
}
- case '@': {
- if (cursor > maxPos) {
- maxPos = cursor;
- }
- if (count == BINARY_ALL) {
- cursor = maxPos;
- } else {
- cursor = buffer + count;
- }
- break;
+ *cursor++ = (unsigned char) value;
+ }
+
+ while (cursor < last) {
+ *cursor++ = '\0';
+ }
+ break;
+ }
+ case 'c':
+ case 't':
+ case 's':
+ case 'S':
+ case 'n':
+ case 'i':
+ case 'I':
+ case 'm':
+ case 'w':
+ case 'W':
+ case 'r':
+ case 'R':
+ case 'd':
+ case 'q':
+ case 'Q':
+ case 'f': {
+ int listc, i;
+ Tcl_Obj **listv;
+
+ if (count == BINARY_NOCOUNT) {
+ /*
+ * Note that we are casting away the const-ness of objv,
+ * but this is safe since we aren't going to modify the
+ * array.
+ */
+
+ listv = (Tcl_Obj**)(objv + arg);
+ listc = 1;
+ count = 1;
+ } else {
+ TclListObjGetElements(interp, objv[arg], &listc, &listv);
+ if (count == BINARY_ALL) {
+ count = listc;
}
}
+ arg++;
+ for (i = 0; i < count; i++) {
+ if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) {
+ Tcl_DecrRefCount(resultPtr);
+ return TCL_ERROR;
+ }
+ }
+ break;
+ }
+ case 'x':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ memset(cursor, 0, (size_t) count);
+ cursor += count;
+ break;
+ case 'X':
+ if (cursor > maxPos) {
+ maxPos = cursor;
+ }
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count == BINARY_ALL) || (count > (cursor - buffer))) {
+ cursor = buffer;
+ } else {
+ cursor -= count;
+ }
+ break;
+ case '@':
+ if (cursor > maxPos) {
+ maxPos = cursor;
+ }
+ if (count == BINARY_ALL) {
+ cursor = maxPos;
+ } else {
+ cursor = buffer + count;
+ }
+ break;
}
- break;
}
- case BINARY_SCAN: {
- int i;
- Tcl_Obj *valuePtr, *elementPtr;
- Tcl_HashTable numberCacheHash;
- Tcl_HashTable *numberCachePtr;
-
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "value formatString ?varName varName ...?");
- return TCL_ERROR;
+ Tcl_SetObjResult(interp, resultPtr);
+ break;
+ case BINARY_SCAN: {
+ int i;
+ Tcl_Obj *valuePtr, *elementPtr;
+ Tcl_HashTable numberCacheHash;
+ Tcl_HashTable *numberCachePtr;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "value formatString ?varName varName ...?");
+ return TCL_ERROR;
+ }
+ numberCachePtr = &numberCacheHash;
+ Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
+ buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
+ format = TclGetString(objv[3]);
+ cursor = buffer;
+ arg = 4;
+ offset = 0;
+ while (*format != '\0') {
+ str = format;
+ flags = 0;
+ if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
+ goto done;
}
- numberCachePtr = &numberCacheHash;
- Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
- buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
- format = Tcl_GetString(objv[3]);
- cursor = buffer;
- arg = 4;
- offset = 0;
- while (*format != '\0') {
- str = format;
- if (!GetFormatSpec(&format, &cmd, &count)) {
- goto done;
+ switch (cmd) {
+ case 'a':
+ case 'A': {
+ unsigned char *src;
+
+ if (arg >= objc) {
+ DeleteScanNumberCache(numberCachePtr);
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ count = length - offset;
+ } else {
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if (count > (length - offset)) {
+ goto done;
+ }
}
- switch (cmd) {
- case 'a':
- case 'A': {
- unsigned char *src;
-
- if (arg >= objc) {
- DeleteScanNumberCache(numberCachePtr);
- goto badIndex;
- }
- if (count == BINARY_ALL) {
- count = length - offset;
- } else {
- if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- if (count > (length - offset)) {
- goto done;
- }
- }
- src = buffer + offset;
- size = count;
+ src = buffer + offset;
+ size = count;
- /*
- * Trim trailing nulls and spaces, if necessary.
- */
+ /*
+ * Trim trailing nulls and spaces, if necessary.
+ */
- if (cmd == 'A') {
- while (size > 0) {
- if (src[size-1] != '\0' && src[size-1] != ' ') {
- break;
- }
- size--;
- }
- }
- valuePtr = Tcl_NewByteArrayObj(src, size);
- Tcl_IncrRefCount(valuePtr);
- resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
- NULL, valuePtr, TCL_LEAVE_ERR_MSG);
- Tcl_DecrRefCount(valuePtr);
- arg++;
- if (resultPtr == NULL) {
- DeleteScanNumberCache(numberCachePtr);
- return TCL_ERROR;
+ if (cmd == 'A') {
+ while (size > 0) {
+ if (src[size-1] != '\0' && src[size-1] != ' ') {
+ break;
}
- offset += count;
- break;
+ size--;
}
- case 'b':
- case 'B': {
- unsigned char *src;
- char *dest;
-
- if (arg >= objc) {
- DeleteScanNumberCache(numberCachePtr);
- goto badIndex;
- }
- if (count == BINARY_ALL) {
- count = (length - offset) * 8;
- } else {
- if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- if (count > (length - offset) * 8) {
- goto done;
- }
- }
- src = buffer + offset;
- valuePtr = Tcl_NewObj();
- Tcl_SetObjLength(valuePtr, count);
- dest = Tcl_GetString(valuePtr);
-
- if (cmd == 'b') {
- for (i = 0; i < count; i++) {
- if (i % 8) {
- value >>= 1;
- } else {
- value = *src++;
- }
- *dest++ = (char) ((value & 1) ? '1' : '0');
- }
- } else {
- for (i = 0; i < count; i++) {
- if (i % 8) {
- value <<= 1;
- } else {
- value = *src++;
- }
- *dest++ = (char) ((value & 0x80) ? '1' : '0');
- }
- }
+ }
- Tcl_IncrRefCount(valuePtr);
- resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
- NULL, valuePtr, TCL_LEAVE_ERR_MSG);
- Tcl_DecrRefCount(valuePtr);
- arg++;
- if (resultPtr == NULL) {
- DeleteScanNumberCache(numberCachePtr);
- return TCL_ERROR;
- }
- offset += (count + 7 ) / 8;
- break;
+ /*
+ * Have to do this #ifdef-fery because (as part of defining
+ * Tcl_NewByteArrayObj) we removed the #def that hides this
+ * stuff normally. If this code ever gets copied to another
+ * file, it should be changed back to the simpler version.
+ */
+
+#ifdef TCL_MEM_DEBUG
+ valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__,__LINE__);
+#else
+ valuePtr = Tcl_NewByteArrayObj(src, size);
+#endif /* TCL_MEM_DEBUG */
+
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
+ TCL_LEAVE_ERR_MSG);
+ arg++;
+ if (resultPtr == NULL) {
+ DeleteScanNumberCache(numberCachePtr);
+ return TCL_ERROR;
+ }
+ offset += count;
+ break;
+ }
+ case 'b':
+ case 'B': {
+ unsigned char *src;
+ char *dest;
+
+ if (arg >= objc) {
+ DeleteScanNumberCache(numberCachePtr);
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ count = (length - offset) * 8;
+ } else {
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
}
- case 'h':
- case 'H': {
- char *dest;
- unsigned char *src;
- int i;
- static char hexdigit[] = "0123456789abcdef";
-
- if (arg >= objc) {
- DeleteScanNumberCache(numberCachePtr);
- goto badIndex;
- }
- if (count == BINARY_ALL) {
- count = (length - offset)*2;
+ if (count > (length - offset) * 8) {
+ goto done;
+ }
+ }
+ src = buffer + offset;
+ valuePtr = Tcl_NewObj();
+ Tcl_SetObjLength(valuePtr, count);
+ dest = TclGetString(valuePtr);
+
+ if (cmd == 'b') {
+ for (i = 0; i < count; i++) {
+ if (i % 8) {
+ value >>= 1;
} else {
- if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- if (count > (length - offset)*2) {
- goto done;
- }
+ value = *src++;
}
- src = buffer + offset;
- valuePtr = Tcl_NewObj();
- Tcl_SetObjLength(valuePtr, count);
- dest = Tcl_GetString(valuePtr);
-
- if (cmd == 'h') {
- for (i = 0; i < count; i++) {
- if (i % 2) {
- value >>= 4;
- } else {
- value = *src++;
- }
- *dest++ = hexdigit[value & 0xf];
- }
+ *dest++ = (char) ((value & 1) ? '1' : '0');
+ }
+ } else {
+ for (i = 0; i < count; i++) {
+ if (i % 8) {
+ value <<= 1;
} else {
- for (i = 0; i < count; i++) {
- if (i % 2) {
- value <<= 4;
- } else {
- value = *src++;
- }
- *dest++ = hexdigit[(value >> 4) & 0xf];
- }
+ value = *src++;
}
-
- Tcl_IncrRefCount(valuePtr);
- resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
- NULL, valuePtr, TCL_LEAVE_ERR_MSG);
- Tcl_DecrRefCount(valuePtr);
- arg++;
- if (resultPtr == NULL) {
- DeleteScanNumberCache(numberCachePtr);
- return TCL_ERROR;
- }
- offset += (count + 1) / 2;
- break;
- }
- case 'c': {
- size = 1;
- goto scanNumber;
- }
- case 's':
- case 'S': {
- size = 2;
- goto scanNumber;
+ *dest++ = (char) ((value & 0x80) ? '1' : '0');
}
- case 'i':
- case 'I': {
- size = 4;
- goto scanNumber;
- }
- case 'w':
- case 'W': {
- size = 8;
- goto scanNumber;
+ }
+
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
+ TCL_LEAVE_ERR_MSG);
+ arg++;
+ if (resultPtr == NULL) {
+ DeleteScanNumberCache(numberCachePtr);
+ return TCL_ERROR;
+ }
+ offset += (count + 7) / 8;
+ break;
+ }
+ case 'h':
+ case 'H': {
+ char *dest;
+ unsigned char *src;
+ int i;
+ static const char hexdigit[] = "0123456789abcdef";
+
+ if (arg >= objc) {
+ DeleteScanNumberCache(numberCachePtr);
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ count = (length - offset)*2;
+ } else {
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
}
- case 'f': {
- size = sizeof(float);
- goto scanNumber;
+ if (count > (length - offset)*2) {
+ goto done;
}
- case 'd': {
- unsigned char *src;
-
- size = sizeof(double);
- /* fall through */
-
- scanNumber:
- if (arg >= objc) {
- DeleteScanNumberCache(numberCachePtr);
- goto badIndex;
- }
- if (count == BINARY_NOCOUNT) {
- if ((length - offset) < size) {
- goto done;
- }
- valuePtr = ScanNumber(buffer+offset, cmd,
- &numberCachePtr);
- offset += size;
+ }
+ src = buffer + offset;
+ valuePtr = Tcl_NewObj();
+ Tcl_SetObjLength(valuePtr, count);
+ dest = TclGetString(valuePtr);
+
+ if (cmd == 'h') {
+ for (i = 0; i < count; i++) {
+ if (i % 2) {
+ value >>= 4;
} else {
- if (count == BINARY_ALL) {
- count = (length - offset) / size;
- }
- if ((length - offset) < (count * size)) {
- goto done;
- }
- valuePtr = Tcl_NewObj();
- src = buffer+offset;
- for (i = 0; i < count; i++) {
- elementPtr = ScanNumber(src, cmd,
- &numberCachePtr);
- src += size;
- Tcl_ListObjAppendElement(NULL, valuePtr,
- elementPtr);
- }
- offset += count*size;
+ value = *src++;
}
-
- Tcl_IncrRefCount(valuePtr);
- resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
- NULL, valuePtr, TCL_LEAVE_ERR_MSG);
- Tcl_DecrRefCount(valuePtr);
- arg++;
- if (resultPtr == NULL) {
- DeleteScanNumberCache(numberCachePtr);
- return TCL_ERROR;
- }
- break;
+ *dest++ = hexdigit[value & 0xf];
}
- case 'x': {
- if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- if ((count == BINARY_ALL)
- || (count > (length - offset))) {
- offset = length;
+ } else {
+ for (i = 0; i < count; i++) {
+ if (i % 2) {
+ value <<= 4;
} else {
- offset += count;
+ value = *src++;
}
- break;
+ *dest++ = hexdigit[(value >> 4) & 0xf];
}
- case 'X': {
- if (count == BINARY_NOCOUNT) {
- count = 1;
- }
- if ((count == BINARY_ALL) || (count > offset)) {
- offset = 0;
- } else {
- offset -= count;
- }
- break;
+ }
+
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
+ TCL_LEAVE_ERR_MSG);
+ arg++;
+ if (resultPtr == NULL) {
+ DeleteScanNumberCache(numberCachePtr);
+ return TCL_ERROR;
+ }
+ offset += (count + 1) / 2;
+ break;
+ }
+ case 'c':
+ size = 1;
+ goto scanNumber;
+ case 't':
+ case 's':
+ case 'S':
+ size = 2;
+ goto scanNumber;
+ case 'n':
+ case 'i':
+ case 'I':
+ size = 4;
+ goto scanNumber;
+ case 'm':
+ case 'w':
+ case 'W':
+ size = 8;
+ goto scanNumber;
+ case 'r':
+ case 'R':
+ case 'f':
+ size = sizeof(float);
+ goto scanNumber;
+ case 'q':
+ case 'Q':
+ case 'd': {
+ unsigned char *src;
+
+ size = sizeof(double);
+ /* fall through */
+
+ scanNumber:
+ if (arg >= objc) {
+ DeleteScanNumberCache(numberCachePtr);
+ goto badIndex;
+ }
+ if (count == BINARY_NOCOUNT) {
+ if ((length - offset) < size) {
+ goto done;
}
- case '@': {
- if (count == BINARY_NOCOUNT) {
- DeleteScanNumberCache(numberCachePtr);
- goto badCount;
- }
- if ((count == BINARY_ALL) || (count > length)) {
- offset = length;
- } else {
- offset = count;
- }
- break;
+ valuePtr = ScanNumber(buffer+offset, cmd, flags,
+ &numberCachePtr);
+ offset += size;
+ } else {
+ if (count == BINARY_ALL) {
+ count = (length - offset) / size;
+ }
+ if ((length - offset) < (count * size)) {
+ goto done;
}
- default: {
- DeleteScanNumberCache(numberCachePtr);
- errorString = str;
- goto badField;
+ 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);
}
+ offset += count*size;
+ }
+
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
+ TCL_LEAVE_ERR_MSG);
+ arg++;
+ if (resultPtr == NULL) {
+ DeleteScanNumberCache(numberCachePtr);
+ return TCL_ERROR;
+ }
+ break;
+ }
+ case 'x':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count == BINARY_ALL) || (count > (length - offset))) {
+ offset = length;
+ } else {
+ offset += count;
+ }
+ break;
+ case 'X':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count == BINARY_ALL) || (count > offset)) {
+ offset = 0;
+ } else {
+ offset -= count;
+ }
+ break;
+ case '@':
+ if (count == BINARY_NOCOUNT) {
+ DeleteScanNumberCache(numberCachePtr);
+ goto badCount;
}
+ if ((count == BINARY_ALL) || (count > length)) {
+ offset = length;
+ } else {
+ offset = count;
+ }
+ break;
+ default:
+ DeleteScanNumberCache(numberCachePtr);
+ errorString = str;
+ goto badField;
}
+ }
- /*
- * Set the result to the last position of the cursor.
- */
+ /*
+ * Set the result to the last position of the cursor.
+ */
- done:
- Tcl_ResetResult(interp);
- Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4);
- DeleteScanNumberCache(numberCachePtr);
- break;
- }
+ done:
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 4));
+ DeleteScanNumberCache(numberCachePtr);
+ break;
+ }
}
return TCL_OK;
- badValue:
+ badValue:
Tcl_ResetResult(interp);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "expected ", errorString,
+ Tcl_AppendResult(interp, "expected ", errorString,
" string but got \"", errorValue, "\" instead", NULL);
return TCL_ERROR;
- badCount:
+ badCount:
errorString = "missing count for \"@\" field specifier";
goto error;
- badIndex:
+ badIndex:
errorString = "not enough arguments for all format specifiers";
goto error;
- badField:
+ badField:
{
Tcl_UniChar ch;
char buf[TCL_UTF_MAX + 1];
@@ -1365,7 +1368,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- error:
+ error:
Tcl_AppendResult(interp, errorString, NULL);
return TCL_ERROR;
}
@@ -1375,15 +1378,15 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
*
* GetFormatSpec --
*
- * This function parses the format strings used in the binary
- * format and scan commands.
+ * This function parses the format strings used in the binary format and
+ * scan commands.
*
* Results:
- * Moves the formatPtr to the start of the next command. Returns
- * the current command character and count in cmdPtr and countPtr.
- * The count is set to BINARY_ALL if the count character was '*'
- * or BINARY_NOCOUNT if no count was specified. Returns 1 on
- * success, or 0 if the string did not have a format specifier.
+ * Moves the formatPtr to the start of the next command. Returns the
+ * current command character and count in cmdPtr and countPtr. The count
+ * is set to BINARY_ALL if the count character was '*' or BINARY_NOCOUNT
+ * if no count was specified. Returns 1 on success, or 0 if the string
+ * did not have a format specifier.
*
* Side effects:
* None.
@@ -1392,10 +1395,11 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
*/
static int
-GetFormatSpec(formatPtr, cmdPtr, countPtr)
- char **formatPtr; /* Pointer to format string. */
- char *cmdPtr; /* Pointer to location of command char. */
- int *countPtr; /* Pointer to repeat count value. */
+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.
@@ -1419,6 +1423,10 @@ GetFormatSpec(formatPtr, cmdPtr, countPtr)
*cmdPtr = **formatPtr;
(*formatPtr)++;
+ if (**formatPtr == 'u') {
+ (*formatPtr)++;
+ (*flagsPtr) |= BINARY_UNSIGNED;
+ }
if (**formatPtr == '*') {
(*formatPtr)++;
(*countPtr) = BINARY_ALL;
@@ -1433,13 +1441,193 @@ GetFormatSpec(formatPtr, cmdPtr, countPtr)
/*
*----------------------------------------------------------------------
*
+ * NeedReversing --
+ *
+ * This routine determines, if bytes of a number need to be re-ordered,
+ * and returns a numeric code indicating the re-ordering to be done.
+ * This depends on the endiannes of the machine and the desired format.
+ * It is in effect a table (whose contents depend on the endianness of
+ * the system) describing whether a value needs reversing or not. Anyone
+ * porting the code to a big-endian platform should take care to make
+ * sure that they define WORDS_BIGENDIAN though this is already done by
+ * configure for the Unix build; little-endian platforms (including
+ * Windows) don't need to do anything.
+ *
+ * Results:
+ * 0 No re-ordering needed.
+ * 1 Reverse the bytes: 01234567 <-> 76543210 (little to big)
+ * 2 Apply this re-ordering: 01234567 <-> 45670123 (Nokia to little)
+ * 3 Apply this re-ordering: 01234567 <-> 32107654 (Nokia to big)
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NeedReversing(
+ int format)
+{
+ switch (format) {
+ /* native floats and doubles: never reverse */
+ case 'd':
+ case 'f':
+ /* big endian ints: never reverse */
+ case 'I':
+ case 'S':
+ case 'W':
+#ifdef WORDS_BIGENDIAN
+ /* native ints: reverse if we're little-endian */
+ case 'n':
+ case 't':
+ case 'm':
+ /* f: reverse if we're little-endian */
+ case 'Q':
+ case 'R':
+#else /* !WORDS_BIGENDIAN */
+ /* small endian floats: reverse if we're big-endian */
+ case 'r':
+#endif /* WORDS_BIGENDIAN */
+ return 0;
+
+#ifdef WORDS_BIGENDIAN
+ /* small endian floats: reverse if we're big-endian */
+ case 'q':
+ case 'r':
+#else /* !WORDS_BIGENDIAN */
+ /* native ints: reverse if we're little-endian */
+ case 'n':
+ case 't':
+ case 'm':
+ /* f: reverse if we're little-endian */
+ case 'R':
+#endif /* WORDS_BIGENDIAN */
+ /* small endian ints: always reverse */
+ case 'i':
+ case 's':
+ case 'w':
+ return 1;
+
+#ifndef WORDS_BIGENDIAN
+ /*
+ * The Q and q formats need special handling to account for the unusual
+ * byte ordering of 8-byte floats on Nokia 770 systems, which claim to be
+ * little-endian, but also reverse word order.
+ */
+
+ case 'Q':
+ if (TclNokia770Doubles()) {
+ return 3;
+ }
+ return 1;
+ case 'q':
+ if (TclNokia770Doubles()) {
+ return 2;
+ }
+ return 0;
+#endif
+ }
+
+ Tcl_Panic("unexpected fallthrough");
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CopyNumber --
+ *
+ * This routine is called by FormatNumber and ScanNumber to copy a
+ * floating-point number. If required, bytes are reversed while copying.
+ * The behaviour is only fully defined when used with IEEE float and
+ * double values (guaranteed to be 4 and 8 bytes long, respectively.)
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Copies length bytes
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+CopyNumber(
+ const void *from, /* source */
+ void *to, /* destination */
+ unsigned int length, /* Number of bytes to copy */
+ int type) /* What type of thing are we copying? */
+{
+ switch (NeedReversing(type)) {
+ case 0:
+ memcpy(to, from, length);
+ break;
+ case 1: {
+ const unsigned char *fromPtr = from;
+ unsigned char *toPtr = to;
+
+ switch (length) {
+ case 4:
+ toPtr[0] = fromPtr[3];
+ toPtr[1] = fromPtr[2];
+ toPtr[2] = fromPtr[1];
+ toPtr[3] = fromPtr[0];
+ break;
+ case 8:
+ toPtr[0] = fromPtr[7];
+ toPtr[1] = fromPtr[6];
+ toPtr[2] = fromPtr[5];
+ toPtr[3] = fromPtr[4];
+ toPtr[4] = fromPtr[3];
+ toPtr[5] = fromPtr[2];
+ toPtr[6] = fromPtr[1];
+ toPtr[7] = fromPtr[0];
+ break;
+ }
+ break;
+ }
+ case 2: {
+ const unsigned char *fromPtr = from;
+ unsigned char *toPtr = to;
+
+ toPtr[0] = fromPtr[4];
+ toPtr[1] = fromPtr[5];
+ toPtr[2] = fromPtr[6];
+ toPtr[3] = fromPtr[7];
+ toPtr[4] = fromPtr[0];
+ toPtr[5] = fromPtr[1];
+ toPtr[6] = fromPtr[2];
+ toPtr[7] = fromPtr[3];
+ break;
+ }
+ case 3: {
+ const unsigned char *fromPtr = from;
+ unsigned char *toPtr = to;
+
+ toPtr[0] = fromPtr[3];
+ toPtr[1] = fromPtr[2];
+ toPtr[2] = fromPtr[1];
+ toPtr[3] = fromPtr[0];
+ toPtr[4] = fromPtr[7];
+ toPtr[5] = fromPtr[6];
+ toPtr[6] = fromPtr[5];
+ toPtr[7] = fromPtr[4];
+ break;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* FormatNumber --
*
- * This routine is called by Tcl_BinaryObjCmd to format a number
- * into a location pointed at by cursor.
+ * This routine is called by Tcl_BinaryObjCmd to format a number into a
+ * location pointed at by cursor.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl result.
*
* Side effects:
* Moves the cursor to the next location to be written into.
@@ -1448,64 +1636,79 @@ GetFormatSpec(formatPtr, cmdPtr, countPtr)
*/
static int
-FormatNumber(interp, type, src, cursorPtr)
- Tcl_Interp *interp; /* Current interpreter, used to report
+FormatNumber(
+ Tcl_Interp *interp, /* Current interpreter, used to report
* errors. */
- int type; /* Type of number to format. */
- Tcl_Obj *src; /* Number to format. */
- unsigned char **cursorPtr; /* Pointer to index into destination buffer. */
+ int type, /* Type of number to format. */
+ Tcl_Obj *src, /* Number to format. */
+ unsigned char **cursorPtr) /* Pointer to index into destination buffer. */
{
long value;
double dvalue;
Tcl_WideInt wvalue;
+ float fvalue;
switch (type) {
case 'd':
- case 'f':
+ case 'q':
+ case 'Q':
/*
- * For floating point types, we need to copy the data using
- * memcpy to avoid alignment issues.
+ * Double-precision floating point values. Tcl_GetDoubleFromObj
+ * returns TCL_ERROR for NaN, but we can check by comparing the
+ * object's type pointer.
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
- return TCL_ERROR;
+ if (src->typePtr != &tclDoubleType) {
+ return TCL_ERROR;
+ }
+ dvalue = src->internalRep.doubleValue;
}
- if (type == 'd') {
- /*
- * Can't just memcpy() here. [Bug 1116542]
- */
-
- CopyNumber(&dvalue, *cursorPtr, sizeof(double));
- *cursorPtr += sizeof(double);
- } else {
- float fvalue;
+ CopyNumber(&dvalue, *cursorPtr, sizeof(double), type);
+ *cursorPtr += sizeof(double);
+ return TCL_OK;
- /*
- * Because some compilers will generate floating point exceptions
- * on an overflow cast (e.g. Borland), we restrict the values
- * to the valid range for float.
- */
+ case 'f':
+ case 'r':
+ case 'R':
+ /*
+ * Single-precision floating point values. Tcl_GetDoubleFromObj
+ * returns TCL_ERROR for NaN, but we can check by comparing the
+ * object's type pointer.
+ */
- if (fabs(dvalue) > (double)FLT_MAX) {
- fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
- } else {
- fvalue = (float) dvalue;
+ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
+ if (src->typePtr != &tclDoubleType) {
+ return TCL_ERROR;
}
- memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float));
- *cursorPtr += sizeof(float);
+ dvalue = src->internalRep.doubleValue;
+ }
+
+ /*
+ * Because some compilers will generate floating point exceptions on
+ * an overflow cast (e.g. Borland), we restrict the values to the
+ * valid range for float.
+ */
+
+ if (fabs(dvalue) > (double)FLT_MAX) {
+ fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
+ } else {
+ fvalue = (float) dvalue;
}
+ CopyNumber(&fvalue, *cursorPtr, sizeof(float), type);
+ *cursorPtr += sizeof(float);
return TCL_OK;
/*
- * Next cases separate from other integer cases because we
- * need a different API to get a wide.
+ * 64-bit integer values.
*/
case 'w':
case 'W':
+ case 'm':
if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
- if (type == 'w') {
+ if (NeedReversing(type)) {
*(*cursorPtr)++ = (unsigned char) wvalue;
*(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
@@ -1525,170 +1728,221 @@ FormatNumber(interp, type, src, cursorPtr)
*(*cursorPtr)++ = (unsigned char) wvalue;
}
return TCL_OK;
- default:
- if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
+
+ /*
+ * 32-bit integer values.
+ */
+ case 'i':
+ case 'I':
+ case 'n':
+ if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
return TCL_ERROR;
}
- if (type == 'c') {
- *(*cursorPtr)++ = (unsigned char) value;
- } else if (type == 's') {
- *(*cursorPtr)++ = (unsigned char) value;
- *(*cursorPtr)++ = (unsigned char) (value >> 8);
- } else if (type == 'S') {
- *(*cursorPtr)++ = (unsigned char) (value >> 8);
- *(*cursorPtr)++ = (unsigned char) value;
- } else if (type == 'i') {
+ if (NeedReversing(type)) {
*(*cursorPtr)++ = (unsigned char) value;
*(*cursorPtr)++ = (unsigned char) (value >> 8);
*(*cursorPtr)++ = (unsigned char) (value >> 16);
*(*cursorPtr)++ = (unsigned char) (value >> 24);
- } else if (type == 'I') {
+ } else {
*(*cursorPtr)++ = (unsigned char) (value >> 24);
*(*cursorPtr)++ = (unsigned char) (value >> 16);
*(*cursorPtr)++ = (unsigned char) (value >> 8);
*(*cursorPtr)++ = (unsigned char) value;
}
return TCL_OK;
+
+ /*
+ * 16-bit integer values.
+ */
+ case 's':
+ case 'S':
+ case 't':
+ if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (NeedReversing(type)) {
+ *(*cursorPtr)++ = (unsigned char) value;
+ *(*cursorPtr)++ = (unsigned char) (value >> 8);
+ } else {
+ *(*cursorPtr)++ = (unsigned char) (value >> 8);
+ *(*cursorPtr)++ = (unsigned char) value;
+ }
+ return TCL_OK;
+
+ /*
+ * 8-bit integer values.
+ */
+ case 'c':
+ if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ *(*cursorPtr)++ = (unsigned char) value;
+ return TCL_OK;
+
+ default:
+ Tcl_Panic("unexpected fallthrough");
+ return TCL_ERROR;
}
}
-/* Ugly workaround for old and broken compiler! */
-static void
-CopyNumber(from, to, length)
- CONST VOID *from;
- VOID *to;
- unsigned int length;
-{
- memcpy(to, from, length);
-}
-
/*
*----------------------------------------------------------------------
*
* ScanNumber --
*
- * This routine is called by Tcl_BinaryObjCmd to scan a number
- * out of a buffer.
+ * This routine is called by Tcl_BinaryObjCmd to scan a number out of a
+ * buffer.
*
* Results:
- * Returns a newly created object containing the scanned number.
- * This object has a ref count of zero.
+ * Returns a newly created object containing the scanned number. This
+ * object has a ref count of zero.
*
* Side effects:
- * Might reuse an object in the number cache, place a new object
- * in the cache, or delete the cache and set the reference to
- * it (itself passed in by reference) to NULL.
+ * Might reuse an object in the number cache, place a new object in the
+ * cache, or delete the cache and set the reference to it (itself passed
+ * in by reference) to NULL.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
-ScanNumber(buffer, type, numberCachePtrPtr)
- unsigned char *buffer; /* Buffer to scan number from. */
- int type; /* Format character from "binary scan" */
- Tcl_HashTable **numberCachePtrPtr;
+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
* different numbers have been scanned. */
{
long value;
+ float fvalue;
+ double dvalue;
Tcl_WideUInt uwvalue;
/*
* We cannot rely on the compiler to properly sign extend integer values
* when we cast from smaller values to larger values because we don't know
- * the exact size of the integer types. So, we have to handle sign
+ * 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.
+ * needed. This practice is disabled if the BINARY_UNSIGNED flag is set.
*/
switch (type) {
- case 'c':
- /*
- * Characters need special handling. We want to produce a
- * signed result, but on some platforms (such as AIX) chars
- * are unsigned. To deal with this, check for a value that
- * should be negative but isn't.
- */
+ case 'c':
+ /*
+ * Characters need special handling. We want to produce a signed
+ * result, but on some platforms (such as AIX) chars are unsigned. To
+ * deal with this, check for a value that should be negative but
+ * isn't.
+ */
- value = buffer[0];
+ value = buffer[0];
+ if (!(flags & BINARY_UNSIGNED)) {
if (value & 0x80) {
value |= -0x100;
}
- goto returnNumericObject;
+ }
+ goto returnNumericObject;
+
+ /*
+ * 16-bit numeric values. We need the sign extension trick (see above)
+ * here as well.
+ */
- case 's':
+ case 's':
+ case 'S':
+ case 't':
+ if (NeedReversing(type)) {
value = (long) (buffer[0] + (buffer[1] << 8));
- goto shortValue;
- case 'S':
+ } else {
value = (long) (buffer[1] + (buffer[0] << 8));
- shortValue:
+ }
+ if (!(flags & BINARY_UNSIGNED)) {
if (value & 0x8000) {
value |= -0x10000;
}
- goto returnNumericObject;
+ }
+ goto returnNumericObject;
- case 'i':
- value = (long) (buffer[0]
+ /*
+ * 32-bit numeric values.
+ */
+
+ case 'i':
+ case 'I':
+ case 'n':
+ if (NeedReversing(type)) {
+ value = (long) (buffer[0]
+ (buffer[1] << 8)
+ (buffer[2] << 16)
- + (buffer[3] << 24));
- goto intValue;
- case 'I':
+ + (((long)buffer[3]) << 24));
+ } else {
value = (long) (buffer[3]
+ (buffer[2] << 8)
+ (buffer[1] << 16)
- + (buffer[0] << 24));
- intValue:
- /*
- * Check to see if the value was sign extended properly on
- * systems where an int is more than 32-bits.
- */
+ + (((long)buffer[0]) << 24));
+ }
+
+ /*
+ * 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((Tcl_WideInt)(unsigned long)value);
+ }
+ if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
+ value -= (((unsigned int)1)<<31);
+ value -= (((unsigned int)1)<<31);
+ }
+
+ returnNumericObject:
+ if (*numberCachePtrPtr == NULL) {
+ return Tcl_NewLongObj(value);
+ } else {
+ register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
+ register Tcl_HashEntry *hPtr;
+ int isNew;
- if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
- value -= (((unsigned int)1)<<31);
- value -= (((unsigned int)1)<<31);
+ hPtr = Tcl_CreateHashEntry(tablePtr, INT2PTR(value), &isNew);
+ if (!isNew) {
+ return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
}
- returnNumericObject:
- if (*numberCachePtrPtr == NULL) {
- return Tcl_NewLongObj(value);
- } else {
- register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
- register Tcl_HashEntry *hPtr;
- int isNew;
-
- hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew);
- if (!isNew) {
- return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
- }
- if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) {
- /*
- * We've overflowed the cache! Someone's parsing
- * a LOT of varied binary data in a single call!
- * Bail out by switching back to the old behaviour
- * for the rest of the scan.
- *
- * Note that anyone just using the 'c' conversion
- * (for bytes) cannot trigger this.
- */
- DeleteScanNumberCache(tablePtr);
- *numberCachePtrPtr = NULL;
- return Tcl_NewLongObj(value);
- } else {
- register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
+ if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) {
+ register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
- Tcl_IncrRefCount(objPtr);
- Tcl_SetHashValue(hPtr, (ClientData) objPtr);
- return objPtr;
- }
+ Tcl_IncrRefCount(objPtr);
+ Tcl_SetHashValue(hPtr, (ClientData) objPtr);
+ return objPtr;
}
/*
- * Do not cache wide values; they are already too large to
- * use as keys.
+ * We've overflowed the cache! Someone's parsing a LOT of varied
+ * binary data in a single call! Bail out by switching back to the
+ * old behaviour for the rest of the scan.
+ *
+ * Note that anyone just using the 'c' conversion (for bytes)
+ * cannot trigger this.
*/
- case 'w':
- uwvalue = ((Tcl_WideUInt) buffer[0])
+
+ DeleteScanNumberCache(tablePtr);
+ *numberCachePtrPtr = NULL;
+ return Tcl_NewLongObj(value);
+ }
+
+ /*
+ * Do not cache wide (64-bit) values; they are already too large to
+ * use as keys.
+ */
+
+ case 'w':
+ case 'W':
+ case 'm':
+ if (NeedReversing(type)) {
+ uwvalue = ((Tcl_WideUInt) buffer[0])
| (((Tcl_WideUInt) buffer[1]) << 8)
| (((Tcl_WideUInt) buffer[2]) << 16)
| (((Tcl_WideUInt) buffer[3]) << 24)
@@ -1696,9 +1950,8 @@ ScanNumber(buffer, type, numberCachePtrPtr)
| (((Tcl_WideUInt) buffer[5]) << 40)
| (((Tcl_WideUInt) buffer[6]) << 48)
| (((Tcl_WideUInt) buffer[7]) << 56);
- return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
- case 'W':
- uwvalue = ((Tcl_WideUInt) buffer[7])
+ } else {
+ uwvalue = ((Tcl_WideUInt) buffer[7])
| (((Tcl_WideUInt) buffer[6]) << 8)
| (((Tcl_WideUInt) buffer[5]) << 16)
| (((Tcl_WideUInt) buffer[4]) << 24)
@@ -1706,23 +1959,42 @@ ScanNumber(buffer, type, numberCachePtrPtr)
| (((Tcl_WideUInt) buffer[2]) << 40)
| (((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 keys and the values stored are utterly
- * incompatible too.
- */
- case 'f': {
- float fvalue;
- memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float));
- return Tcl_NewDoubleObj(fvalue);
}
- case 'd': {
- double dvalue;
- memcpy((VOID *) &dvalue, (VOID *) buffer, sizeof(double));
- return Tcl_NewDoubleObj(dvalue);
+ if (flags & BINARY_UNSIGNED) {
+ Tcl_Obj *bigObj = NULL;
+ mp_int big;
+
+ TclBNInitBignumFromWideUInt(&big, uwvalue);
+ bigObj = Tcl_NewBignumObj(&big);
+ return bigObj;
}
+ return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
+
+ /*
+ * Do not cache double values; they are already too large to use as
+ * keys and the values stored are utterly incompatible with the
+ * integer part of the cache.
+ */
+
+ /*
+ * 32-bit IEEE single-precision floating point.
+ */
+
+ case 'f':
+ case 'R':
+ case 'r':
+ CopyNumber(buffer, &fvalue, sizeof(float), type);
+ return Tcl_NewDoubleObj(fvalue);
+
+ /*
+ * 64-bit IEEE double-precision floating point.
+ */
+
+ case 'd':
+ case 'Q':
+ case 'q':
+ CopyNumber(buffer, &dvalue, sizeof(double), type);
+ return Tcl_NewDoubleObj(dvalue);
}
return NULL;
}
@@ -1731,7 +2003,7 @@ ScanNumber(buffer, type, numberCachePtrPtr)
*----------------------------------------------------------------------
*
* DeleteScanNumberCache --
- *
+ *
* Deletes the hash table acting as a scan number cache.
*
* Results:
@@ -1744,10 +2016,11 @@ ScanNumber(buffer, type, numberCachePtrPtr)
*/
static void
-DeleteScanNumberCache(numberCachePtr)
- Tcl_HashTable *numberCachePtr; /* Pointer to the hash table, or
- * NULL (when the cache has already
- * been deleted due to overflow.) */
+DeleteScanNumberCache(
+ Tcl_HashTable *numberCachePtr)
+ /* Pointer to the hash table, or NULL (when
+ * the cache has already been deleted due to
+ * overflow.) */
{
Tcl_HashEntry *hEntry;
Tcl_HashSearch search;
@@ -1758,7 +2031,7 @@ DeleteScanNumberCache(numberCachePtr)
hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
while (hEntry != NULL) {
- register Tcl_Obj *value = (Tcl_Obj *) Tcl_GetHashValue(hEntry);
+ register Tcl_Obj *value = Tcl_GetHashValue(hEntry);
if (value != NULL) {
Tcl_DecrRefCount(value);
@@ -1767,3 +2040,11 @@ DeleteScanNumberCache(numberCachePtr)
}
Tcl_DeleteHashTable(numberCachePtr);
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */