summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tcl.decls6
-rw-r--r--generic/tcl.h75
-rw-r--r--generic/tclDecls.h10
-rw-r--r--generic/tclLink.c2245
-rw-r--r--generic/tclStubInit.c2
-rw-r--r--generic/tclTest.c152
6 files changed, 2213 insertions, 277 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls
index b2b91a9..ca181b7 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -2333,6 +2333,12 @@ declare 631 {
ClientData callbackData)
}
+# TIP #312
+declare 633 {
+ int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, char *addr,
+ int type, size_t size)
+}
+
# ----- BASELINE -- FOR -- 8.7.0 ----- #
diff --git a/generic/tcl.h b/generic/tcl.h
index 6ec47c6..47bc961 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -1129,26 +1129,67 @@ typedef struct Tcl_DString {
* Types for linked variables:
*/
-#define TCL_LINK_INT 1
-#define TCL_LINK_DOUBLE 2
-#define TCL_LINK_BOOLEAN 3
-#define TCL_LINK_STRING 4
-#define TCL_LINK_WIDE_INT 5
-#define TCL_LINK_CHAR 6
-#define TCL_LINK_UCHAR 7
-#define TCL_LINK_SHORT 8
-#define TCL_LINK_USHORT 9
-#define TCL_LINK_UINT 10
+#if !defined(TCL_NO_DEPRECATED) && !defined(BUILD_tcl)
+/* Here are the legacy values 1-14, will be removed in Tcl 9.0 */
+#define TCL_LINK_INT 1 /* 32bit int -> int */
+#define TCL_LINK_DOUBLE 2 /* 64bit double -> double */
+#define TCL_LINK_BOOLEAN 3 /* tcl boolean -> int */
+#define TCL_LINK_STRING 4 /* 8bit chars -> ckalloc'd string */
+#define TCL_LINK_WIDE_INT 5 /* 64bit int -> Tcl_WideInt */
+#define TCL_LINK_CHAR 6 /* 8bit int -> char */
+#define TCL_LINK_UCHAR 7 /* 8bit uint -> unsigned char */
+#define TCL_LINK_SHORT 8 /* 16bit int -> short */
+#define TCL_LINK_USHORT 9 /* 16bit int -> unsigned short */
+#define TCL_LINK_UINT 10 /* 32bit uint -> int */
#if defined(TCL_WIDE_INT_IS_LONG) || defined(_WIN32) || defined(__CYGWIN__)
-#define TCL_LINK_LONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT)
-#define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT)
+#define TCL_LINK_LONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT)
+#define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT)
#else
-#define TCL_LINK_LONG 11
-#define TCL_LINK_ULONG 12
+#define TCL_LINK_LONG 11 /* long -> long */
+#define TCL_LINK_ULONG 12 /* unsigned long -> unsigned long */
#endif
-#define TCL_LINK_FLOAT 13
-#define TCL_LINK_WIDE_UINT 14
-#define TCL_LINK_READ_ONLY 0x80
+#define TCL_LINK_FLOAT 13 /* 32bit float -> double */
+#define TCL_LINK_WIDE_UINT 14 /* 64bit uint -> wide TODO bignum */
+#else
+
+/* These are the new values, available starting with Tcl 8.7 */
+#define TCL_LINK_I(type) (0x100 | (int)sizeof(type)) /* signed integer */
+#define TCL_LINK_U(type) (0x200 | (int)sizeof(type)) /* unsigned integer */
+#define TCL_LINK_D(type) (0x300 | (int)sizeof(type)) /* float/double/long double */
+#define TCL_LINK_X(type) (0x400 | (int)sizeof(type)) /* Hexadecimal */
+#define TCL_LINK_B(type) (0x500 | (int)sizeof(type)) /* Boolean */
+#define TCL_LINK_C(type) (0xa00 | (int)sizeof(type)) /* Complex */
+
+#define TCL_LINK_INT TCL_LINK_I(int) /* 32bit int -> int */
+#define TCL_LINK_DOUBLE TCL_LINK_D(double) /* 64bit double -> double */
+#define TCL_LINK_BOOLEAN TCL_LINK_B(int) /* tcl boolean -> int */
+#define TCL_LINK_STRING 0 /* 8bit chars -> ckalloc'd string */
+#define TCL_LINK_WIDE_INT TCL_LINK_I(Tcl_WideInt) /* 64bit int -> Tcl_WideInt */
+#define TCL_LINK_CHAR TCL_LINK_I(char) /* 8bit int -> char */
+#define TCL_LINK_UCHAR TCL_LINK_U(char) /* 8bit uint -> unsigned char */
+#define TCL_LINK_SHORT TCL_LINK_I(short) /* 16bit int -> short */
+#define TCL_LINK_USHORT TCL_LINK_U(short) /* 16bit int -> unsigned short */
+#define TCL_LINK_UINT TCL_LINK_U(int) /* 32bit uint -> int */
+#define TCL_LINK_LONG TCL_LINK_I(long)
+#define TCL_LINK_ULONG TCL_LINK_U(long)
+#define TCL_LINK_FLOAT TCL_LINK_D(float) /* 32bit float -> double */
+#define TCL_LINK_WIDE_UINT TCL_LINK_U(Tcl_WideInt) /* 64bit uint -> wide TODO bignum */
+#endif
+
+#define TCL_LINK_CHARS 0x901 /* 8bit chars -> null terminated string
+ last char will always set to \0 */
+#define TCL_LINK_BINARY 0x601 /* fixed size binary byte array */
+#define TCL_LINK_BITARRAY8 0x701 /* 8bit uint -> string, 8 chars 0|1 */
+#define TCL_LINK_BITARRAY16 0x702 /* 16bit uint -> string, 16 chars 0|1 */
+#define TCL_LINK_BITARRAY32 0x704 /* 32bit uint -> string, 32 chars 0|1 */
+#define TCL_LINK_BITARRAY64 0x708 /* 64bit uint -> string, 64 chars 0|1 */
+#define TCL_LINK_BIT8 0x801 /* bit in 8bit uint -> int (0|1) */
+#define TCL_LINK_BIT16 0x802 /* bit in 16bit uint -> int (0|1) */
+#define TCL_LINK_BIT32 0x804 /* bit in 32bit uint -> int (0|1) */
+#define TCL_LINK_BIT64 0x808 /* bit in 64bit uint -> int (0|1) */
+#define TCL_LINK_S5FLOAT 0x904 /* Siemens S5 32bit uint -> double */
+#define TCL_LINK_S5TIME 0x902 /* Siemens S5 16bit uint -> double */
+#define TCL_LINK_READ_ONLY 0x80
/*
*----------------------------------------------------------------------------
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index d543238..2f98068 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -1822,6 +1822,11 @@ EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp,
unsigned int flags,
Tcl_TcpAcceptProc *acceptProc,
ClientData callbackData);
+/* Slot 632 is reserved */
+/* 633 */
+EXTERN int Tcl_LinkArray(Tcl_Interp *interp,
+ const char *varName, char *addr, int type,
+ size_t size);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
@@ -2489,6 +2494,8 @@ typedef struct TclStubs {
int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */
void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */
Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */
+ void (*reserved632)(void);
+ int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, char *addr, int type, size_t size); /* 633 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
@@ -3783,6 +3790,9 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */
#define Tcl_OpenTcpServerEx \
(tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */
+/* Slot 632 is reserved */
+#define Tcl_LinkArray \
+ (tclStubsPtr->tcl_LinkArray) /* 633 */
#endif /* defined(USE_TCL_STUBS) */
diff --git a/generic/tclLink.c b/generic/tclLink.c
index a39dfcd..fd765fa 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -28,24 +28,22 @@ typedef struct Link {
* actual variable may be aliased at that time
* via upvar. */
char *addr; /* Location of C variable. */
+ size_t bytes; /* Size of C variable array.
+ * 0 when single variables
+ * >0 used for array variables */
int type; /* Type of link (TCL_LINK_INT, etc.). */
union {
- char c;
- unsigned char uc;
int i;
unsigned int ui;
- short s;
- unsigned short us;
-#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
- long l;
- unsigned long ul;
-#endif
Tcl_WideInt w;
Tcl_WideUInt uw;
float f;
double d;
+ long double ld;
+ void *p;
} lastValue; /* Last known value of C variable; used to
- * avoid string conversions. */
+ * avoid string conversions. Pointer values
+ * will be used for array links. */
int flags; /* Miscellaneous one-bit values; see below for
* definitions. */
} Link;
@@ -57,10 +55,15 @@ typedef struct Link {
* LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar is
* in progress for this variable, so trace
* callbacks on the variable should be ignored.
+ * LINK_ALLOC_ADDR - 1 means linkPtr->addr was allocated on the heap
+ * LINK_ALLOC_LAST - 1 means linkPtr->valueLast.p was allocated on
+ * the heap
*/
#define LINK_READ_ONLY 1
#define LINK_BEING_UPDATED 2
+#define LINK_ALLOC_ADDR 4
+#define LINK_ALLOC_LAST 8
/*
* Forward references to functions defined later in this file:
@@ -69,6 +72,16 @@ typedef struct Link {
static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp,
const char *name1, const char *name2, int flags);
static Tcl_Obj * ObjValue(Link *linkPtr);
+static void LinkFree(Link *linkPtr);
+static float S5ToFloat(unsigned int value);
+static unsigned int FloatToS5(float value);
+static float S5timeToFloat(unsigned short value);
+static unsigned short FloatToS5time(unsigned short basis, float value);
+static int Hex2Int(const char ch);
+static int HexTo8bit(const char *ch, unsigned char *ret);
+static int HexTo16bit(const char *ch, unsigned short *ret);
+static int HexTo32bit(const char *ch, unsigned int *ret);
+static int HexTo64bit(const char *ch, Tcl_WideUInt *ret);
static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr);
static int GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr);
static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr);
@@ -83,6 +96,24 @@ static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr);
*/
#define LinkedVar(type) (*(type *) linkPtr->addr)
+
+static const int linkCompatTable[] = {
+ 0,
+ TCL_LINK_INT,
+ TCL_LINK_DOUBLE,
+ TCL_LINK_BOOLEAN,
+ TCL_LINK_STRING,
+ TCL_LINK_WIDE_INT,
+ TCL_LINK_CHAR,
+ TCL_LINK_UCHAR,
+ TCL_LINK_SHORT,
+ TCL_LINK_USHORT,
+ TCL_LINK_UINT,
+ TCL_LINK_LONG,
+ TCL_LINK_ULONG,
+ TCL_LINK_FLOAT,
+ TCL_LINK_WIDE_UINT
+};
/*
*----------------------------------------------------------------------
@@ -113,30 +144,65 @@ Tcl_LinkVar(
int type) /* Type of C variable: TCL_LINK_INT, etc. Also
* may have TCL_LINK_READ_ONLY OR'ed in. */
{
+ int code;
+ code = Tcl_LinkArray(interp, varName, addr, type, 1);
+ if (code == TCL_OK) {/* Don't return address because of old behaviour */
+ Tcl_ResetResult(interp);
+ }
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LinkArray --
+ *
+ * Link a C variable array to a Tcl variable so that changes to either one
+ * causes the other to change.
+ *
+ * Results:
+ * The return value is TCL_OK if everything went well or TCL_ERROR if an
+ * error occurred (the interp's result is also set after errors).
+ *
+ * Side effects:
+ * The value at *addr is linked to the Tcl variable "varName", using
+ * "type" to convert between string values for Tcl and binary values for
+ * *addr. If "size" is greater then 1 then link to a tcl list variable.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LinkArray(
+ Tcl_Interp *interp, /* Interpreter in which varName exists. */
+ const char *varName, /* Name of a global variable in interp. */
+ char *addr, /* Address of a C variable to be linked to
+ * varName. If NULL then the necessary space
+ * will be allocated and returned as the
+ * interpreter result. */
+ int type, /* Type of C variable: TCL_LINK_INT, etc. Also
+ * may have TCL_LINK_READ_ONLY OR'ed in. */
+ size_t size) /* Size of C variable array, >1 if array. */
+{
Tcl_Obj *objPtr;
Link *linkPtr;
int code;
- linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
- TCL_GLOBAL_ONLY, LinkTraceProc, (ClientData) NULL);
- if (linkPtr != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "variable '%s' is already linked", varName));
- return TCL_ERROR;
- }
-
- linkPtr = ckalloc(sizeof(Link));
- linkPtr->interp = interp;
- linkPtr->varName = Tcl_NewStringObj(varName, -1);
- Tcl_IncrRefCount(linkPtr->varName);
- linkPtr->addr = addr;
- linkPtr->type = type & ~TCL_LINK_READ_ONLY;
-#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
- || defined(_WIN32) || defined(__CYGWIN__))
- if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
- linkPtr->type = TCL_LINK_LONG;
- } else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) {
- linkPtr->type = TCL_LINK_ULONG;
+ if (size < 1) {
+ Tcl_AppendResult(interp, "wrong array size given", NULL);
+ return TCL_ERROR;
+ }
+ linkPtr = (Link *) Tcl_VarTraceInfo(interp,varName,TCL_GLOBAL_ONLY,
+ LinkTraceProc, (ClientData) NULL);
+ if (linkPtr != NULL) {
+ Tcl_AppendResult(interp, "variable is already linked", NULL);
+ return TCL_ERROR;
+ }
+ linkPtr = (Link *) ckalloc(sizeof(Link));
+ linkPtr->type = type & ~TCL_LINK_READ_ONLY;
+#if !defined(TCL_NO_DEPRECATED)
+ if (linkPtr->type<15){
+ linkPtr->type = linkCompatTable[linkPtr->type&15];
}
#endif
if (type & TCL_LINK_READ_ONLY) {
@@ -144,19 +210,72 @@ Tcl_LinkVar(
} else {
linkPtr->flags = 0;
}
+ switch (linkPtr->type) {
+ case TCL_LINK_C(float):
+ case TCL_LINK_C(double):
+ case TCL_LINK_C(double)+2:
+ case TCL_LINK_C(double)+4:
+ case TCL_LINK_C(double)+8:
+ size = size * 2;
+ linkPtr->bytes = size * (linkPtr->type & 0x7f);
+ break;
+ case TCL_LINK_STRING:
+ linkPtr->bytes = size * sizeof(char);
+ size = 1;/* this is a variable length string, no need to check last value */
+ /* if no address is given create one and use as address the
+ * not needed linkPtr->last */
+ if (addr == NULL) {
+ linkPtr->lastValue.p = ckalloc(linkPtr->bytes);
+ linkPtr->flags |= LINK_ALLOC_LAST;
+ addr = (char *) &linkPtr->lastValue.p;
+ }
+ break;
+ case TCL_LINK_BIT8:
+ case TCL_LINK_BIT16:
+ case TCL_LINK_BIT32:
+ case TCL_LINK_BIT64:
+ if (size > (linkPtr->type & 0x7f)) {
+ Tcl_AppendResult(interp, "size to big", NULL);
+ return TCL_ERROR;
+ }
+ linkPtr->bytes = size - 1;
+ size = 1;
+ break;
+ default:
+ linkPtr->bytes = size * (linkPtr->type & 0x7f);
+ break;
+ }
+
+ /* allocate C variable space in case no address is given */
+ if (addr == NULL) {
+ linkPtr->addr = ckalloc(linkPtr->bytes);
+ linkPtr->flags |= LINK_ALLOC_ADDR;
+ } else {
+ linkPtr->addr = addr;
+ }
+ /* if necessary create space for last used value */
+ if (size > 1) {
+ linkPtr->lastValue.p = ckalloc(linkPtr->bytes);
+ linkPtr->flags |= LINK_ALLOC_LAST;
+ }
+ /* set common structure values */
+ linkPtr->interp = interp;
+ linkPtr->varName = Tcl_NewStringObj(varName, -1);
+ Tcl_IncrRefCount(linkPtr->varName);
objPtr = ObjValue(linkPtr);
if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
- TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
+ TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(linkPtr->varName);
- ckfree(linkPtr);
+ LinkFree(linkPtr);
return TCL_ERROR;
}
- code = Tcl_TraceVar2(interp, varName, NULL,
- TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- LinkTraceProc, linkPtr);
+ code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY | TCL_TRACE_READS
+ | TCL_TRACE_WRITES | TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr);
if (code != TCL_OK) {
Tcl_DecrRefCount(linkPtr->varName);
- ckfree(linkPtr);
+ LinkFree(linkPtr);
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->addr));
}
return code;
}
@@ -194,7 +313,7 @@ Tcl_UnlinkVar(
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, linkPtr);
Tcl_DecrRefCount(linkPtr->varName);
- ckfree(linkPtr);
+ LinkFree(linkPtr);
}
/*
@@ -245,6 +364,575 @@ Tcl_UpdateLinkedVar(
/*
*----------------------------------------------------------------------
*
+ * LinkFree --
+ *
+ * Free's allocated space of given link and link structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+LinkFree(
+ Link * linkPtr) /* Structure describing linked variable. */
+{
+ if (linkPtr->flags & LINK_ALLOC_ADDR) {
+ ckfree(linkPtr->addr);
+ }
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ ckfree(linkPtr->lastValue.p);
+ }
+ ckfree((char *) linkPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ObjValue --
+ *
+ * Converts the value of a C variable to a Tcl_Obj* for use in a Tcl
+ * variable to which it is linked.
+ *
+ * Results:
+ * The return value is a pointer to a Tcl_Obj that represents the value
+ * of the C variable given by linkPtr.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ObjValue(
+ Link *linkPtr) /* Structure describing linked variable. */
+{
+ char *p;
+ Tcl_Obj *resultObj;
+ int objc;
+ static Tcl_Obj **objv = NULL;
+ int i;
+ int j;
+ static const char hexdigit[] = "0123456789abcdef";
+ char c[64];
+
+ switch (linkPtr->type) {
+ case TCL_LINK_CHAR:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ char *pc = linkPtr->lastValue.p;
+ memcpy(pc, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(char);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewIntObj(pc[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.i = LinkedVar(char);
+ return Tcl_NewIntObj(linkPtr->lastValue.i);
+ case TCL_LINK_SHORT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ short *ps = linkPtr->lastValue.p;
+ memcpy(ps, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(short);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewIntObj(ps[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.i = LinkedVar(short);
+ return Tcl_NewIntObj(linkPtr->lastValue.i);
+ case TCL_LINK_INT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ int *pi = linkPtr->lastValue.p;
+ memcpy(pi, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(int);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewIntObj(pi[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.i = LinkedVar(int);
+ return Tcl_NewIntObj(linkPtr->lastValue.i);
+ case TCL_LINK_WIDE_INT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ Tcl_WideInt *pw = linkPtr->lastValue.p;
+ memcpy(pw, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(Tcl_WideInt);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewWideIntObj(pw[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.w = LinkedVar(Tcl_WideInt);
+ return Tcl_NewWideIntObj(linkPtr->lastValue.w);
+ case TCL_LINK_UCHAR:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned char *puc = linkPtr->lastValue.p;
+ memcpy(puc, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(unsigned char);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewIntObj(puc[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.i = LinkedVar(unsigned char);
+ return Tcl_NewIntObj(linkPtr->lastValue.i);
+ case TCL_LINK_USHORT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned short *pus = linkPtr->lastValue.p;
+ memcpy(pus, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(unsigned short);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewIntObj(pus[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.ui = LinkedVar(unsigned short);
+ return Tcl_NewIntObj((int)linkPtr->lastValue.ui);
+ case TCL_LINK_UINT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned int *pui = linkPtr->lastValue.p;
+ memcpy(pui, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(unsigned int);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewWideIntObj(pui[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.ui = LinkedVar(unsigned int);
+ return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui);
+ case TCL_LINK_WIDE_UINT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ Tcl_WideUInt *puw = linkPtr->lastValue.p;
+ memcpy(puw, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(Tcl_WideUInt);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewWideIntObj(puw[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
+ return Tcl_NewWideIntObj((Tcl_WideUInt) linkPtr->lastValue.uw);
+ case TCL_LINK_FLOAT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ float *pf = linkPtr->lastValue.p;
+ memcpy(pf, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(float);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewDoubleObj(pf[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.f = LinkedVar(float);
+ return Tcl_NewDoubleObj(linkPtr->lastValue.f);
+ case TCL_LINK_DOUBLE:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ double *pd = linkPtr->lastValue.p;
+ memcpy(pd, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(double);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewDoubleObj(pd[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.d = LinkedVar(double);
+ return Tcl_NewDoubleObj(linkPtr->lastValue.d);
+ case TCL_LINK_DOUBLE+2:
+ case TCL_LINK_DOUBLE+4:
+ case TCL_LINK_DOUBLE+8:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ long double *pld = linkPtr->lastValue.p;
+ memcpy(pld, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(long double);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewDoubleObj((double)pld[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.ld = LinkedVar(long double);
+ return Tcl_NewDoubleObj(linkPtr->lastValue.ld);
+ case TCL_LINK_C(float): {
+ float *pf = linkPtr->lastValue.p;
+ memcpy(pf, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(float);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewDoubleObj((double) pf[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ case TCL_LINK_C(double): {
+ double *pd = linkPtr->lastValue.p;
+ memcpy(pd, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(double);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewDoubleObj(pd[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ case TCL_LINK_C(double)+2:
+ case TCL_LINK_C(double)+4:
+ case TCL_LINK_C(double)+8: {
+ long double *pld = linkPtr->lastValue.p;
+ memcpy(pld, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(long double);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewDoubleObj((double)pld[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ case TCL_LINK_STRING:
+ p = (*(char **) linkPtr->addr);
+ if (p == NULL) {
+ resultObj = Tcl_NewStringObj("NULL", 4);
+ return resultObj;
+ }
+ return Tcl_NewStringObj(p, -1);
+ case TCL_LINK_CHARS:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ char *pc = linkPtr->lastValue.p;
+ memcpy(pc, linkPtr->addr, linkPtr->bytes);
+ pc[linkPtr->bytes - 1] = '\0'; /* take care of proper string end */
+ return Tcl_NewStringObj(pc, linkPtr->bytes);
+ }
+ linkPtr->lastValue.i = '\0';
+ return Tcl_NewStringObj("", 1);
+ case TCL_LINK_BINARY: {
+ unsigned char uc;
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.p, linkPtr->addr, linkPtr->bytes);
+ return Tcl_NewByteArrayObj((unsigned char *) linkPtr->addr,
+ linkPtr->bytes);
+ }
+ linkPtr->lastValue.i = LinkedVar(unsigned char);
+ uc = (unsigned char) linkPtr->lastValue.i;
+ return Tcl_NewByteArrayObj(&uc, 1);
+ }
+ case TCL_LINK_X(char):
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned char *puc = linkPtr->lastValue.p;
+ memcpy(puc, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(unsigned char);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ c[0] = '0';
+ c[1] = 'x';
+ for (i = 0; i < objc; i++) {
+ c[3] = hexdigit[puc[i] & 0xf];
+ c[2] = hexdigit[(puc[i] >> 4) & 0xf];
+ objv[i] = Tcl_NewStringObj(c, 4);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.i = LinkedVar(unsigned char);
+ c[0] = '0';
+ c[1] = 'x';
+ c[3] = hexdigit[linkPtr->lastValue.i & 0xf];
+ c[2] = hexdigit[(linkPtr->lastValue.i >> 4) & 0xf];
+ return Tcl_NewStringObj(c, 4);
+ case TCL_LINK_X(short):
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned short *pus = linkPtr->lastValue.p;
+ memcpy(pus, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(unsigned short);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ c[0] = '0';
+ c[1] = 'x';
+ for (i = 0; i < objc; i++) {
+ c[5] = hexdigit[pus[i] & 0xf];
+ c[4] = hexdigit[(pus[i] >> 4) & 0xf];
+ c[3] = hexdigit[(pus[i] >> 8) & 0xf];
+ c[2] = hexdigit[(pus[i] >> 12) & 0xf];
+ objv[i] = Tcl_NewStringObj(c, 6);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.ui = LinkedVar(unsigned short);
+ c[0] = '0';
+ c[1] = 'x';
+ c[5] = hexdigit[linkPtr->lastValue.ui & 0xf];
+ c[4] = hexdigit[(linkPtr->lastValue.ui >> 4) & 0xf];
+ c[3] = hexdigit[(linkPtr->lastValue.ui >> 8) & 0xf];
+ c[2] = hexdigit[(linkPtr->lastValue.ui >> 12) & 0xf];
+ return Tcl_NewStringObj(c, 6);
+ case TCL_LINK_X(int):
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned int *pui = linkPtr->lastValue.p;
+ memcpy(pui, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(unsigned int);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ c[0] = '0';
+ c[1] = 'x';
+ for (i = 0; i < objc; i++) {
+ c[9] = hexdigit[pui[i] & 0xf];
+ c[8] = hexdigit[(pui[i] >> 4) & 0xf];
+ c[7] = hexdigit[(pui[i] >> 8) & 0xf];
+ c[6] = hexdigit[(pui[i] >> 12) & 0xf];
+ c[5] = hexdigit[(pui[i] >> 16) & 0xf];
+ c[4] = hexdigit[(pui[i] >> 20) & 0xf];
+ c[3] = hexdigit[(pui[i] >> 24) & 0xf];
+ c[2] = hexdigit[(pui[i] >> 28) & 0xf];
+ objv[i] = Tcl_NewStringObj(c, 10);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.ui = LinkedVar(unsigned int);
+ c[0] = '0';
+ c[1] = 'x';
+ c[9] = hexdigit[linkPtr->lastValue.ui & 0xf];
+ c[8] = hexdigit[(linkPtr->lastValue.ui >> 4) & 0xf];
+ c[7] = hexdigit[(linkPtr->lastValue.ui >> 8) & 0xf];
+ c[6] = hexdigit[(linkPtr->lastValue.ui >> 12) & 0xf];
+ c[5] = hexdigit[(linkPtr->lastValue.ui >> 16) & 0xf];
+ c[4] = hexdigit[(linkPtr->lastValue.ui >> 20) & 0xf];
+ c[3] = hexdigit[(linkPtr->lastValue.ui >> 24) & 0xf];
+ c[2] = hexdigit[(linkPtr->lastValue.ui >> 28) & 0xf];
+ return Tcl_NewStringObj(c, 10);
+ case TCL_LINK_X(Tcl_WideInt):
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ Tcl_WideUInt *puw = linkPtr->lastValue.p;
+ memcpy(puw, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(Tcl_WideUInt);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ c[0] = '0';
+ c[1] = 'x';
+ for (i = 0; i < objc; i++) {
+ c[17] = hexdigit[puw[i] & 0xf];
+ c[16] = hexdigit[(puw[i] >> 4) & 0xf];
+ c[15] = hexdigit[(puw[i] >> 8) & 0xf];
+ c[14] = hexdigit[(puw[i] >> 12) & 0xf];
+ c[13] = hexdigit[(puw[i] >> 16) & 0xf];
+ c[12] = hexdigit[(puw[i] >> 20) & 0xf];
+ c[11] = hexdigit[(puw[i] >> 24) & 0xf];
+ c[10] = hexdigit[(puw[i] >> 28) & 0xf];
+ c[9] = hexdigit[(puw[i] >> 32) & 0xf];
+ c[8] = hexdigit[(puw[i] >> 36) & 0xf];
+ c[7] = hexdigit[(puw[i] >> 40) & 0xf];
+ c[6] = hexdigit[(puw[i] >> 44) & 0xf];
+ c[5] = hexdigit[(puw[i] >> 48) & 0xf];
+ c[4] = hexdigit[(puw[i] >> 52) & 0xf];
+ c[3] = hexdigit[(puw[i] >> 56) & 0xf];
+ c[2] = hexdigit[(puw[i] >> 60) & 0xf];
+ objv[i] = Tcl_NewStringObj(c, 18);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
+ c[0] = '0';
+ c[1] = 'x';
+ c[17] = hexdigit[linkPtr->lastValue.uw & 0xf];
+ c[16] = hexdigit[(linkPtr->lastValue.uw >> 4) & 0xf];
+ c[15] = hexdigit[(linkPtr->lastValue.uw >> 8) & 0xf];
+ c[14] = hexdigit[(linkPtr->lastValue.uw >> 12) & 0xf];
+ c[13] = hexdigit[(linkPtr->lastValue.uw >> 16) & 0xf];
+ c[12] = hexdigit[(linkPtr->lastValue.uw >> 20) & 0xf];
+ c[11] = hexdigit[(linkPtr->lastValue.uw >> 24) & 0xf];
+ c[10] = hexdigit[(linkPtr->lastValue.uw >> 28) & 0xf];
+ c[9] = hexdigit[(linkPtr->lastValue.uw >> 32) & 0xf];
+ c[8] = hexdigit[(linkPtr->lastValue.uw >> 36) & 0xf];
+ c[7] = hexdigit[(linkPtr->lastValue.uw >> 40) & 0xf];
+ c[6] = hexdigit[(linkPtr->lastValue.uw >> 44) & 0xf];
+ c[5] = hexdigit[(linkPtr->lastValue.uw >> 48) & 0xf];
+ c[4] = hexdigit[(linkPtr->lastValue.uw >> 52) & 0xf];
+ c[3] = hexdigit[(linkPtr->lastValue.uw >> 56) & 0xf];
+ c[2] = hexdigit[(linkPtr->lastValue.uw >> 60) & 0xf];
+ return Tcl_NewStringObj(c, 18);
+ case TCL_LINK_BITARRAY8:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned char *puc = linkPtr->lastValue.p;
+ memcpy(puc, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(unsigned char);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ for (j = 0; j < 8; j++) {
+ c[j] = (puc[i] & (1 << (7 - j))) ? '1' : '0';
+ }
+ objv[i] = Tcl_NewStringObj(c, 8);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.i = LinkedVar(unsigned char);
+ for (j = 0; j < 8; j++) {
+ c[j] = (linkPtr->lastValue.i & (1 << (7 - j))) ? '1' : '0';
+ }
+ return Tcl_NewStringObj(c, 8);
+ case TCL_LINK_BITARRAY16:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned short *pus = linkPtr->lastValue.p;
+ memcpy(pus, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(unsigned short);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ for (j = 0; j < 16; j++) {
+ c[j] = (pus[i] & (1 << (15 - j))) ? '1' : '0';
+ }
+ objv[i] = Tcl_NewStringObj(c, 16);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.ui = LinkedVar(unsigned short);
+ for (j = 0; j < 16; j++) {
+ c[j] = (linkPtr->lastValue.ui & (1 << (15 - j))) ? '1' : '0';
+ }
+ return Tcl_NewStringObj(c, 16);
+ case TCL_LINK_BITARRAY32:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned int *pui = linkPtr->lastValue.p;
+ memcpy(pui, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(unsigned int);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ for (j = 0; j < 32; j++) {
+ c[j] = (pui[i] & (1 << (31 - j))) ? '1' : '0';
+ }
+ objv[i] = Tcl_NewStringObj(c, 32);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.ui = LinkedVar(unsigned int);
+ for (j = 0; j < 32; j++) {
+ c[j] = (linkPtr->lastValue.ui & (1 << (31 - j))) ? '1' : '0';
+ }
+ return Tcl_NewStringObj(c, 32);
+ case TCL_LINK_BITARRAY64:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ Tcl_WideUInt *puw = linkPtr->lastValue.p;
+ memcpy(puw, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(Tcl_WideUInt);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ for (j = 0; j < 64; j++) {
+ c[j] = (puw[i] & (1 << (63 - j))) ? '1' : '0';
+ }
+ objv[i] = Tcl_NewStringObj(c, 64);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
+ for (j = 0; j < 64; j++) {
+ c[j] = (linkPtr->lastValue.uw & (1 << (63 - j))) ? '1' : '0';
+ }
+ return Tcl_NewStringObj(c, 64);
+ case TCL_LINK_B(char):
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned char *puc = linkPtr->lastValue.p;
+ memcpy(puc, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(unsigned char);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewBooleanObj(puc[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.i = LinkedVar(unsigned char);
+ return Tcl_NewBooleanObj(linkPtr->lastValue.i);
+ case TCL_LINK_B(short):
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned short *pus = linkPtr->lastValue.p;
+ memcpy(pus, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(unsigned short);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewBooleanObj(pus[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.ui = LinkedVar(unsigned short);
+ return Tcl_NewBooleanObj(linkPtr->lastValue.ui);
+ case TCL_LINK_B(int):
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned int *pui = linkPtr->lastValue.p;
+ memcpy(pui, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(unsigned int);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewBooleanObj(pui[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.ui = LinkedVar(unsigned int);
+ return Tcl_NewBooleanObj(linkPtr->lastValue.ui);
+ case TCL_LINK_B(Tcl_WideInt):
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ Tcl_WideUInt *puw = linkPtr->lastValue.p;
+ memcpy(puw, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(Tcl_WideUInt);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewBooleanObj(puw[i]);
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
+ return Tcl_NewBooleanObj(linkPtr->lastValue.uw);
+ case TCL_LINK_BIT8:
+ linkPtr->lastValue.i = LinkedVar(unsigned char);
+ return Tcl_NewIntObj((linkPtr->lastValue.i & (1 << linkPtr->bytes)) ? 1 : 0);
+ case TCL_LINK_BIT16:
+ linkPtr->lastValue.ui = LinkedVar(unsigned short);
+ return Tcl_NewIntObj((linkPtr->lastValue.ui & (1 << linkPtr->bytes)) ? 1 : 0);
+ case TCL_LINK_BIT32:
+ linkPtr->lastValue.ui = LinkedVar(unsigned int);
+ return Tcl_NewIntObj((linkPtr->lastValue.ui & (1 << linkPtr->bytes)) ? 1 : 0);
+ case TCL_LINK_BIT64:
+ linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
+ return Tcl_NewIntObj((linkPtr->lastValue.uw & (1 << linkPtr->bytes)) ? 1 : 0);
+ case TCL_LINK_S5FLOAT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned int *pui = linkPtr->lastValue.p;
+ memcpy(pui, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(unsigned int);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewDoubleObj(S5ToFloat(pui[i]));
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.ui = LinkedVar(unsigned int);
+ return Tcl_NewDoubleObj(S5ToFloat(linkPtr->lastValue.ui));
+ case TCL_LINK_S5TIME:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned short *pus = linkPtr->lastValue.p;
+ memcpy(pus, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes / sizeof(unsigned short);
+ objv = (Tcl_Obj **) ckrealloc((char *) objv, objc * sizeof(Tcl_Obj *));
+ for (i = 0; i < objc; i++) {
+ objv[i] = Tcl_NewDoubleObj(S5timeToFloat(pus[i]));
+ }
+ return Tcl_NewListObj(objc, objv);
+ }
+ linkPtr->lastValue.ui = LinkedVar(unsigned short);
+ return Tcl_NewDoubleObj(S5timeToFloat((unsigned short)linkPtr->lastValue.ui));
+ /*
+ * This code only gets executed if the link type is unknown (shouldn't
+ * ever happen).
+ */
+ default:
+ resultObj = Tcl_NewStringObj("??", 2);
+ return resultObj;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* LinkTraceProc --
*
* This function is invoked when a linked Tcl variable is read, written,
@@ -280,6 +968,10 @@ LinkTraceProc(
int valueInt;
Tcl_WideInt valueWide;
double valueDouble;
+ int objc;
+ Tcl_Obj **objv;
+ int i;
+ int j;
/*
* If the variable is being unset, then just re-create it (with a trace)
@@ -289,7 +981,7 @@ LinkTraceProc(
if (flags & TCL_TRACE_UNSETS) {
if (Tcl_InterpDeleted(interp)) {
Tcl_DecrRefCount(linkPtr->varName);
- ckfree(linkPtr);
+ LinkFree(linkPtr);
} else if (flags & TCL_TRACE_DESTROYED) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
@@ -316,51 +1008,85 @@ LinkTraceProc(
*/
if (flags & TCL_TRACE_READS) {
- switch (linkPtr->type) {
- case TCL_LINK_INT:
- case TCL_LINK_BOOLEAN:
- changed = (LinkedVar(int) != linkPtr->lastValue.i);
- break;
- case TCL_LINK_DOUBLE:
- changed = (LinkedVar(double) != linkPtr->lastValue.d);
- break;
- case TCL_LINK_WIDE_INT:
- changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w);
- break;
- case TCL_LINK_WIDE_UINT:
- changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw);
- break;
- case TCL_LINK_CHAR:
- changed = (LinkedVar(char) != linkPtr->lastValue.c);
- break;
- case TCL_LINK_UCHAR:
- changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc);
- break;
- case TCL_LINK_SHORT:
- changed = (LinkedVar(short) != linkPtr->lastValue.s);
- break;
- case TCL_LINK_USHORT:
- changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us);
- break;
- case TCL_LINK_UINT:
- changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui);
- break;
-#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
- case TCL_LINK_LONG:
- changed = (LinkedVar(long) != linkPtr->lastValue.l);
- break;
- case TCL_LINK_ULONG:
- changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul);
- break;
-#endif
- case TCL_LINK_FLOAT:
- changed = (LinkedVar(float) != linkPtr->lastValue.f);
- break;
- case TCL_LINK_STRING:
- changed = 1;
- break;
- default:
- return (char *) "internal error: bad linked variable type";
+ /* variable arrays and TCL_LINK_C() */
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ changed = memcmp(linkPtr->addr, linkPtr->lastValue.p, linkPtr->bytes);
+ /* single variables */
+ } else {
+ switch (linkPtr->type) {
+ case TCL_LINK_CHARS:
+ case TCL_LINK_STRING:
+ case TCL_LINK_BINARY:
+ changed = 1;
+ break;
+ case TCL_LINK_CHAR:
+ changed = (LinkedVar(char) != (char)linkPtr->lastValue.i);
+ break;
+ case TCL_LINK_UCHAR:
+ case TCL_LINK_X(char):
+ case TCL_LINK_BITARRAY8:
+ case TCL_LINK_B(char):
+ changed = (LinkedVar(unsigned char) != (unsigned char)linkPtr->lastValue.i);
+ break;
+ case TCL_LINK_SHORT:
+ changed = (LinkedVar(short) != (short)linkPtr->lastValue.i);
+ break;
+ case TCL_LINK_USHORT:
+ case TCL_LINK_X(short):
+ case TCL_LINK_BITARRAY16:
+ case TCL_LINK_B(short):
+ case TCL_LINK_S5TIME:
+ changed = (LinkedVar(unsigned short) != (unsigned short)linkPtr->lastValue.ui);
+ break;
+ case TCL_LINK_INT:
+ changed = (LinkedVar(int) != linkPtr->lastValue.i);
+ break;
+ case TCL_LINK_UINT:
+ case TCL_LINK_X(int):
+ case TCL_LINK_BITARRAY32:
+ case TCL_LINK_B(int):
+ case TCL_LINK_S5FLOAT:
+ changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui);
+ break;
+ case TCL_LINK_WIDE_INT:
+ changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w);
+ break;
+ case TCL_LINK_WIDE_UINT:
+ case TCL_LINK_X(Tcl_WideInt):
+ case TCL_LINK_BITARRAY64:
+ case TCL_LINK_B(Tcl_WideInt):
+ changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw);
+ break;
+ case TCL_LINK_FLOAT:
+ changed = (LinkedVar(float) != linkPtr->lastValue.f);
+ break;
+ case TCL_LINK_DOUBLE:
+ changed = (LinkedVar(double) != linkPtr->lastValue.d);
+ break;
+ case TCL_LINK_DOUBLE+2:
+ case TCL_LINK_DOUBLE+4:
+ case TCL_LINK_DOUBLE+8:
+ changed = (LinkedVar(long double) != linkPtr->lastValue.ld);
+ break;
+ case TCL_LINK_BIT8:
+ changed = (LinkedVar(unsigned char) | (1 << linkPtr->bytes)) !=
+ ((unsigned char)linkPtr->lastValue.i | (1 << linkPtr->bytes));
+ break;
+ case TCL_LINK_BIT16:
+ changed = (LinkedVar(unsigned short) | (1 << linkPtr->bytes)) !=
+ ((unsigned short)linkPtr->lastValue.ui | (1 << linkPtr->bytes));
+ break;
+ case TCL_LINK_BIT32:
+ changed = (LinkedVar(unsigned int) | (1 << linkPtr->bytes)) !=
+ (linkPtr->lastValue.ui | (1 << linkPtr->bytes));
+ break;
+ case TCL_LINK_BIT64:
+ changed = (LinkedVar(Tcl_WideUInt) | (1 << linkPtr->bytes)) !=
+ (linkPtr->lastValue.uw | (1 << linkPtr->bytes));
+ break;
+ default:
+ changed = 0;
+ }
}
if (changed) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
@@ -372,7 +1098,7 @@ LinkTraceProc(
/*
* For writes, first make sure that the variable is writable. Then convert
* the Tcl value to C if possible. If the variable isn't writable or can't
- * be converted, then restore the varaible's old value and return an
+ * be converted, then restore the variable's old value and return an
* error. Another tricky thing: we have to save and restore the interp's
* result, since the variable access could occur when the result has been
* partially set.
@@ -381,271 +1107,1270 @@ LinkTraceProc(
if (linkPtr->flags & LINK_READ_ONLY) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return (char *) "linked variable is read-only";
+ return (char *)"linked variable is read-only";
}
- valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY);
+ valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName, NULL, TCL_GLOBAL_ONLY);
if (valueObj == NULL) {
/*
* This shouldn't ever happen.
*/
-
- return (char *) "internal error: linked variable couldn't be read";
+ return (char *)"internal error: linked variable couldn't be read";
}
switch (linkPtr->type) {
+ case TCL_LINK_CHAR:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ char *pc = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(char)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if ((Tcl_GetIntFromObj(NULL, objv[i], &valueInt) != TCL_OK
+ || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX)
+ && GetInvalidIntFromObj(objv[i], &valueInt) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have char values";
+ }
+ pc[i] = (char) valueInt;
+ }
+ memcpy(linkPtr->addr, pc, linkPtr->bytes);
+ break;
+ }
+ if ((Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX)
+ && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable must have char value";
+ }
+ LinkedVar(char) = linkPtr->lastValue.i = valueInt;
+ break;
+ case TCL_LINK_UCHAR:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned char *puc = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(unsigned char)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if ((Tcl_GetIntFromObj(NULL, objv[i], &valueInt) != TCL_OK
+ || valueInt < 0 || valueInt > UCHAR_MAX)
+ && GetInvalidIntFromObj(objv[i], &valueInt) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have unsigned char values";
+ }
+ puc[i] = (unsigned char) valueInt;
+ }
+ memcpy(linkPtr->addr, puc, linkPtr->bytes);
+ break;
+ }
+ if ((Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ || valueInt < 0 || valueInt > UCHAR_MAX)
+ && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable must have unsigned char value";
+ }
+ linkPtr->lastValue.i = valueInt;
+ LinkedVar(unsigned char) = (unsigned char)linkPtr->lastValue.i;
+ break;
+ case TCL_LINK_SHORT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ short *ps = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(short)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if ((Tcl_GetIntFromObj(NULL, objv[i], &valueInt) != TCL_OK
+ || valueInt < SHRT_MIN || valueInt > SHRT_MAX)
+ && GetInvalidIntFromObj(objv[i], &valueInt) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have short values";
+ }
+ ps[i] = (short) valueInt;
+ }
+ memcpy(linkPtr->addr, ps, linkPtr->bytes);
+ break;
+ }
+ if ((Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ || valueInt < SHRT_MIN || valueInt > SHRT_MAX)
+ && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable must have short value";
+ }
+ linkPtr->lastValue.i = valueInt;
+ LinkedVar(short) = (short) linkPtr->lastValue.i;
+ break;
+ case TCL_LINK_USHORT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned short *pus = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(unsigned short)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if ((Tcl_GetIntFromObj(NULL, objv[i], &valueInt) != TCL_OK
+ || valueInt < 0 || valueInt > USHRT_MAX)
+ && GetInvalidIntFromObj(objv[i], &valueInt) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have unsigned short values";
+ }
+ pus[i] = (unsigned short) valueInt;
+ }
+ memcpy(linkPtr->addr, pus, linkPtr->bytes);
+ break;
+ }
+ if ((Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ || valueInt < 0 || valueInt > USHRT_MAX)
+ && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable must have unsigned short value";
+ }
+ linkPtr->lastValue.ui = valueInt;
+ LinkedVar(unsigned short) = (unsigned short) linkPtr->lastValue.ui;
+ break;
case TCL_LINK_INT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ int *pi = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(int)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetIntFromObj(NULL, objv[i], &pi[i]) != TCL_OK
+ && GetInvalidIntFromObj(objv[i], &pi[i]) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have integer values";
+ }
+ }
+ memcpy(linkPtr->addr, pi, linkPtr->bytes);
+ break;
+ }
if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK
&& GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have integer value";
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable must have integer value";
}
LinkedVar(int) = linkPtr->lastValue.i;
break;
-
+ case TCL_LINK_UINT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned int *pui = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(unsigned int)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if ((Tcl_GetWideIntFromObj(NULL, objv[i], &valueWide) != TCL_OK
+ || valueWide < 0 || valueWide > UINT_MAX)
+ && GetInvalidWideFromObj(objv[i], &valueWide) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have unsigned integer values";
+ }
+ pui[i] = (unsigned int) valueWide;
+ }
+ memcpy(linkPtr->addr, pui, linkPtr->bytes);
+ break;
+ }
+ if ((Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
+ || valueWide < 0 || valueWide > UINT_MAX)
+ && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable must have unsigned integer value";
+ }
+ linkPtr->lastValue.ui = (unsigned int) valueWide;
+ LinkedVar(unsigned int) = linkPtr->lastValue.ui;
+ break;
case TCL_LINK_WIDE_INT:
- if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ Tcl_WideInt *pw = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(Tcl_WideInt)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetWideIntFromObj(NULL, objv[i], &pw[i]) != TCL_OK
+ && GetInvalidWideFromObj(objv[i], &pw[i]) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have integer values";
+ }
+ }
+ memcpy(linkPtr->addr, pw, linkPtr->bytes);
+ break;
+ }
+ if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w)
&& GetInvalidWideFromObj(valueObj, &linkPtr->lastValue.w) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return (char *) "variable must have integer value";
+ return (char *)"variable must have integer value";
}
LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
break;
-
- case TCL_LINK_DOUBLE:
- if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) {
-#ifdef ACCEPT_NAN
- if (valueObj->typePtr != &tclDoubleType) {
-#endif
- if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) {
+ case TCL_LINK_WIDE_UINT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ Tcl_WideUInt *puw = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(Tcl_WideUInt)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if ((Tcl_GetWideIntFromObj(NULL, objv[i], &valueWide) != TCL_OK
+ || valueWide < 0)
+ && GetInvalidWideFromObj(objv[i], &valueWide) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have real value";
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have Tcl_WideUInt values";
}
-#ifdef ACCEPT_NAN
+ puw[i] = (Tcl_WideUInt) valueWide;
}
- linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
-#endif
+ memcpy(linkPtr->addr, linkPtr->lastValue.p, linkPtr->bytes);
+ break;
}
- LinkedVar(double) = linkPtr->lastValue.d;
- break;
-
- case TCL_LINK_BOOLEAN:
- if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) {
+ if ((Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
+ || valueWide < 0)
+ && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return (char *) "variable must have boolean value";
+ return (char *)"variable must have Tcl_WideUInt value";
}
- LinkedVar(int) = linkPtr->lastValue.i;
+ linkPtr->lastValue.uw = (Tcl_WideUInt) valueWide;
+ LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
break;
-
- case TCL_LINK_CHAR:
- if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
- && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
- || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
+ case TCL_LINK_FLOAT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ float *pf = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(float)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if ((Tcl_GetDoubleFromObj(interp, objv[i], &valueDouble) != TCL_OK
+ || valueDouble < -FLT_MAX || valueDouble > FLT_MAX)
+ && GetInvalidDoubleFromObj(objv[i], &valueDouble) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have float values";
+ }
+ pf[i] = (float) valueDouble;
+ }
+ memcpy(linkPtr->addr, linkPtr->lastValue.p, linkPtr->bytes);
+ break;
+ }
+ if ((Tcl_GetDoubleFromObj(interp, valueObj, &valueDouble) != TCL_OK
+ || valueDouble < -FLT_MAX || valueDouble > FLT_MAX)
+ && GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return (char *) "variable must have char value";
+ return (char *)"variable must have float value";
}
- LinkedVar(char) = linkPtr->lastValue.c = (char)valueInt;
+ linkPtr->lastValue.f = (float) valueDouble;
+ LinkedVar(float) = linkPtr->lastValue.f;
break;
-
- case TCL_LINK_UCHAR:
- if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
- && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
- || valueInt < 0 || valueInt > UCHAR_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned char value";
+ case TCL_LINK_DOUBLE:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ double *pd = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(double)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetDoubleFromObj(NULL, objv[i], &pd[i]) != TCL_OK
+ && GetInvalidDoubleFromObj(objv[i], &pd[i]) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have real values";
+ }
+ }
+ memcpy(linkPtr->addr, pd, linkPtr->bytes);
+ break;
+ }
+ if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK
+ && GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *)"variable must have real value";
}
- LinkedVar(unsigned char) = linkPtr->lastValue.uc = (unsigned char) valueInt;
+ LinkedVar(double) = linkPtr->lastValue.d;
break;
-
- case TCL_LINK_SHORT:
- if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
- && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
- || valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
+ case TCL_LINK_DOUBLE+2:
+ case TCL_LINK_DOUBLE+4:
+ case TCL_LINK_DOUBLE+8:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ long double *pld = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(long double)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if ((Tcl_GetDoubleFromObj(interp, objv[i], &valueDouble) != TCL_OK)
+ && GetInvalidDoubleFromObj(objv[i], &valueDouble) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have double values";
+ }
+ pld[i] = (long double) valueDouble;
+ }
+ memcpy(linkPtr->addr, pld, linkPtr->bytes);
+ break;
+ }
+ if ((Tcl_GetDoubleFromObj(interp, valueObj, &valueDouble) != TCL_OK)
+ && GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return (char *) "variable must have short value";
+ return (char *)"variable must have double values";
}
- LinkedVar(short) = linkPtr->lastValue.s = (short)valueInt;
+ linkPtr->lastValue.ld = valueDouble;
+ LinkedVar(long double) = linkPtr->lastValue.ld;
break;
-
- case TCL_LINK_USHORT:
- if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
- && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
- || valueInt < 0 || valueInt > USHRT_MAX) {
+ case TCL_LINK_C(float): {
+ float *pf = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(float)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetDoubleFromObj(interp, objv[i], &valueDouble) != TCL_OK
+ || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have float values";
+ }
+ pf[i] = (float) valueDouble;
+ }
+ memcpy(linkPtr->addr, pf, linkPtr->bytes);
+ break;
+ }
+ case TCL_LINK_C(double): {
+ double *pd = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(double)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetDoubleFromObj(interp, objv[i], &valueDouble) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have double values";
+ }
+ pd[i] = valueDouble;
+ }
+ memcpy(linkPtr->addr, pd, linkPtr->bytes);
+ break;
+ }
+ case TCL_LINK_C(double)+2:
+ case TCL_LINK_C(double)+4:
+ case TCL_LINK_C(double)+8: {
+ long double *pld = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(long double)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetDoubleFromObj(interp, objv[i], &valueDouble) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have double values";
+ }
+ pld[i] = valueDouble;
+ }
+ memcpy(linkPtr->addr, pld, linkPtr->bytes);
+ break;
+ }
+ case TCL_LINK_STRING:
+ value = TclGetString(valueObj);
+ valueLength = valueObj->length + 1;
+ pp = (char **) linkPtr->addr;
+ *pp = ckrealloc(*pp, valueLength);
+ memcpy(*pp, value, valueLength);
+ break;
+ case TCL_LINK_CHARS:
+ value = (char *) Tcl_GetString(valueObj);
+ valueLength = valueObj->length + 1; /* include end of string char */
+ if (valueLength > linkPtr->bytes) {
+ return (char *)"wrong size of char* value";
+ }
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.p, value, valueLength);
+ memcpy(linkPtr->addr, value, valueLength);
+ } else {
+ LinkedVar(char) = linkPtr->lastValue.i = '\0';
+ }
+ break;
+ case TCL_LINK_BINARY:
+ value = (char *) Tcl_GetByteArrayFromObj(valueObj, &i);
+ if ((size_t)i != linkPtr->bytes) {
+ return (char *)"wrong size of binary value";
+ }
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.p, value, (size_t) i);
+ memcpy(linkPtr->addr, value, (size_t) i);
+ } else {
+ linkPtr->lastValue.i = (unsigned char) *value;
+ LinkedVar(unsigned char) = (unsigned char) linkPtr->lastValue.i;
+ }
+ break;
+ case TCL_LINK_X(char): {
+ unsigned char uc;
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned char *puc = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(unsigned char)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ value = TclGetString(objv[i]);
+ valueLength = objv[i]->length;
+ if (valueLength != 4 || value[0]!='0' || value[1]!='x'
+ || (HexTo8bit(value+2, &puc[i])) < 0) {
+ return (char *)"variable array must have '0x' and 2 hex chars";
+ }
+ }
+ memcpy(linkPtr->addr, puc, linkPtr->bytes);
+ break;
+ }
+ value = TclGetString(valueObj);
+ valueLength = valueObj->length;
+ if (valueLength != 4 || value[0]!='0' || value[1]!='x'
+ || HexTo8bit(value+2, &uc) < 0) {
+ return (char *)"variable must have '0x' and 2 hex chars";
+ }
+ linkPtr->lastValue.i = uc;
+ LinkedVar(unsigned char) = (unsigned char)linkPtr->lastValue.i;
+ break;
+ }
+ case TCL_LINK_X(short): {
+ unsigned short us;
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned short *pus = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(unsigned short)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ value = TclGetString(objv[i]);
+ valueLength = objv[i]->length;
+ if (valueLength != 6 || value[0]!='0' || value[1]!='x'
+ || (HexTo16bit(value+2, &pus[i])) < 0) {
+ return (char *)"variable array must have '0x' and 4 hex chars";
+ }
+ }
+ memcpy(linkPtr->addr, pus, linkPtr->bytes);
+ break;
+ }
+ value = TclGetString(valueObj);
+ valueLength = valueObj->length;
+ if (valueLength != 6 || value[0]!='0' || value[1]!='x'
+ || HexTo16bit(value+2, &us) < 0) {
+ return (char *)"variable must have '0x' and 4 hex chars";
+ }
+ linkPtr->lastValue.ui = us;
+ LinkedVar(unsigned short) = (unsigned short)linkPtr->lastValue.ui;
+ break;
+ }
+ case TCL_LINK_X(int):
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned int *pui = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(unsigned int)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ value = TclGetString(objv[i]);
+ valueLength = objv[i]->length;
+ if (valueLength != 10 || value[0]!='0' || value[1]!='x'
+ || (HexTo32bit(value+2, &pui[i])) < 0) {
+ return (char *)"variable array must have '0x' and 8 hex chars";
+ }
+ }
+ memcpy(linkPtr->addr, pui, linkPtr->bytes);
+ break;
+ }
+ value = TclGetString(valueObj);
+ valueLength = valueObj->length;
+ if (valueLength != 10 || value[0]!='0' || value[1]!='x'
+ || HexTo32bit(value+2, &linkPtr->lastValue.ui) < 0) {
+ return (char *)"variable must have '0x' and 8 hex chars";
+ }
+ LinkedVar(unsigned int) = linkPtr->lastValue.ui;
+ break;
+ case TCL_LINK_X(Tcl_WideInt):
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ Tcl_WideUInt *puw = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(Tcl_WideUInt)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ value = TclGetString(objv[i]);
+ valueLength = objv[i]->length;
+ if (valueLength != 18 || value[0]!='0' || value[1]!='x'
+ || (HexTo64bit(value+2, &puw[i])) < 0) {
+ return (char *)"variable array must have '0x' and 16 hex chars";
+ }
+ }
+ memcpy(linkPtr->addr, puw, linkPtr->bytes);
+ break;
+ }
+ value = TclGetString(valueObj);
+ valueLength = valueObj->length;
+ if (valueLength != 18 || value[0]!='0' || value[1]!='x'
+ || HexTo64bit(value+2, &linkPtr->lastValue.uw) < 0) {
+ return (char *)"variable must have '0x' and 16 hex chars";
+ }
+ LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
+ break;
+ case TCL_LINK_BITARRAY8:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned char *puc = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(unsigned char)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ value = TclGetString(objv[i]);
+ valueLength = objv[i]->length;
+ if (valueLength != 8) {
+ return (char *)"variable array must be 8 chars long";
+ }
+ for (j = 0; j < 8; j++) {
+ if (value[j] == '0' || value[j] == 'f' || value[j] == 'F') {
+ puc[i] &= ~(1 << (7 - j));
+ } else {
+ puc[i] |= (1 << (7 - j));
+ }
+ }
+ }
+ memcpy(linkPtr->addr, puc, linkPtr->bytes);
+ break;
+ }
+ value = Tcl_GetString(valueObj);
+ valueLength = valueObj->length;
+ if (valueLength != 8) {
+ return (char *)"variable array must be 8 chars long";
+ }
+ for (j = 0; j < 8; j++) {
+ if (value[j] == '0' || value[j] == 'f' || value[j] == 'F') {
+ linkPtr->lastValue.i &= ~(1 << (7 - j));
+ } else {
+ linkPtr->lastValue.i |= (1 << (7 - j));
+ }
+ }
+ LinkedVar(unsigned char) = (unsigned char)linkPtr->lastValue.i;
+ break;
+ case TCL_LINK_BITARRAY16:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned short *pus = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(unsigned short)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ value = TclGetString(objv[i]);
+ valueLength = objv[i]->length;
+ if (valueLength != 16) {
+ return (char *)"variable array must be 16 chars long";
+ }
+ for (j = 0; j < 16; j++) {
+ if (value[j] == '0' || value[j] == 'f' || value[j] == 'F') {
+ pus[i] &= ~(1 << (15 - j));
+ } else {
+ pus[i] |= (1 << (15 - j));
+ }
+ }
+ }
+ memcpy(linkPtr->addr, pus, linkPtr->bytes);
+ break;
+ }
+ value = Tcl_GetString(valueObj);
+ valueLength = valueObj->length;
+ if (valueLength != 16) {
+ return (char *)"variable array must be 16 chars long";
+ }
+ for (j = 0; j < 16; j++) {
+ if (value[j] == '0' || value[j] == 'f' || value[j] == 'F') {
+ linkPtr->lastValue.ui &= ~(1 << (15 - j));
+ } else {
+ linkPtr->lastValue.ui |= (1 << (15 - j));
+ }
+ }
+ LinkedVar(unsigned short) = (unsigned short)linkPtr->lastValue.ui;
+ break;
+ case TCL_LINK_BITARRAY32:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned int *pui = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(unsigned int)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ value = Tcl_GetString(objv[i]);
+ valueLength = objv[i]->length;
+ if (valueLength != 32) {
+ return (char *)"variable array must be 32 chars long";
+ }
+ for (j = 0; j < 32; j++) {
+ if (value[j] == '0' || value[j] == 'f' || value[j] == 'F') {
+ pui[i] &= ~(1 << (31 - j));
+ } else {
+ pui[i] |= (1 << (31 - j));
+ }
+ }
+ }
+ memcpy(linkPtr->addr, pui, linkPtr->bytes);
+ break;
+ }
+ value = Tcl_GetString(valueObj);
+ valueLength = valueObj->length;
+ if (valueLength != 32) {
+ return (char *)"variable array must be 32 chars long";
+ }
+ for (j = 0; j < 32; j++) {
+ if (value[j] == '0' || value[j] == 'f' || value[j] == 'F') {
+ linkPtr->lastValue.ui &= ~(1 << (31 - j));
+ } else {
+ linkPtr->lastValue.ui |= (1 << (31 - j));
+ }
+ }
+ LinkedVar(unsigned int) = linkPtr->lastValue.ui;
+ break;
+ case TCL_LINK_BITARRAY64:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ Tcl_WideUInt *puw = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(unsigned int)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ value = Tcl_GetString(objv[i]);
+ valueLength = objv[i]->length;
+ if (valueLength != 64) {
+ return (char *)"variable array must be 64 chars long";
+ }
+ for (j = 0; j < 64; j++) {
+ if (value[j] == '0' || value[j] == 'f' || value[j] == 'F') {
+ puw[i] &= ~(1 << (63 - j));
+ } else {
+ puw[i] |= (1 << (63 - j));
+ }
+ }
+ }
+ memcpy(linkPtr->addr, puw, linkPtr->bytes);
+ break;
+ }
+ value = Tcl_GetString(valueObj);
+ valueLength = valueObj->length;
+ if (valueLength != 64) {
+ return (char *)"variable array must be 64 chars long";
+ }
+ for (j = 0; j < 64; j++) {
+ if (value[j] == '0' || value[j] == 'f' || value[j] == 'F') {
+ linkPtr->lastValue.uw &= ~(1 << (63 - j));
+ } else {
+ linkPtr->lastValue.uw |= (1 << (63 - j));
+ }
+ }
+ LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
+ break;
+ case TCL_LINK_B(char):
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned char *puc = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(unsigned char)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetBooleanFromObj(NULL, objv[i], &valueInt) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have boolean values";
+ }
+ puc[i] = (unsigned char) valueInt;
+ }
+ memcpy(linkPtr->addr, puc, linkPtr->bytes);
+ break;
+ }
+ if (Tcl_GetBooleanFromObj(NULL, valueObj, &valueInt) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned short value";
+ return (char *)"variable must have boolean value";
}
- LinkedVar(unsigned short) = linkPtr->lastValue.us = (unsigned short)valueInt;
+ linkPtr->lastValue.i = valueInt;
+ LinkedVar(unsigned char) = (unsigned char)linkPtr->lastValue.i;
break;
-
- case TCL_LINK_UINT:
- if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
- && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
- || valueWide < 0 || valueWide > UINT_MAX) {
+ case TCL_LINK_B(short):
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned short *pus = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(unsigned short)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetBooleanFromObj(NULL, objv[i], &valueInt) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have boolean values";
+ }
+ pus[i] = (unsigned short) valueInt;
+ }
+ memcpy(linkPtr->addr, pus, linkPtr->bytes);
+ break;
+ }
+ if (Tcl_GetBooleanFromObj(NULL, valueObj, &valueInt) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned int value";
+ return (char *)"variable must have boolean value";
}
- LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide;
+ linkPtr->lastValue.ui = valueInt;
+ LinkedVar(unsigned short) = (unsigned short) linkPtr->lastValue.ui;
break;
-
-#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
- case TCL_LINK_LONG:
- if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
- && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
- || valueWide < LONG_MIN || valueWide > LONG_MAX) {
+ case TCL_LINK_B(int):
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned int *pui = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(unsigned int)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetBooleanFromObj(NULL, objv[i], &valueInt) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have boolean values";
+ }
+ pui[i] = (unsigned int) valueInt;
+ }
+ memcpy(linkPtr->addr, pui, linkPtr->bytes);
+ break;
+ }
+ if (Tcl_GetBooleanFromObj(NULL, valueObj, &valueInt) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return (char *) "variable must have long value";
+ return (char *)"variable must have boolean value";
}
- LinkedVar(long) = linkPtr->lastValue.l = (long)valueWide;
+ linkPtr->lastValue.ui = (unsigned int) valueInt;
+ LinkedVar(unsigned int) = linkPtr->lastValue.ui;
break;
-
- case TCL_LINK_ULONG:
- if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
- && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
- || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
+ case TCL_LINK_B(Tcl_WideInt):
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ Tcl_WideUInt *puw = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(Tcl_WideUInt)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetBooleanFromObj(NULL, objv[i], &valueInt) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have boolean values";
+ }
+ puw[i] = (Tcl_WideUInt) valueInt;
+ }
+ memcpy(linkPtr->addr, puw, linkPtr->bytes);
+ break;
+ }
+ if (Tcl_GetBooleanFromObj(NULL, valueObj, &valueInt) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned long value";
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable must have boolean value";
}
- LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide;
+ linkPtr->lastValue.uw = (Tcl_WideUInt) valueInt;
+ LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
break;
-#endif
-
- case TCL_LINK_WIDE_UINT:
- /*
- * FIXME: represent as a bignum.
- */
- if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
- && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) {
+ case TCL_LINK_BIT8:
+ if (Tcl_GetBooleanFromObj(NULL, valueObj, &changed)
+ != TCL_OK) {
+ return (char *)"variable must have boolean value";
+ }
+ if (changed) {
+ linkPtr->lastValue.i |= (1 << linkPtr->bytes);
+ } else {
+ linkPtr->lastValue.i &= ~(1 << linkPtr->bytes);
+ }
+ LinkedVar(unsigned char) = (unsigned char)linkPtr->lastValue.i;
+ break;
+ case TCL_LINK_BIT16:
+ if (Tcl_GetBooleanFromObj(NULL, valueObj, &changed)
+ != TCL_OK) {
+ return (char *)"variable must have boolean value";
+ }
+ if (changed) {
+ linkPtr->lastValue.ui |= (1 << linkPtr->bytes);
+ } else {
+ linkPtr->lastValue.ui &= ~(1 << linkPtr->bytes);
+ }
+ LinkedVar(unsigned short) = (unsigned short)linkPtr->lastValue.ui;
+ break;
+ case TCL_LINK_BIT32:
+ if (Tcl_GetBooleanFromObj(NULL, valueObj, &changed)
+ != TCL_OK) {
+ return (char *)"variable must have boolean value";
+ }
+ if (changed) {
+ linkPtr->lastValue.ui |= (1 << linkPtr->bytes);
+ } else {
+ linkPtr->lastValue.ui &= ~(1 << linkPtr->bytes);
+ }
+ LinkedVar(unsigned int) = linkPtr->lastValue.ui;
+ break;
+ case TCL_LINK_BIT64:
+ if (Tcl_GetBooleanFromObj(NULL, valueObj, &changed)
+ != TCL_OK) {
+ return (char *)"variable must have boolean value";
+ }
+ if (changed) {
+ linkPtr->lastValue.uw |= (1 << linkPtr->bytes);
+ } else {
+ linkPtr->lastValue.uw &= ~(1 << linkPtr->bytes);
+ }
+ LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
+ break;
+ case TCL_LINK_S5FLOAT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned int *pui = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(unsigned int)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetDoubleFromObj(interp, objv[i], &valueDouble) != TCL_OK
+ || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have float values";
+ }
+ pui[i] = FloatToS5((float) valueDouble);
+ }
+ memcpy(linkPtr->addr, pui, linkPtr->bytes);
+ break;
+ }
+ if (Tcl_GetDoubleFromObj(interp, valueObj, &valueDouble) != TCL_OK
+ || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned wide int value";
+ return (char *)"variable must have float value";
}
- LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
+ linkPtr->lastValue.ui = FloatToS5((float) valueDouble);
+ LinkedVar(unsigned int) = linkPtr->lastValue.ui;
break;
-
- case TCL_LINK_FLOAT:
- if ((Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK
- && GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK)
+ case TCL_LINK_S5TIME:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ unsigned short *pus = linkPtr->lastValue.p;
+ if (Tcl_ListObjGetElements(interp, valueObj, &objc, &objv) == TCL_ERROR
+ || (size_t)objc != linkPtr->bytes / sizeof(unsigned short)) {
+ return (char *)"wrong dimension";
+ }
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetDoubleFromObj(interp, objv[i], &valueDouble) != TCL_OK
+ || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *)"variable array must have float values";
+ }
+ pus[i] = FloatToS5time(pus[i], (float) valueDouble);
+ }
+ memcpy(linkPtr->addr, pus, linkPtr->bytes);
+ break;
+ }
+ if (Tcl_GetDoubleFromObj(interp, valueObj, &valueDouble) != TCL_OK
|| valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return (char *) "variable must have float value";
+ return (char *)"variable must have float value";
+ }
+ linkPtr->lastValue.ui =
+ FloatToS5time((unsigned short)linkPtr->lastValue.ui, (float) valueDouble);
+ LinkedVar(unsigned short) = (unsigned short) linkPtr->lastValue.ui;
+ break;
+ default:
+ return (char *)"internal error: bad linked variable type";
+ }
+ return NULL;
+}
+
+/* Internal ieee type. */
+typedef union
+{
+ unsigned int bits;
+ float value;
+} _Ieee_t;
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * S5ToFloat --
+ * Convert given Siemens S5 value in IEEE float format.
+ *
+ * Result:
+ * IEEE format float value.
+ *
+ * Side effects:
+ * None
+ *----------------------------------------------------------------------
+ */
+
+static float
+S5ToFloat(
+ unsigned int value) /* Float value in Siemens S5 format to convert. */
+{
+ unsigned int S5Bits;
+ _Ieee_t ieee;
+ unsigned int ieee_mantisse, ieee_exponent, ieee_sign;
+ unsigned int S5mantisse, S5exponent, S5exposign;
+
+ S5Bits = ((unsigned int) (((*(unsigned char *) (&value) * 256 +
+ *((unsigned char *) (&value) + 1)) * 256 +
+ *((unsigned char *) (&value) + 2)) * 256 +
+ *((unsigned char *) (&value) + 3)));
+ if (S5Bits == 0x80000000u) {
+ ieee.bits = 0x0u;
+ } else {
+ if (S5Bits != 0x00000000u) {/*special handling, otherwise we get "0.5"*/
+ S5exponent = (S5Bits & 0x7f000000u) >> 24;
+ S5exposign = S5Bits & 0x80000000u;
+ S5mantisse = S5Bits & 0x007fffffu;
+ ieee_sign = (S5Bits & 0x00800000u) << 8;
+ if (!S5mantisse && ieee_sign) {
+ S5mantisse = 0x00000001u;
+ }
+ if (S5exposign) {
+ S5exponent = -((~S5exponent + 1) & 0x0000007fu);
+ }
+ ieee_exponent = S5exponent + 126;
+ if (ieee_sign) {
+ S5mantisse = (~S5mantisse + 1) & 0x007fffffu;
+ }
+ ieee_mantisse = (S5mantisse & 0xffbfffff) << 1;
+ ieee_exponent = (ieee_exponent & 0xff) << 23;
+ ieee.bits = ieee_sign | ieee_exponent | ieee_mantisse;
+ } else { /* when we get only zeros */
+ ieee.value = 0.0;
}
- LinkedVar(float) = linkPtr->lastValue.f = (float)valueDouble;
+ }
+/*TODO if (isnanf(ieee.value)) {
+ ieee.value = 0.0;
+ }
+*/
+ return ieee.value;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FloatToS5 --
+ * Convert given Siemens S5 value in IEEE float value in Siemens S5 float.
+ *
+ * Result:
+ * Siemens S5 float value.
+ *
+ * Side effects:
+ * None
+ *----------------------------------------------------------------------
+ */
+
+static unsigned int
+FloatToS5(
+ float value) /* Float value to convert. */
+{
+ _Ieee_t ieee;
+ unsigned int ieee_mantisse, ieee_exponent;
+ unsigned int S5Bits, S5sign, S5mantisse, S5exponent, S5exposign;
+ unsigned int RetVal;
+
+ ieee.value = value;
+
+ if (!ieee.bits) {
+ S5Bits = 0x80000000u;
+ } else {
+ ieee_mantisse = ieee.bits & 0x007fffffu;
+ ieee_exponent = (ieee.bits >> 23) & 0x000000ffu;
+ S5sign = (ieee.bits >> 8) & 0x00800000u;
+
+ if (!ieee_mantisse && S5sign) {
+ S5mantisse = 0x0u;
+ S5exponent = ieee_exponent + 1;
+ } else {
+ S5mantisse = (ieee_mantisse >> 1) | 0x00400000u;
+ S5exponent = ieee_exponent + 2;
+ if (S5sign) {
+ S5mantisse = (~S5mantisse + 1) & 0x007fffffu;
+ }
+ }
+
+ if (S5exponent & 0x00000080u) {
+ S5exposign = 0x0u;
+ } else {
+ S5exposign = 0x80000000u;
+ }
+
+ S5exponent = (S5exponent << 24) & 0x7f000000u;
+
+ S5Bits = S5exposign | S5exponent | S5sign | S5mantisse;
+ }
+
+ *(char *) (&RetVal) = (char) ((unsigned int) (S5Bits) / 0x1000000 & 0xff);
+ *((char *) (&RetVal)+1) = (char) ((unsigned int) (S5Bits) / 0x10000 & 0xff);
+ *((char *) (&RetVal)+2) = (char) ((unsigned int) (S5Bits) / 0x100 & 0xff);
+ *((char *) (&RetVal)+3) = (char) ((S5Bits) & 0xff);
+
+ return RetVal;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * S5timeToFloat --
+ * Convert Siemens S5 time value in IEEE float value.
+ *
+ * Result:
+ * Float time value in seconds.
+ *
+ * Side effects:
+ * None.
+ *----------------------------------------------------------------------
+ */
+
+static float
+S5timeToFloat(
+ unsigned short value) /*S5 format time value to convert. */
+{
+ float RetVal;
+
+ switch ((value & 0x3000) >> 12) {
+ case 0:
+ RetVal = 0.01 * (float) (value & 0x03ff);
+ break;
+ case 1:
+ RetVal = 0.1 * (float) (value & 0x03ff);
break;
+ case 2:
+ RetVal = (float) (value & 0x03ff);
+ break;
+ default: /*=3*/
+ RetVal = 10.0 * (float) (value & 0x03ff);
+ break;
+ }
+ return RetVal;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FloatToS5time --
+ * Convert IEEE float value in Siemens S5 time value.
+ *
+ * Result:
+ * S5 format time value.
+ *
+ * Side effects:
+ * None.
+ *----------------------------------------------------------------------
+ */
- case TCL_LINK_STRING:
- value = TclGetString(valueObj);
- valueLength = valueObj->length + 1;
- pp = (char **) linkPtr->addr;
+static unsigned short
+FloatToS5time(
+ unsigned short basis, /* S5 format time value used to detect time range. */
+ float value) /* Float time value in seconds to convert. */
+{
+ unsigned short RetVal = (basis & 0xf000);
+ unsigned short shortvalue;
- *pp = ckrealloc(*pp, valueLength);
- memcpy(*pp, value, valueLength);
+ switch ((RetVal & 0x3000) >> 12) {
+ case 0:
+ if (value < 0.01) return RetVal;
+ shortvalue = (unsigned short) (value * 100.);
+ break;
+ case 1:
+ if (value < 0.1) return RetVal;
+ shortvalue = (unsigned short) (value * 10.);
+ break;
+ case 2:
+ if (value < 1.) return RetVal;
+ shortvalue = (unsigned short) value;
+ break;
+ default: /*=3*/
+ if (value < 10.) return RetVal;
+ shortvalue = (unsigned short) (value / 10.);
break;
+ }
+ RetVal |= (shortvalue & 0x03ff);
+ return (RetVal);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * HexToInt --
+ * Get integer value of given hex string value.
+ *
+ * Result:
+ * Integer value of given hex character. -1 in case of error.
+ *
+ * Side effects:
+ * None.
+ *----------------------------------------------------------------------
+ */
- default:
- return (char *) "internal error: bad linked variable type";
+static int
+Hex2Int(
+ const char ch) /* hex string value to convert. */
+{
+ switch (ch) {
+ case '0': return 0;
+ case '1': return 1;
+ case '2': return 2;
+ case '3': return 3;
+ case '4': return 4;
+ case '5': return 5;
+ case '6': return 6;
+ case '7': return 7;
+ case '8': return 8;
+ case '9': return 9;
+ case 'A':
+ case 'a': return 10;
+ case 'B':
+ case 'b': return 11;
+ case 'C':
+ case 'c': return 12;
+ case 'D':
+ case 'd': return 13;
+ case 'E':
+ case 'e': return 14;
+ case 'F':
+ case 'f': return 15;
+ default: return -1;
}
- return NULL;
}
/*
*----------------------------------------------------------------------
*
- * ObjValue --
+ * HexTo8bit --
+ * Convert 2 hex chars in unsigned char integer value.
*
- * Converts the value of a C variable to a Tcl_Obj* for use in a Tcl
- * variable to which it is linked.
+ * Result:
+ * Return 0 on success and negative position in case of error.
*
- * Results:
- * The return value is a pointer to a Tcl_Obj that represents the value
- * of the C variable given by linkPtr.
+ * Side effects:
+ * None.
+ *----------------------------------------------------------------------
+ */
+
+static int
+HexTo8bit(
+ const char *ch, /* 2 hex chars. */
+ unsigned char *ret) /* Pointer with converted value. */
+{
+ int Tmp0, Tmp1;
+
+ if ((Tmp0 = Hex2Int(ch[0])) < 0) return -1;
+ if ((Tmp1 = Hex2Int(ch[1])) < 0) return -2;
+ *ret = (unsigned char) (Tmp1 + (Tmp0 << 4));
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * HexTo16bit --
+ * Convert 4 hex chars in unsigned short integer value.
+ *
+ * Result:
+ * Return 0 on success and negative position in case of error.
*
* Side effects:
- * None.
+ * None.
+ *----------------------------------------------------------------------
+ */
+
+static int
+HexTo16bit(
+ const char *ch, /* 4 hex chars. */
+ unsigned short *ret) /* Pointer with converted value. */
+{
+ int i;
+ int Tmp;
+ unsigned short Ret = 0;
+
+ for (i = 0; i < 4; i++) {
+ if ((Tmp = Hex2Int(ch[i])) < 0) return (-1 - i);
+ Ret += (Tmp << (12 - 4 * i));
+ }
+ *ret = Ret;
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * HexTo32bit --
+ *
+ * Result:
+ * Return 0 on success and negative position in case of error.
*
+ * Side effects:
+ * None.
*----------------------------------------------------------------------
*/
-static Tcl_Obj *
-ObjValue(
- Link *linkPtr) /* Structure describing linked variable. */
+static int
+HexTo32bit(
+ const char *ch, /* 8 hex chars. */
+ unsigned int *ret) /* Pointer with converted value. */
{
- char *p;
- Tcl_Obj *resultObj;
+ int i;
+ int Tmp;
+ unsigned int Ret = 0;
- switch (linkPtr->type) {
- case TCL_LINK_INT:
- linkPtr->lastValue.i = LinkedVar(int);
- return Tcl_NewIntObj(linkPtr->lastValue.i);
- case TCL_LINK_WIDE_INT:
- linkPtr->lastValue.w = LinkedVar(Tcl_WideInt);
- return Tcl_NewWideIntObj(linkPtr->lastValue.w);
- case TCL_LINK_DOUBLE:
- linkPtr->lastValue.d = LinkedVar(double);
- return Tcl_NewDoubleObj(linkPtr->lastValue.d);
- case TCL_LINK_BOOLEAN:
- linkPtr->lastValue.i = LinkedVar(int);
- return Tcl_NewBooleanObj(linkPtr->lastValue.i);
- case TCL_LINK_CHAR:
- linkPtr->lastValue.c = LinkedVar(char);
- return Tcl_NewIntObj(linkPtr->lastValue.c);
- case TCL_LINK_UCHAR:
- linkPtr->lastValue.uc = LinkedVar(unsigned char);
- return Tcl_NewIntObj(linkPtr->lastValue.uc);
- case TCL_LINK_SHORT:
- linkPtr->lastValue.s = LinkedVar(short);
- return Tcl_NewIntObj(linkPtr->lastValue.s);
- case TCL_LINK_USHORT:
- linkPtr->lastValue.us = LinkedVar(unsigned short);
- return Tcl_NewIntObj(linkPtr->lastValue.us);
- case TCL_LINK_UINT:
- linkPtr->lastValue.ui = LinkedVar(unsigned int);
- return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui);
-#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
- case TCL_LINK_LONG:
- linkPtr->lastValue.l = LinkedVar(long);
- return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l);
- case TCL_LINK_ULONG:
- linkPtr->lastValue.ul = LinkedVar(unsigned long);
- return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul);
-#endif
- case TCL_LINK_FLOAT:
- linkPtr->lastValue.f = LinkedVar(float);
- return Tcl_NewDoubleObj(linkPtr->lastValue.f);
- case TCL_LINK_WIDE_UINT:
- linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
- /*
- * FIXME: represent as a bignum.
- */
- return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw);
- case TCL_LINK_STRING:
- p = LinkedVar(char *);
- if (p == NULL) {
- TclNewLiteralStringObj(resultObj, "NULL");
- return resultObj;
- }
- return Tcl_NewStringObj(p, -1);
+ for (i = 0; i < 8; i++) {
+ if ((Tmp = Hex2Int(ch[i])) < 0) return (-1 - i);
+ Ret += (Tmp << (28 - 4 * i));
+ }
+ *ret = Ret;
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * HexTo64bit --
+ *
+ * Result:
+ * Return 0 on success and negative position in case of error.
+ *
+ * Side effects:
+ * None.
+ *----------------------------------------------------------------------
+ */
- /*
- * This code only gets executed if the link type is unknown (shouldn't
- * ever happen).
- */
+static int
+HexTo64bit(
+ const char *ch, /* 16 hex chars. */
+ Tcl_WideUInt *ret) /* Pointer with converted value. */
+{
+ int i;
+ int Tmp;
+ Tcl_WideUInt Ret = 0;
- default:
- TclNewLiteralStringObj(resultObj, "??");
- return resultObj;
+ for (i = 0; i < 16; i++) {
+ if ((Tmp = Hex2Int(ch[i])) < 0) return (-1 - i);
+ Ret += (Tmp << (60 - 4 * i));
}
+ *ret = Ret;
+ return 0;
}
+
static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 59325b7..8ee9a31 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -1519,6 +1519,8 @@ const TclStubs tclStubs = {
Tcl_FSUnloadFile, /* 629 */
Tcl_ZlibStreamSetCompressionDictionary, /* 630 */
Tcl_OpenTcpServerEx, /* 631 */
+ 0, /* 632 */
+ Tcl_LinkArray, /* 633 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 547dc9a..d7a3117 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -299,6 +299,9 @@ static int TestinterpdeleteCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestlinkCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
+static int TestlinkarrayCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static int TestlocaleCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -654,6 +657,7 @@ Tcltest_Init(
Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
@@ -3278,6 +3282,154 @@ TestlinkCmd(
/*
*----------------------------------------------------------------------
*
+ * TestlinkarrayCmd --
+ * This procedure implements the "testlinkarray" command. It is used
+ * to test Tcl_LinkArray and related library procedures.
+ * Additionally it can be used as an example on how to implement
+ * a script link command with access to internal TCL_Link* functions.
+ * It is not a global tcl command because of security reasons.
+ * Use it in your extension on your own risk.
+ *
+ * Usage:
+ * testlinkobj update <name> ..
+ * Update given Tcl-variables with content from C-address
+ * testlinkobj remove <name> ..
+ * Remove link to C-variable. Free C-variable if it was created in
+ * "create" command.
+ * testlinkobj create ?-readonly? <type> <size> <name> ?address?
+ * Create new linked variable. If "-readonly" is given variable can
+ * only be read from tcl side. If address is given use it as address of
+ * C-variable. Otherwise create a new C-variable of needed size.
+ * testlinkobj types
+ * Return list of available types.
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Creates and deletes various variable links, plus returns
+ * values of the linked variables.
+ *----------------------------------------------------------------------
+ */
+static int
+TestlinkarrayCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj * const objv[]) /* Argument strings. */
+{
+ static const char *LinkOption[] = {
+ "update", "remove", "create", "types", NULL
+ };
+ enum LinkOption
+ { LINK_UPDATE, LINK_REMOVE, LINK_CREATE, LINK_TYPES };
+ static const char *LinkType[] = {
+ "int", "double", "bool", "string",
+ "wideint", "char", "uchar",
+ "short", "ushort", "uint",
+ "long", "ulong", "float",
+ "uint", "chars",
+ "complex32", "complex64", "binary"
+ "hex8", "hex16", "hex32", "hex64",
+ "bitarray8", "bitarray16", "bitarray32", "bitarray64",
+ "bool8", "bool16", "bool32", "bool64",
+ "bit8", "bit16", "bit32", "bit64",
+ "s5float", "s5time", NULL
+ };
+ static const int LinkTypes[] = {
+ TCL_LINK_INT, TCL_LINK_DOUBLE, TCL_LINK_BOOLEAN, TCL_LINK_STRING,
+ TCL_LINK_WIDE_INT, TCL_LINK_CHAR, TCL_LINK_UCHAR,
+ TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_UINT,
+ TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_FLOAT,
+ TCL_LINK_WIDE_UINT, TCL_LINK_CHARS,
+ TCL_LINK_C(float), TCL_LINK_C(double), TCL_LINK_BINARY ,
+ TCL_LINK_X(char), TCL_LINK_X(short), TCL_LINK_X(int), TCL_LINK_X(Tcl_WideInt),
+ TCL_LINK_BITARRAY8, TCL_LINK_BITARRAY16,
+ TCL_LINK_BITARRAY32, TCL_LINK_BITARRAY64,
+ TCL_LINK_B(char), TCL_LINK_B(short), TCL_LINK_B(int), TCL_LINK_B(Tcl_WideInt),
+ TCL_LINK_BIT8, TCL_LINK_BIT16, TCL_LINK_BIT32, TCL_LINK_BIT64,
+ TCL_LINK_S5FLOAT, TCL_LINK_S5TIME
+ };
+ int optionIndex;
+ int typeIndex;
+ int readonly;
+ int i;
+ char *name;
+ Tcl_WideInt addr;
+ int size;
+ char *arg;
+ int length;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option args");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0,
+ &optionIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum LinkOption) optionIndex) {
+ case LINK_UPDATE:
+ for (i = 2; i < objc; i++) {
+ Tcl_UpdateLinkedVar(interp, Tcl_GetString(objv[i]));
+ }
+ return TCL_OK;
+ case LINK_REMOVE:
+ for (i = 2; i < objc; i++) {
+ Tcl_UnlinkVar(interp, Tcl_GetString(objv[i]));
+ }
+ return TCL_OK;
+ case LINK_TYPES:
+ Tcl_AppendResult(interp, "int double bool string wideint char uchar short ushort uint long ulong float uint chars complex32 complex64 binary hex8 hex16 hex32 hex64 bitarray8 bitarray16 bitarray32 bitarray64 bool8 bool16 bool32 bool64 bit8 bit16 bit32 bit64 s5float s5time", NULL);
+ return TCL_OK;
+ case LINK_CREATE:
+ if (objc < 4) {
+ goto wrongArgs;
+ }
+ readonly = 0;
+ i = 2;
+ /* test on switch -r... */
+ arg = Tcl_GetStringFromObj(objv[i], &length);
+ if (length < 2) {
+ goto wrongArgs;
+ }
+ if (arg[0] == '-') {
+ if (arg[1] != 'r') {
+ goto wrongArgs;
+ }
+ readonly = TCL_LINK_READ_ONLY;
+ i++;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0,
+ &typeIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) {
+ Tcl_AppendResult(interp, "wrong size value", NULL);
+ return TCL_ERROR;
+ }
+ name = Tcl_GetString(objv[i++]);
+ /* if no address is given request one in the underlying function */
+ if (i < objc) {
+ if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
+ Tcl_AppendResult(interp, "wrong address value", NULL);
+ return TCL_ERROR;
+ }
+ } else {
+ addr = 0;
+ }
+ return Tcl_LinkArray(interp, name, (char *) addr,
+ LinkTypes[typeIndex] | readonly, size);
+ }
+ return TCL_OK;
+
+wrongArgs:
+ Tcl_WrongNumArgs(interp, 2, objv, "?-readonly? type size name ?address?");
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestlocaleCmd --
*
* This procedure implements the "testlocale" command. It is used
generated by cgit v0.12 at 2024-09-16 04:59:17 (GMT)