aboutsummaryrefslogtreecommitdiffstats
path: root/contrib/tcl/generic/tclBinary.c
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/tcl/generic/tclBinary.c')
-rw-r--r--contrib/tcl/generic/tclBinary.c94
1 files changed, 63 insertions, 31 deletions
diff --git a/contrib/tcl/generic/tclBinary.c b/contrib/tcl/generic/tclBinary.c
index c20d03dcd88d..e15fe4c7f51b 100644
--- a/contrib/tcl/generic/tclBinary.c
+++ b/contrib/tcl/generic/tclBinary.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclBinary.c 1.20 97/08/11 18:43:09
+ * SCCS: @(#) tclBinary.c 1.26 97/11/05 13:02:05
*/
#include <math.h>
@@ -867,13 +867,20 @@ FormatNumber(interp, type, src, cursorPtr)
char cmd = (char)type;
if (cmd == 'd' || cmd == 'f') {
+ /*
+ * For floating point types, we need to copy the data using
+ * memcpy to avoid alignment issues.
+ */
+
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
return TCL_ERROR;
}
if (cmd == 'd') {
- *((double *)(*cursorPtr)) = dvalue;
+ memcpy((*cursorPtr), &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
@@ -881,13 +888,11 @@ FormatNumber(interp, type, src, cursorPtr)
*/
if (fabs(dvalue) > (double)FLT_MAX) {
- *((float *)(*cursorPtr))
- = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
- } else if (fabs(dvalue) < (double)FLT_MIN) {
- *((float *)(*cursorPtr)) = (float) 0.0;
+ fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
} else {
- *((float *)(*cursorPtr)) = (float) dvalue;
+ fvalue = (float) dvalue;
}
+ memcpy((*cursorPtr), &fvalue, sizeof(float));
(*cursorPtr) += sizeof(float);
}
} else {
@@ -938,44 +943,71 @@ FormatNumber(interp, type, src, cursorPtr)
static Tcl_Obj *
ScanNumber(buffer, type)
char *buffer; /* Buffer to scan number from. */
- int type; /* Type of number to scan. */
+ int type; /* Format character from "binary scan" */
{
- int c;
+ int value;
+
+ /*
+ * 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
+ * extension explicitly by checking the high bit and padding with 1's as
+ * needed.
+ */
switch ((char) 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.
- */
+ value = buffer[0];
- c = buffer[0];
- if (c > 127) {
- c -= 256;
+ if (value & 0x80) {
+ value |= -0x100;
}
- return Tcl_NewIntObj(c);
+ return Tcl_NewLongObj((long)value);
case 's':
- return Tcl_NewIntObj((short)(((unsigned char)buffer[0])
- + ((unsigned char)buffer[1] << 8)));
+ value = (((unsigned char)buffer[0])
+ + ((unsigned char)buffer[1] << 8));
+ goto shortValue;
case 'S':
- return Tcl_NewIntObj((short)(((unsigned char)buffer[1])
- + ((unsigned char)buffer[0] << 8)));
+ value = (((unsigned char)buffer[1])
+ + ((unsigned char)buffer[0] << 8));
+ shortValue:
+ if (value & 0x8000) {
+ value |= -0x10000;
+ }
+ return Tcl_NewLongObj((long)value);
case 'i':
- return Tcl_NewIntObj((long) (((unsigned char)buffer[0])
+ value = (((unsigned char)buffer[0])
+ ((unsigned char)buffer[1] << 8)
+ ((unsigned char)buffer[2] << 16)
- + ((unsigned char)buffer[3] << 24)));
+ + ((unsigned char)buffer[3] << 24));
+ goto intValue;
case 'I':
- return Tcl_NewIntObj((long) (((unsigned char)buffer[3])
+ value = (((unsigned char)buffer[3])
+ ((unsigned char)buffer[2] << 8)
+ ((unsigned char)buffer[1] << 16)
- + ((unsigned char)buffer[0] << 24)));
- case 'f':
- return Tcl_NewDoubleObj(*(float*)buffer);
- case 'd':
- return Tcl_NewDoubleObj(*(double*)buffer);
+ + ((unsigned char)buffer[0] << 24));
+ intValue:
+ /*
+ * 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);
+ }
+
+ return Tcl_NewLongObj((long)value);
+ case 'f': {
+ float fvalue;
+ memcpy(&fvalue, buffer, sizeof(float));
+ return Tcl_NewDoubleObj(fvalue);
+ }
+ case 'd': {
+ double dvalue;
+ memcpy(&dvalue, buffer, sizeof(double));
+ return Tcl_NewDoubleObj(dvalue);
+ }
}
return NULL;
}