Attachment "1992824.patch" to
ticket [1992824fff]
added by
dgp
2008-09-17 23:48:52.
Index: generic/tcl.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.decls,v
retrieving revision 1.143
diff -u -r1.143 tcl.decls
--- generic/tcl.decls 21 Aug 2008 21:35:37 -0000 1.143
+++ generic/tcl.decls 17 Sep 2008 16:45:58 -0000
@@ -2146,6 +2146,13 @@
Tcl_Obj *CONST objv[])
}
+# TIP#312 New Tcl_LinkArray() function
+declare 589 generic {
+ int Tcl_LinkArray(Tcl_Interp *interp, CONST char *varName, char *addr,
+ int type, int size)
+}
+
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are
Index: generic/tcl.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.h,v
retrieving revision 1.270
diff -u -r1.270 tcl.h
--- generic/tcl.h 3 Sep 2008 05:43:31 -0000 1.270
+++ generic/tcl.h 17 Sep 2008 16:45:58 -0000
@@ -1078,6 +1078,8 @@
#define TCL_LINK_ULONG 12
#define TCL_LINK_FLOAT 13
#define TCL_LINK_WIDE_UINT 14
+#define TCL_LINK_CHARS 15
+#define TCL_LINK_BINARY 16
#define TCL_LINK_READ_ONLY 0x80
/*
Index: generic/tclDecls.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclDecls.h,v
retrieving revision 1.145
diff -u -r1.145 tclDecls.h
--- generic/tclDecls.h 21 Aug 2008 21:35:38 -0000 1.145
+++ generic/tclDecls.h 17 Sep 2008 16:45:59 -0000
@@ -3566,6 +3566,13 @@
ClientData clientData, int objc,
Tcl_Obj *CONST objv[]);
#endif
+#ifndef Tcl_LinkArray_TCL_DECLARED
+#define Tcl_LinkArray_TCL_DECLARED
+/* 589 */
+EXTERN int Tcl_LinkArray (Tcl_Interp * interp,
+ CONST char * varName, char * addr, int type,
+ int size);
+#endif
typedef struct TclStubHooks {
CONST struct TclPlatStubs *tclPlatStubs;
@@ -4214,6 +4221,7 @@
int (*tcl_NRCmdSwap) (Tcl_Interp * interp, Tcl_Command cmd, int objc, Tcl_Obj *CONST objv[], int flags); /* 586 */
void (*tcl_NRAddCallback) (Tcl_Interp * interp, Tcl_NRPostProc * postProcPtr, ClientData data0, ClientData data1, ClientData data2, ClientData data3); /* 587 */
int (*tcl_NRCallObjProc) (Tcl_Interp * interp, Tcl_ObjCmdProc * objProc, ClientData clientData, int objc, Tcl_Obj *CONST objv[]); /* 588 */
+ int (*tcl_LinkArray) (Tcl_Interp * interp, CONST char * varName, char * addr, int type, int size); /* 589 */
} TclStubs;
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
@@ -6642,6 +6650,10 @@
#define Tcl_NRCallObjProc \
(tclStubsPtr->tcl_NRCallObjProc) /* 588 */
#endif
+#ifndef Tcl_LinkArray
+#define Tcl_LinkArray \
+ (tclStubsPtr->tcl_LinkArray) /* 589 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
Index: generic/tclLink.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclLink.c,v
retrieving revision 1.25
diff -u -r1.25 tclLink.c
--- generic/tclLink.c 27 Apr 2008 22:21:30 -0000 1.25
+++ generic/tclLink.c 17 Sep 2008 16:45:59 -0000
@@ -30,6 +30,9 @@
* actual variable may be aliased at that time
* via upvar. */
char *addr; /* Location of C variable. */
+ int 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;
@@ -44,6 +47,18 @@
Tcl_WideUInt uw;
float f;
double d;
+ char *pc;
+ unsigned char *puc;
+ int *pi;
+ unsigned int *pui;
+ short *ps;
+ unsigned short *pus;
+ long *pl;
+ unsigned long *pul;
+ Tcl_WideInt *pw;
+ Tcl_WideUInt *puw;
+ float *pf;
+ double *pd;
} lastValue; /* Last known value of C variable; used to
* avoid string conversions. */
int flags; /* Miscellaneous one-bit values; see below for
@@ -57,10 +72,14 @@
* 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 +88,7 @@
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);
/*
* Convenience macro for accessing the value of the C variable pointed to by a
@@ -125,18 +145,161 @@
} else {
linkPtr->flags = 0;
}
+ linkPtr->bytes = 0;
objPtr = ObjValue(linkPtr);
if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(linkPtr->varName);
- ckfree((char *) linkPtr);
+ LinkFree(linkPtr);
return TCL_ERROR;
}
code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr);
if (code != TCL_OK) {
Tcl_DecrRefCount(linkPtr->varName);
- ckfree((char *) linkPtr);
+ LinkFree(linkPtr);
+ }
+ 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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 and
+ * TCL_LINK_ALLOC OR'ed in. */
+ int size) /* Size of C variable array, >1 if array */
+{
+ Tcl_Obj *objPtr;
+ Link *linkPtr;
+ int code;
+
+ if (size < 1) {
+ Tcl_SetResult(interp, "wrong array size given", TCL_STATIC);
+ return TCL_ERROR;
+ }
+
+ linkPtr = (Link *) ckalloc(sizeof(Link));
+ linkPtr->type = type & ~TCL_LINK_READ_ONLY;
+ if (type & TCL_LINK_READ_ONLY) {
+ linkPtr->flags = LINK_READ_ONLY;
+ } else {
+ linkPtr->flags = 0;
+ }
+ switch (linkPtr->type) {
+ case TCL_LINK_INT:
+ case TCL_LINK_BOOLEAN:
+ linkPtr->bytes = size * sizeof(int);
+ break;
+ case TCL_LINK_DOUBLE:
+ linkPtr->bytes = size * sizeof(double);
+ break;
+ case TCL_LINK_WIDE_INT:
+ linkPtr->bytes = size * sizeof(Tcl_WideInt);
+ break;
+ case TCL_LINK_WIDE_UINT:
+ linkPtr->bytes = size * sizeof(Tcl_WideUInt);
+ break;
+ case TCL_LINK_CHAR:
+ linkPtr->bytes = size * sizeof(char);
+ break;
+ case TCL_LINK_UCHAR:
+ linkPtr->bytes = size * sizeof(unsigned char);
+ break;
+ case TCL_LINK_SHORT:
+ linkPtr->bytes = size * sizeof(short);
+ break;
+ case TCL_LINK_USHORT:
+ linkPtr->bytes = size * sizeof(unsigned short);
+ break;
+ case TCL_LINK_UINT:
+ linkPtr->bytes = size * sizeof(unsigned int);
+ break;
+ case TCL_LINK_LONG:
+ linkPtr->bytes = size * sizeof(long);
+ break;
+ case TCL_LINK_ULONG:
+ linkPtr->bytes = size * sizeof(unsigned long);
+ break;
+ case TCL_LINK_FLOAT:
+ linkPtr->bytes = size * sizeof(float);
+ 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->lastValue */
+ if (addr == NULL) {
+ linkPtr->lastValue.pc = ckalloc(linkPtr->bytes);
+ linkPtr->flags |= LINK_ALLOC_LAST;
+ addr = (char *)&linkPtr->lastValue.pc;
+ }
+ break;
+ case TCL_LINK_CHARS:
+ case TCL_LINK_BINARY:
+ linkPtr->bytes = size * sizeof(char);
+ break;
+ default:
+ LinkFree(linkPtr);
+ Tcl_SetResult(interp, "bad linked array variable type", TCL_STATIC);
+ return TCL_ERROR;
+ }
+ /* 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.pc = 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_DecrRefCount(linkPtr->varName);
+ LinkFree(linkPtr);
+ return TCL_ERROR;
+ }
+ 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);
+ LinkFree(linkPtr);
+ } else {
+ Tcl_SetObjResult(interp,Tcl_NewIntObj((int)linkPtr->addr));
}
return code;
}
@@ -174,7 +337,7 @@
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, linkPtr);
Tcl_DecrRefCount(linkPtr->varName);
- ckfree((char *) linkPtr);
+ LinkFree(linkPtr);
}
/*
@@ -259,6 +422,9 @@
int valueInt;
Tcl_WideInt valueWide;
double valueDouble;
+ int objc;
+ Tcl_Obj **objv;
+ int i;
/*
* If the variable is being unset, then just re-create it (with a trace)
@@ -268,7 +434,7 @@
if (flags & TCL_TRACE_UNSETS) {
if (Tcl_InterpDeleted(interp)) {
Tcl_DecrRefCount(linkPtr->varName);
- ckfree((char *) linkPtr);
+ LinkFree(linkPtr);
} else if (flags & TCL_TRACE_DESTROYED) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
@@ -295,6 +461,11 @@
*/
if (flags & TCL_TRACE_READS) {
+ /* variable arrays */
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ changed = memcmp(linkPtr->addr,linkPtr->lastValue.pc,linkPtr->bytes);
+ /* single variables */
+ } else {
switch (linkPtr->type) {
case TCL_LINK_INT:
case TCL_LINK_BOOLEAN:
@@ -334,10 +505,13 @@
changed = (LinkedVar(float) != linkPtr->lastValue.f);
break;
case TCL_LINK_STRING:
+ case TCL_LINK_CHARS:
+ case TCL_LINK_BINARY:
changed = 1;
break;
default:
- return "internal error: bad linked variable type";
+ changed = 0;
+ }
}
if (changed) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
@@ -349,7 +523,7 @@
/*
* 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.
@@ -371,6 +545,21 @@
switch (linkPtr->type) {
case TCL_LINK_INT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ if (Tcl_ListObjGetElements(interp,valueObj,&objc,&objv)==TCL_ERROR
+ || objc != linkPtr->bytes/sizeof(int)) {
+ return "wrong dimension";
+ }
+ for (i=0; i < objc; i++) {
+ if (Tcl_GetIntFromObj(NULL,objv[i],&linkPtr->lastValue.pi[i])!= TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable array must have integer value";
+ }
+ }
+ memcpy(linkPtr->addr,linkPtr->lastValue.pc,linkPtr->bytes);
+ break;
+ }
if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
@@ -381,16 +570,53 @@
break;
case TCL_LINK_WIDE_INT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ if (Tcl_ListObjGetElements(interp,valueObj,&objc,&objv)==TCL_ERROR
+ || objc != linkPtr->bytes/sizeof(Tcl_WideInt)) {
+ return "wrong dimension";
+ }
+ for (i=0; i < objc; i++) {
+ if (Tcl_GetWideIntFromObj(NULL,objv[i],&linkPtr->lastValue.pw[i])!= TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable array must have wide integer value";
+ }
+ }
+ memcpy(linkPtr->addr,linkPtr->lastValue.pc,linkPtr->bytes);
+ break;
+ }
if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return "variable must have integer value";
+ return "variable must have wide integer value";
}
LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
break;
case TCL_LINK_DOUBLE:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ if (Tcl_ListObjGetElements(interp,valueObj,&objc,&objv)==TCL_ERROR
+ || objc != linkPtr->bytes/sizeof(double)) {
+ return "wrong dimension";
+ }
+ for (i=0; i < objc; i++) {
+ if (Tcl_GetDoubleFromObj(NULL,objv[i],&linkPtr->lastValue.pd[i])!= TCL_OK) {
+#ifdef ACCEPT_NAN
+ if (valueObj->typePtr != &tclDoubleType) {
+#endif
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable array must have real value";
+#ifdef ACCEPT_NAN
+ }
+ linkPtr->lastValue.pdi[i] = valueObj->internalRep.doubleValue;
+#endif
+ }
+ }
+ memcpy(linkPtr->addr,linkPtr->lastValue.pc,linkPtr->bytes);
+ break;
+ }
if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d)
!= TCL_OK) {
#ifdef ACCEPT_NAN
@@ -408,6 +634,21 @@
break;
case TCL_LINK_BOOLEAN:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ if (Tcl_ListObjGetElements(interp,valueObj,&objc,&objv)==TCL_ERROR
+ || objc != linkPtr->bytes/sizeof(int)) {
+ return "wrong dimension";
+ }
+ for (i=0; i < objc; i++) {
+ if (Tcl_GetBooleanFromObj(NULL,objv[i],&linkPtr->lastValue.pi[i])!= TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable array must have boolean value";
+ }
+ }
+ memcpy(linkPtr->addr,linkPtr->lastValue.pc,linkPtr->bytes);
+ break;
+ }
if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
@@ -418,6 +659,23 @@
break;
case TCL_LINK_CHAR:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ if (Tcl_ListObjGetElements(interp,valueObj,&objc,&objv)==TCL_ERROR
+ || objc != linkPtr->bytes/sizeof(char)) {
+ return "wrong dimension";
+ }
+ for (i=0; i < objc; i++) {
+ if (Tcl_GetIntFromObj(NULL,objv[i],&valueInt)!= TCL_OK
+ || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable array must have char value";
+ }
+ linkPtr->lastValue.pc[i] = (char)valueInt;
+ }
+ memcpy(linkPtr->addr,linkPtr->lastValue.pc,linkPtr->bytes);
+ break;
+ }
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
|| valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
@@ -429,6 +687,23 @@
break;
case TCL_LINK_UCHAR:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ if (Tcl_ListObjGetElements(interp,valueObj,&objc,&objv)==TCL_ERROR
+ || objc != linkPtr->bytes/sizeof(unsigned char)) {
+ return "wrong dimension";
+ }
+ for (i=0; i < objc; i++) {
+ if (Tcl_GetIntFromObj(NULL,objv[i],&valueInt)!= TCL_OK
+ || valueInt < 0 || valueInt > UCHAR_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable array must have unsigned char value";
+ }
+ linkPtr->lastValue.puc[i] = (unsigned char)valueInt;
+ }
+ memcpy(linkPtr->addr,linkPtr->lastValue.pc,linkPtr->bytes);
+ break;
+ }
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
|| valueInt < 0 || valueInt > UCHAR_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
@@ -440,6 +715,23 @@
break;
case TCL_LINK_SHORT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ if (Tcl_ListObjGetElements(interp,valueObj,&objc,&objv)==TCL_ERROR
+ || objc != linkPtr->bytes/sizeof(short)) {
+ return "wrong dimension";
+ }
+ for (i=0; i < objc; i++) {
+ if (Tcl_GetIntFromObj(NULL,objv[i],&valueInt)!= TCL_OK
+ || valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable array must have short value";
+ }
+ linkPtr->lastValue.ps[i] = (short)valueInt;
+ }
+ memcpy(linkPtr->addr,linkPtr->lastValue.pc,linkPtr->bytes);
+ break;
+ }
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
|| valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
@@ -451,6 +743,23 @@
break;
case TCL_LINK_USHORT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ if (Tcl_ListObjGetElements(interp,valueObj,&objc,&objv)==TCL_ERROR
+ || objc != linkPtr->bytes/sizeof(unsigned short)) {
+ return "wrong dimension";
+ }
+ for (i=0; i < objc; i++) {
+ if (Tcl_GetIntFromObj(NULL,objv[i],&valueInt)!= TCL_OK
+ || valueInt < 0 || valueInt > USHRT_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable array must have unsigned short value";
+ }
+ linkPtr->lastValue.pus[i] = (unsigned short)valueInt;
+ }
+ memcpy(linkPtr->addr,linkPtr->lastValue.pc,linkPtr->bytes);
+ break;
+ }
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
|| valueInt < 0 || valueInt > USHRT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
@@ -462,6 +771,23 @@
break;
case TCL_LINK_UINT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ if (Tcl_ListObjGetElements(interp,valueObj,&objc,&objv)==TCL_ERROR
+ || objc != linkPtr->bytes/sizeof(unsigned int)) {
+ return "wrong dimension";
+ }
+ for (i=0; i < objc; i++) {
+ if (Tcl_GetWideIntFromObj(NULL,objv[i],&valueWide)!= TCL_OK
+ || valueWide < 0 || valueWide > UINT_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable array must have unsigned int value";
+ }
+ linkPtr->lastValue.pui[i] = (unsigned int)valueWide;
+ }
+ memcpy(linkPtr->addr,linkPtr->lastValue.pc,linkPtr->bytes);
+ break;
+ }
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
|| valueWide < 0 || valueWide > UINT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
@@ -473,6 +799,23 @@
break;
case TCL_LINK_LONG:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ if (Tcl_ListObjGetElements(interp,valueObj,&objc,&objv)==TCL_ERROR
+ || objc != linkPtr->bytes/sizeof(long)) {
+ return "wrong dimension";
+ }
+ for (i=0; i < objc; i++) {
+ if (Tcl_GetWideIntFromObj(NULL,objv[i],&valueWide)!= TCL_OK
+ || valueWide < LONG_MIN || valueWide > LONG_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable array must have long value";
+ }
+ linkPtr->lastValue.pl[i] = (long)valueWide;
+ }
+ memcpy(linkPtr->addr,linkPtr->lastValue.pc,linkPtr->bytes);
+ break;
+ }
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
|| valueWide < LONG_MIN || valueWide > LONG_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
@@ -484,6 +827,23 @@
break;
case TCL_LINK_ULONG:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ if (Tcl_ListObjGetElements(interp,valueObj,&objc,&objv)==TCL_ERROR
+ || objc != linkPtr->bytes/sizeof(unsigned long)) {
+ return "wrong dimension";
+ }
+ for (i=0; i < objc; i++) {
+ if (Tcl_GetWideIntFromObj(NULL,objv[i],&valueWide)!= TCL_OK
+ || valueWide < 0 || valueWide > ULONG_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable array must have unsigned long value";
+ }
+ linkPtr->lastValue.pul[i] = (unsigned long)valueWide;
+ }
+ memcpy(linkPtr->addr,linkPtr->lastValue.pc,linkPtr->bytes);
+ break;
+ }
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
|| valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
@@ -498,7 +858,25 @@
/*
* FIXME: represent as a bignum.
*/
- if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK) {
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ if (Tcl_ListObjGetElements(interp,valueObj,&objc,&objv)==TCL_ERROR
+ || objc != linkPtr->bytes/sizeof(Tcl_WideUInt)) {
+ return "wrong dimension";
+ }
+ for (i=0; i < objc; i++) {
+ if (Tcl_GetWideIntFromObj(NULL,objv[i],&valueWide)!= TCL_OK
+ || valueWide < 0) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable array must have unsigned wide int value";
+ }
+ linkPtr->lastValue.puw[i] = (Tcl_WideUInt)valueWide;
+ }
+ memcpy(linkPtr->addr,linkPtr->lastValue.pc,linkPtr->bytes);
+ break;
+ }
+ if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
+ || valueWide < 0) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have unsigned wide int value";
@@ -508,6 +886,23 @@
break;
case TCL_LINK_FLOAT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ if (Tcl_ListObjGetElements(interp,valueObj,&objc,&objv)==TCL_ERROR
+ || objc != linkPtr->bytes/sizeof(float)) {
+ return "wrong dimension";
+ }
+ for (i=0; i < objc; i++) {
+ if (Tcl_GetDoubleFromObj(interp,objv[i],&valueDouble)!= TCL_OK
+ || valueDouble < FLT_MIN || valueDouble > FLT_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable array must have float value";
+ }
+ linkPtr->lastValue.pf[i] = (float)valueDouble;
+ }
+ memcpy(linkPtr->addr,linkPtr->lastValue.pc,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),
@@ -522,11 +917,39 @@
value = Tcl_GetStringFromObj(valueObj, &valueLength);
valueLength++;
pp = (char **) linkPtr->addr;
-
*pp = ckrealloc(*pp, valueLength);
memcpy(*pp, value, (unsigned) valueLength);
break;
+ case TCL_LINK_CHARS:
+ value = (char *)Tcl_GetStringFromObj(valueObj, &valueLength);
+ valueLength++;/* include end of string char */
+ if (valueLength > linkPtr->bytes) {
+ return "wrong size of char* value";
+ }
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.pc, value, (unsigned) valueLength);
+ memcpy(linkPtr->addr, value, (unsigned) valueLength);
+ } else {
+ linkPtr->lastValue.c = '\0';
+ LinkedVar(char) = linkPtr->lastValue.c;
+ }
+ break;
+
+ case TCL_LINK_BINARY:
+ value = (char *)Tcl_GetByteArrayFromObj(valueObj, &valueLength);
+ if (valueLength != linkPtr->bytes) {
+ return "wrong size of binary value";
+ }
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.pc, value, (unsigned) valueLength);
+ memcpy(linkPtr->addr, value, (unsigned) valueLength);
+ } else {
+ linkPtr->lastValue.uc = (unsigned char) *value;
+ LinkedVar(unsigned char) = linkPtr->lastValue.uc;
+ }
+ break;
+
default:
return "internal error: bad linked variable type";
}
@@ -557,49 +980,169 @@
{
char *p;
Tcl_Obj *resultObj;
+ int objc;
+ static Tcl_Obj **objv = NULL;
+ int i;
switch (linkPtr->type) {
case TCL_LINK_INT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.pc, 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(linkPtr->lastValue.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) {
+ memcpy(linkPtr->lastValue.pc, 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(linkPtr->lastValue.pw[i]);
+ }
+ return Tcl_NewListObj(objc,objv);
+ }
linkPtr->lastValue.w = LinkedVar(Tcl_WideInt);
return Tcl_NewWideIntObj(linkPtr->lastValue.w);
case TCL_LINK_DOUBLE:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.pc, 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(linkPtr->lastValue.pd[i]);
+ }
+ return Tcl_NewListObj(objc,objv);
+ }
linkPtr->lastValue.d = LinkedVar(double);
return Tcl_NewDoubleObj(linkPtr->lastValue.d);
case TCL_LINK_BOOLEAN:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.pc, 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_NewBooleanObj(linkPtr->lastValue.pi[i] != 0);
+ }
+ return Tcl_NewListObj(objc,objv);
+ }
linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0);
case TCL_LINK_CHAR:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.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(linkPtr->lastValue.pc[i]);
+ }
+ return Tcl_NewListObj(objc,objv);
+ }
linkPtr->lastValue.c = LinkedVar(char);
return Tcl_NewIntObj(linkPtr->lastValue.c);
case TCL_LINK_UCHAR:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.pc, 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(linkPtr->lastValue.puc[i]);
+ }
+ return Tcl_NewListObj(objc,objv);
+ }
linkPtr->lastValue.uc = LinkedVar(unsigned char);
return Tcl_NewIntObj(linkPtr->lastValue.uc);
case TCL_LINK_SHORT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.pc, 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(linkPtr->lastValue.ps[i]);
+ }
+ return Tcl_NewListObj(objc,objv);
+ }
linkPtr->lastValue.s = LinkedVar(short);
return Tcl_NewIntObj(linkPtr->lastValue.s);
case TCL_LINK_USHORT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.pc, 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(linkPtr->lastValue.pus[i]);
+ }
+ return Tcl_NewListObj(objc,objv);
+ }
linkPtr->lastValue.us = LinkedVar(unsigned short);
return Tcl_NewIntObj(linkPtr->lastValue.us);
case TCL_LINK_UINT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.pc, 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(linkPtr->lastValue.pui[i]);
+ }
+ return Tcl_NewListObj(objc,objv);
+ }
linkPtr->lastValue.ui = LinkedVar(unsigned int);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui);
case TCL_LINK_LONG:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.pc, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes/sizeof(long);
+ objv = (Tcl_Obj **) ckrealloc((char *)objv, objc*sizeof(Tcl_Obj*));
+ for (i=0; i < objc; i++) {
+ objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pl[i]);
+ }
+ return Tcl_NewListObj(objc,objv);
+ }
linkPtr->lastValue.l = LinkedVar(long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l);
case TCL_LINK_ULONG:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.pc, linkPtr->addr, linkPtr->bytes);
+ objc = linkPtr->bytes/sizeof(unsigned long);
+ objv = (Tcl_Obj **) ckrealloc((char *)objv, objc*sizeof(Tcl_Obj*));
+ for (i=0; i < objc; i++) {
+ objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pul[i]);
+ }
+ return Tcl_NewListObj(objc,objv);
+ }
linkPtr->lastValue.ul = LinkedVar(unsigned long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul);
case TCL_LINK_FLOAT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.pc, 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(linkPtr->lastValue.pf[i]);
+ }
+ return Tcl_NewListObj(objc,objv);
+ }
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.
*/
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.pc, 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((Tcl_WideInt) linkPtr->lastValue.puw[i]);
+ }
+ return Tcl_NewListObj(objc,objv);
+ }
+ linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw);
case TCL_LINK_STRING:
p = LinkedVar(char *);
@@ -609,6 +1152,23 @@
}
return Tcl_NewStringObj(p, -1);
+ case TCL_LINK_CHARS:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.pc, linkPtr->addr, linkPtr->bytes);
+ linkPtr->lastValue.pc[linkPtr->bytes-1] = '\0';/* take care of proper string end */
+ return Tcl_NewStringObj(linkPtr->lastValue.pc,linkPtr->bytes);
+ }
+ linkPtr->lastValue.c = '\0';
+ return Tcl_NewStringObj(&linkPtr->lastValue.c,1);
+
+ case TCL_LINK_BINARY:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.pc, linkPtr->addr, linkPtr->bytes);
+ return Tcl_NewByteArrayObj((unsigned char *)linkPtr->addr,linkPtr->bytes);
+ }
+ linkPtr->lastValue.uc = LinkedVar(unsigned char);
+ return Tcl_NewByteArrayObj(&linkPtr->lastValue.uc,1);
+
/*
* This code only gets executed if the link type is unknown (shouldn't
* ever happen).
@@ -621,6 +1181,31 @@
}
/*
+ *----------------------------------------------------------------------
+ *
+ * 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.pc);
+ ckfree((char *) linkPtr);
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
Index: generic/tclStubInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclStubInit.c,v
retrieving revision 1.162
diff -u -r1.162 tclStubInit.c
--- generic/tclStubInit.c 29 Jul 2008 05:30:38 -0000 1.162
+++ generic/tclStubInit.c 17 Sep 2008 16:45:59 -0000
@@ -1114,6 +1114,7 @@
Tcl_NRCmdSwap, /* 586 */
Tcl_NRAddCallback, /* 587 */
Tcl_NRCallObjProc, /* 588 */
+ Tcl_LinkArray, /* 589 */
};
/* !END!: Do not edit above this line. */
Index: generic/tclTest.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTest.c,v
retrieving revision 1.124
diff -u -r1.124 tclTest.c
--- generic/tclTest.c 20 Aug 2008 13:14:41 -0000 1.124
+++ generic/tclTest.c 17 Sep 2008 16:45:59 -0000
@@ -273,6 +273,9 @@
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[]);
@@ -616,6 +619,8 @@
Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
(ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0, NULL);
+ Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd,
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, (ClientData) 0,
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, (ClientData) 0, NULL);
@@ -3057,6 +3062,118 @@
/*
*----------------------------------------------------------------------
*
+ * TestlinkarrayCmd --
+ *
+ * This function is invoked to process the "testlinkarray" Tcl command.
+ * It is used to test the 'Tcl_LinkArray' function.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Creates, deletes, and invokes variable links.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestlinkarrayCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ static const char *LinkOption[] = {
+ "update", "remove", "create", NULL
+ };
+ enum LinkOption { LINK_UPDATE, LINK_REMOVE, LINK_CREATE };
+ static const char *LinkType[] = {
+ "char", "uchar", "short", "ushort", "int", "uint", "long", "ulong",
+ "wide", "uwide", "float", "double", "string", "char*", "binary", NULL
+ };
+ /* all values after TCL_LINK_CHARS_ARRAY are used as arrays (see below) */
+ static int LinkTypes[] = { TCL_LINK_CHAR, TCL_LINK_UCHAR,
+ TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT,
+ TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT,
+ TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS, TCL_LINK_BINARY
+ };
+ int optionIndex;
+ int typeIndex;
+ int readonly;
+ int i;
+ char *name;
+ int 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_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_SetResult(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_GetIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
+ Tcl_SetResult(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
Index: tests/link.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/link.test,v
retrieving revision 1.17
diff -u -r1.17 link.test
--- tests/link.test 13 Dec 2007 15:26:06 -0000 1.17
+++ tests/link.test 17 Sep 2008 16:46:00 -0000
@@ -19,6 +19,7 @@
}
testConstraint testlink [llength [info commands testlink]]
+testConstraint testlinkarray [llength [info commands testlinkarray]]
foreach i {int real bool string} {
catch {unset $i}
@@ -79,7 +80,7 @@
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
list [catch {set wide gorp} msg] $msg $bool
-} {1 {can't set "wide": variable must have integer value} 1}
+} {1 {can't set "wide": variable must have wide integer value} 1}
test link-3.1 {read-only variables} {testlink} {
testlink delete
@@ -234,7 +235,7 @@
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {}
list [catch x msg] $msg $wide
-} {1 {can't set "y": variable must have integer value} 778899}
+} {1 {can't set "y": variable must have wide integer value} 778899}
test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} {
proc x args {
@@ -269,6 +270,296 @@
testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {}
} msg] $msg $int
} {0 {} 47}
+test link-9.1 {linkarray usage messages} {
+ set mylist [list]
+ catch {testlinkarray} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {testlinkarray x} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {testlinkarray update} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {testlinkarray remove} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {testlinkarray create} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {testlinkarray create xx 1 my} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {testlinkarray create char* 0 my} my(msg); lappend mylist $my(msg);unset my(msg)
+ join $mylist "\n"
+} {wrong # args: should be "testlinkarray option args"
+bad option "x": must be update, remove, or create
+
+
+wrong # args: should be "testlinkarray create ?-readonly? type size name ?address?"
+bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, char*, or binary
+wrong array size given}
+test link-10.1 {linkarray char*} {
+ set mylist [list]
+ testlinkarray create char* 1 ::my(var)
+ lappend mylist [set ::my(var) ""]
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var)
+ testlinkarray create char* 4 ::my(var)
+ set ::my(var) x
+ catch {set ::my(var) xyzz} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var)
+ testlinkarray create -r char* 4 ::my(var)
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var); unset my; join $mylist "\n"
+} {
+can't set "::my(var)": wrong size of char* value
+can't set "::my(var)": wrong size of char* value
+can't set "::my(var)": linked variable is read-only}
+test link-11.1 {linkarray char} {
+ set mylist [list]
+ testlinkarray create char 1 ::my(var)
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1234} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var)
+ testlinkarray create char 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} my(msg); lappend mylist $my(msg);unset my(msg)
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+ testlinkarray remove ::my(var)
+ testlinkarray create -r char 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var); unset my; join $mylist "\n"
+} {can't set "::my(var)": variable must have char value
+120
+can't set "::my(var)": variable must have char value
+can't set "::my(var)": wrong dimension
+1 2 3 4
+can't set "::my(var)": linked variable is read-only}
+test link-12.1 {linkarray unsigned char} {
+ set mylist [list]
+ testlinkarray create uchar 1 ::my(var)
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1234} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {set ::my(var) -1} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var)
+ testlinkarray create uchar 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} my(msg); lappend mylist $my(msg);unset my(msg)
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+ testlinkarray remove ::my(var)
+ testlinkarray create -r uchar 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var); unset my; join $mylist "\n"
+} {can't set "::my(var)": variable must have unsigned char value
+120
+can't set "::my(var)": variable must have unsigned char value
+can't set "::my(var)": variable must have unsigned char value
+can't set "::my(var)": wrong dimension
+1 2 3 4
+can't set "::my(var)": linked variable is read-only}
+test link-13.1 {linkarray short} {
+ set mylist [list]
+ testlinkarray create short 1 ::my(var)
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 123456} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var)
+ testlinkarray create short 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} my(msg); lappend mylist $my(msg);unset my(msg)
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+ testlinkarray remove ::my(var)
+ testlinkarray create -r short 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var); unset my; join $mylist "\n"
+} {can't set "::my(var)": variable must have short value
+120
+can't set "::my(var)": variable must have short value
+can't set "::my(var)": wrong dimension
+1 2 3 4
+can't set "::my(var)": linked variable is read-only}
+test link-14.1 {linkarray unsigned short} {
+ set mylist [list]
+ testlinkarray create ushort 1 ::my(var)
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 123456} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {set ::my(var) -1} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var)
+ testlinkarray create ushort 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} my(msg); lappend mylist $my(msg);unset my(msg)
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+ testlinkarray remove ::my(var)
+ testlinkarray create -r ushort 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var); unset my; join $mylist "\n"
+} {can't set "::my(var)": variable must have unsigned short value
+120
+can't set "::my(var)": variable must have unsigned short value
+can't set "::my(var)": variable must have unsigned short value
+can't set "::my(var)": wrong dimension
+1 2 3 4
+can't set "::my(var)": linked variable is read-only}
+test link-15.1 {linkarray int} {
+ set mylist [list]
+ testlinkarray create int 1 ::my(var)
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1e3} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var)
+ testlinkarray create int 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} my(msg); lappend mylist $my(msg);unset my(msg)
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+ testlinkarray remove ::my(var)
+ testlinkarray create -r int 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var); unset my; join $mylist "\n"
+} {can't set "::my(var)": variable must have integer value
+120
+can't set "::my(var)": variable must have integer value
+can't set "::my(var)": wrong dimension
+1 2 3 4
+can't set "::my(var)": linked variable is read-only}
+test link-16.1 {linkarray unsigned int} {
+ set mylist [list]
+ testlinkarray create uint 1 ::my(var)
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1e33} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {set ::my(var) -1} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var)
+ testlinkarray create uint 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} my(msg); lappend mylist $my(msg);unset my(msg)
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+ testlinkarray remove ::my(var)
+ testlinkarray create -r uint 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var); unset my; join $mylist "\n"
+} {can't set "::my(var)": variable must have unsigned int value
+120
+can't set "::my(var)": variable must have unsigned int value
+can't set "::my(var)": variable must have unsigned int value
+can't set "::my(var)": wrong dimension
+1 2 3 4
+can't set "::my(var)": linked variable is read-only}
+test link-17.1 {linkarray long} {
+ set mylist [list]
+ testlinkarray create long 1 ::my(var)
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1e33} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var)
+ testlinkarray create long 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} my(msg); lappend mylist $my(msg);unset my(msg)
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+ testlinkarray remove ::my(var)
+ testlinkarray create -r long 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var); unset my; join $mylist "\n"
+} {can't set "::my(var)": variable must have long value
+120
+can't set "::my(var)": variable must have long value
+can't set "::my(var)": wrong dimension
+1 2 3 4
+can't set "::my(var)": linked variable is read-only}
+test link-18.1 {linkarray unsigned long} {
+ set mylist [list]
+ testlinkarray create ulong 1 ::my(var)
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1e33} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {set ::my(var) -1} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var)
+ testlinkarray create ulong 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} my(msg); lappend mylist $my(msg);unset my(msg)
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+ testlinkarray remove ::my(var)
+ testlinkarray create -r ulong 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var); unset my; join $mylist "\n"
+} {can't set "::my(var)": variable must have unsigned long value
+120
+can't set "::my(var)": variable must have unsigned long value
+can't set "::my(var)": variable must have unsigned long value
+can't set "::my(var)": wrong dimension
+1 2 3 4
+can't set "::my(var)": linked variable is read-only}
+test link-19.1 {linkarray wide} {
+ set mylist [list]
+ testlinkarray create wide 1 ::my(var)
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1e33} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var)
+ testlinkarray create wide 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} my(msg); lappend mylist $my(msg);unset my(msg)
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+ testlinkarray remove ::my(var)
+ testlinkarray create -r wide 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var); unset my; join $mylist "\n"
+} {can't set "::my(var)": variable must have wide integer value
+120
+can't set "::my(var)": variable must have wide integer value
+can't set "::my(var)": wrong dimension
+1 2 3 4
+can't set "::my(var)": linked variable is read-only}
+test link-20.1 {linkarray unsigned wide} {
+ set mylist [list]
+ testlinkarray create uwide 1 ::my(var)
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1e33} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {set ::my(var) -1} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var)
+ testlinkarray create uwide 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} my(msg); lappend mylist $my(msg);unset my(msg)
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+ testlinkarray remove ::my(var)
+ testlinkarray create -r uwide 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var); unset my; join $mylist "\n"
+} {can't set "::my(var)": variable must have unsigned wide int value
+120
+can't set "::my(var)": variable must have unsigned wide int value
+can't set "::my(var)": variable must have unsigned wide int value
+can't set "::my(var)": wrong dimension
+1 2 3 4
+can't set "::my(var)": linked variable is read-only}
+test link-21.1 {linkarray string} {
+ set mylist [list]
+ testlinkarray create string 1 ::my(var)
+ lappend mylist [set ::my(var) ""]
+ lappend mylist [set ::my(var) "xyz"]
+ lappend mylist $::my(var)
+ testlinkarray remove ::my(var)
+ testlinkarray create -r string 4 ::my(var)
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var); unset my; join $mylist "\n"
+} {
+xyz
+xyz
+can't set "::my(var)": linked variable is read-only}
+test link-22.1 {linkarray binary} {
+ set mylist [list]
+ testlinkarray create binary 1 ::my(var)
+ set ::my(var) x
+ catch {set ::my(var) xy} my(msg); lappend mylist $my(msg);unset my(msg)
+ lappend mylist $::my(var)
+ testlinkarray remove ::my(var)
+ testlinkarray create binary 4 ::my(var)
+ catch {set ::my(var) abc} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {set ::my(var) abcde} my(msg); lappend mylist $my(msg);unset my(msg)
+ set ::my(var) abcd
+ lappend mylist $::my(var)
+ testlinkarray remove ::my(var)
+ testlinkarray create -r binary 4 ::my(var)
+ catch {set ::my(var) xyzv} my(msg); lappend mylist $my(msg);unset my(msg)
+ testlinkarray remove ::my(var); unset my; join $mylist "\n"
+} {can't set "::my(var)": wrong size of binary value
+x
+can't set "::my(var)": wrong size of binary value
+can't set "::my(var)": wrong size of binary value
+abcd
+can't set "::my(var)": linked variable is read-only}
catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0}
catch {testlink delete}
