summaryrefslogtreecommitdiffstats
path: root/generic/tclBinary.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclBinary.c')
-rw-r--r--generic/tclBinary.c490
1 files changed, 358 insertions, 132 deletions
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index a99519a..44fb2f0 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBinary.c,v 1.17 2004/04/06 22:25:48 dgp Exp $
+ * RCS: @(#) $Id: tclBinary.c,v 1.18 2004/05/13 10:12:55 dkf Exp $
*/
#include "tclInt.h"
@@ -67,6 +67,9 @@ static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp,
static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr));
static void DeleteScanNumberCache _ANSI_ARGS_((
Tcl_HashTable *numberCachePtr));
+static int NeedReversing _ANSI_ARGS_((int format));
+static void CopyNumber _ANSI_ARGS_((CONST void *from, void *to,
+ unsigned int length, int type));
/*
* The following object type represents an array of bytes. An array of
@@ -127,7 +130,7 @@ typedef struct ByteArray {
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* Tcl_NewByteArrayObj --
*
@@ -142,7 +145,7 @@ typedef struct ByteArray {
* Side effects:
* Memory allocated for new object and copy of byte array argument.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
@@ -177,7 +180,7 @@ Tcl_NewByteArrayObj(bytes, length)
#endif /* TCL_MEM_DEBUG */
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* Tcl_DbNewByteArrayObj --
*
@@ -199,7 +202,7 @@ Tcl_NewByteArrayObj(bytes, length)
* Side effects:
* Memory allocated for new object and copy of byte array argument.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
@@ -340,7 +343,7 @@ Tcl_GetByteArrayFromObj(objPtr, lengthPtr)
* new array; new bytes are undefined. When shrinking, the
* old array is truncated to the specified length.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
unsigned char *
@@ -374,7 +377,7 @@ Tcl_SetByteArrayLength(objPtr, length)
}
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* SetByteArrayFromAny --
*
@@ -386,7 +389,7 @@ Tcl_SetByteArrayLength(objPtr, length)
* Side effects:
* A ByteArray object is stored as the internal rep of objPtr.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static int
@@ -449,7 +452,7 @@ FreeByteArrayInternalRep(objPtr)
}
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* DupByteArrayInternalRep --
*
@@ -463,7 +466,7 @@ FreeByteArrayInternalRep(objPtr)
* Side effects:
* Allocates memory.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static void
@@ -488,7 +491,7 @@ DupByteArrayInternalRep(srcPtr, copyPtr)
}
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* UpdateStringOfByteArray --
*
@@ -506,7 +509,7 @@ DupByteArrayInternalRep(srcPtr, copyPtr)
* The object becomes a string object -- the internal rep is
* discarded and the typePtr becomes NULL.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static void
@@ -660,25 +663,32 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
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);
@@ -707,7 +717,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
if (count == BINARY_ALL) {
count = listc;
} else if (count > listc) {
- Tcl_AppendResult(interp,
+ Tcl_AppendResult(interp,
"number of elements in list does not match count",
(char *) NULL);
return TCL_ERROR;
@@ -814,7 +824,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
memcpy((VOID *) cursor, (VOID *) bytes,
(size_t) length);
memset((VOID *) (cursor + length), pad,
- (size_t) (count - length));
+ (size_t) (count - length));
}
cursor += count;
break;
@@ -951,13 +961,20 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
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;
@@ -1212,25 +1229,32 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
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;
@@ -1427,6 +1451,135 @@ GetFormatSpec(formatPtr, cmdPtr, countPtr)
/*
*----------------------------------------------------------------------
*
+ * NeedReversing --
+ *
+ * This routine determines, if bytes of a number need to be
+ * reversed. 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:
+ * 1 if reversion is required, 0 if not.
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NeedReversing(format)
+ 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+d: reverse if we're little-endian */
+ case 'Q':
+ case 'R':
+#else /* !WORDS_BIGENDIAN */
+ /* small endian floats: reverse if we're big-endian */
+ case 'q':
+ 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+d: reverse if we're little-endian */
+ case 'Q':
+ case 'R':
+#endif /* WORDS_BIGENDIAN */
+ /* small endian ints: always reverse */
+ case 'i':
+ case 's':
+ case 'w':
+ return 1;
+ }
+
+ Tcl_Panic("unexpected fall-through");
+ 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(from, to, length, type)
+ CONST void *from; /* source */
+ void *to; /* destination */
+ unsigned int length; /* Number of bytes to copy */
+ int type; /* What type of thing are we copying? */
+{
+ if (NeedReversing(type)) {
+ CONST unsigned char *fromPtr = (CONST unsigned char *) from;
+ unsigned char *toPtr = (unsigned char *) 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;
+ }
+ } else {
+ memcpy(to, from, length);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* FormatNumber --
*
* This routine is called by Tcl_BinaryObjCmd to format a number
@@ -1452,50 +1605,59 @@ FormatNumber(interp, type, src, cursorPtr)
long value;
double dvalue;
Tcl_WideInt wvalue;
+ float fvalue;
switch (type) {
case 'd':
+ case 'q':
+ case 'Q':
+ /*
+ * Double-precision floating point values.
+ */
+
+ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ CopyNumber(&dvalue, *cursorPtr, sizeof(double), type);
+ *cursorPtr += sizeof(double);
+ return TCL_OK;
+
case 'f':
+ case 'r':
+ case 'R':
/*
- * For floating point types, we need to copy the data using
- * memcpy to avoid alignment issues.
+ * Single-precision floating point values.
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
return TCL_ERROR;
}
- if (type == 'd') {
- memcpy((VOID *) *cursorPtr, (VOID *) &dvalue, sizeof(double));
- *cursorPtr += sizeof(double);
- } else {
- float fvalue;
- /*
- * 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.
- */
+ /*
+ * 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;
- }
- memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float));
- *cursorPtr += sizeof(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);
@@ -1515,30 +1677,60 @@ FormatNumber(interp, type, src, cursorPtr)
*(*cursorPtr)++ = (unsigned char) wvalue;
}
return TCL_OK;
- default:
+
+ /*
+ * 32-bit integer values.
+ */
+ case 'i':
+ case 'I':
+ case 'n':
if (Tcl_GetLongFromObj(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 (Tcl_GetLongFromObj(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 (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ *(*cursorPtr)++ = (unsigned char) value;
+ return TCL_OK;
+
+ default:
+ Tcl_Panic("unexpected fallthrough");
+ return TCL_ERROR;
}
}
@@ -1572,6 +1764,8 @@ ScanNumber(buffer, type, numberCachePtrPtr)
* different numbers have been scanned. */
{
long value;
+ float fvalue;
+ double dvalue;
Tcl_WideUInt uwvalue;
/*
@@ -1583,92 +1777,114 @@ ScanNumber(buffer, type, numberCachePtrPtr)
*/
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];
- if (value & 0x80) {
- value |= -0x100;
- }
- goto returnNumericObject;
+ value = buffer[0];
+ if (value & 0x80) {
+ value |= -0x100;
+ }
+ 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 (value & 0x8000) {
- value |= -0x10000;
- }
- goto returnNumericObject;
+ }
+ if (value & 0x8000) {
+ value |= -0x10000;
+ }
+ goto returnNumericObject;
- case 'i':
+ /*
+ * 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':
+ } 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.
- */
+ }
+
+ /*
+ * 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);
+ }
- 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;
+
+ hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew);
+ if (!isNew) {
+ return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
}
- returnNumericObject:
- if (*numberCachePtrPtr == NULL) {
+ 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_HashTable *tablePtr = *numberCachePtrPtr;
- register Tcl_HashEntry *hPtr;
- int isNew;
+ register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
- 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);
-
- 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.
- */
- case 'w':
- uwvalue = ((Tcl_WideUInt) buffer[0])
+ /*
+ * 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)
@@ -1676,9 +1892,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)
@@ -1686,23 +1901,34 @@ 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);
}
+ 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;
}
generated by cgit v0.12 at 2024-11-09 16:03:18 (GMT)