Attachment "link.diff" to
ticket [1881048fff]
added by
dkf
2008-01-28 17:58:16.
diff -Nupr tcl-8.5/generic/tclBasic.c tclTIP/generic/tclBasic.c
--- tcl-8.5/generic/tclBasic.c 2007-12-13 16:23:14.000000000 +0100
+++ tclTIP/generic/tclBasic.c 2008-01-26 19:54:22.000000000 +0100
@@ -146,6 +146,7 @@ static const CmdInfo builtInCmds[] = {
{"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, 1},
{"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, 1},
{"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, 1},
+ {"link", Tcl_LinkObjCmd, NULL, 0},
{"linsert", Tcl_LinsertObjCmd, NULL, 1},
{"list", Tcl_ListObjCmd, TclCompileListCmd, 1},
{"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, 1},
diff -Nupr tcl-8.5/generic/tcl.decls tclTIP/generic/tcl.decls
--- tcl-8.5/generic/tcl.decls 2007-12-13 16:23:14.000000000 +0100
+++ tclTIP/generic/tcl.decls 2008-01-26 19:52:14.000000000 +0100
@@ -2099,6 +2099,12 @@ declare 579 generic {
void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, CONST char *format, ...)
}
+# TIP#TODO Create ''link'' command and add more link types
+declare 580 generic {
+ int Tcl_LinkVar(Tcl_Interp *interp, CONST char *varName, char *addr,
+ int type, int size)
+}
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are
diff -Nupr tcl-8.5/generic/tcl.h tclTIP/generic/tcl.h
--- tcl-8.5/generic/tcl.h 2007-12-13 16:23:14.000000000 +0100
+++ tclTIP/generic/tcl.h 2008-01-26 19:49:50.000000000 +0100
@@ -1065,6 +1065,8 @@ typedef struct Tcl_DString {
#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
/*
diff -Nupr tcl-8.5/generic/tclInt.h tclTIP/generic/tclInt.h
--- tcl-8.5/generic/tclInt.h 2007-12-17 16:28:27.000000000 +0100
+++ tclTIP/generic/tclInt.h 2008-01-26 20:10:58.000000000 +0100
@@ -2826,6 +2826,9 @@ MODULE_SCOPE int Tcl_LassignObjCmd(Clien
MODULE_SCOPE int Tcl_LindexObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LinkObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_LinsertObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
diff -Nupr tcl-8.5/generic/tclLink.c tclTIP/generic/tclLink.c
--- tcl-8.5/generic/tclLink.c 2007-12-13 16:23:18.000000000 +0100
+++ tclTIP/generic/tclLink.c 2008-01-26 20:13:51.000000000 +0100
@@ -30,6 +30,9 @@ typedef struct Link {
* 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 @@ typedef struct Link {
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 @@ 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 +88,7 @@ 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);
/*
* Convenience macro for accessing the value of the C variable pointed to by a
@@ -125,11 +145,12 @@ Tcl_LinkVar(
} 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
@@ -137,7 +158,149 @@ Tcl_LinkVar(
(ClientData) 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;
}
@@ -176,7 +339,7 @@ Tcl_UnlinkVar(
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, (ClientData) linkPtr);
Tcl_DecrRefCount(linkPtr->varName);
- ckfree((char *) linkPtr);
+ LinkFree(linkPtr);
}
/*
@@ -228,6 +391,118 @@ Tcl_UpdateLinkedVar(
/*
*----------------------------------------------------------------------
*
+ * Tcl_LinkObjCmd --
+ *
+ * This function is invoked to process the "link" Tcl command. See the
+ * user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LinkObjCmd(
+ 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", "chars", "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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* LinkTraceProc --
*
* This function is invoked when a linked Tcl variable is read, written,
@@ -262,6 +537,9 @@ LinkTraceProc(
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)
@@ -271,7 +549,7 @@ LinkTraceProc(
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);
@@ -298,6 +576,11 @@ LinkTraceProc(
*/
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:
@@ -337,10 +620,13 @@ LinkTraceProc(
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),
@@ -352,7 +638,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.
@@ -374,6 +660,21 @@ LinkTraceProc(
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),
@@ -384,16 +685,53 @@ LinkTraceProc(
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
@@ -411,6 +749,21 @@ LinkTraceProc(
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),
@@ -421,6 +774,23 @@ LinkTraceProc(
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),
@@ -432,6 +802,23 @@ LinkTraceProc(
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),
@@ -443,6 +830,23 @@ LinkTraceProc(
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),
@@ -454,6 +858,23 @@ LinkTraceProc(
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),
@@ -465,6 +886,23 @@ LinkTraceProc(
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),
@@ -476,6 +914,23 @@ LinkTraceProc(
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),
@@ -487,6 +942,23 @@ LinkTraceProc(
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),
@@ -501,7 +973,25 @@ LinkTraceProc(
/*
* 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";
@@ -511,6 +1001,23 @@ LinkTraceProc(
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),
@@ -525,11 +1032,39 @@ LinkTraceProc(
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 chars 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";
}
@@ -560,49 +1095,169 @@ ObjValue(
{
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 *);
@@ -612,6 +1267,23 @@ ObjValue(
}
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).
@@ -624,6 +1296,31 @@ ObjValue(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * 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
diff -Nupr tcl-8.5/tests/link.test tclTIP/tests/link.test
--- tcl-8.5/tests/link.test 2007-12-13 16:26:06.000000000 +0100
+++ tclTIP/tests/link.test 2008-01-26 20:26:32.000000000 +0100
@@ -79,7 +79,7 @@ test link-2.5 {writing bad values into v
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 +234,7 @@ test link-7.7 {access to linked variable
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 {
@@ -275,6 +275,296 @@ catch {testlink delete}
foreach i {int real bool string wide} {
catch {unset $i}
}
+test link-9.1 {link usage messages} {
+ set mylist [list]
+ catch {link} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {link x} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {link update} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {link remove} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {link create} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {link create xx 1 my} my(msg); lappend mylist $my(msg);unset my(msg)
+ catch {link create chars 0 my} my(msg); lappend mylist $my(msg);unset my(msg)
+ join $mylist "\n"
+} {wrong # args: should be "link option args"
+bad option "x": must be update, remove, or create
+
+
+wrong # args: should be "link create ?-readonly? type size name ?address?"
+bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, chars, or binary
+wrong array size given}
+test link-10.1 {link chars} {
+ set mylist [list]
+ link create chars 1 ::my(var)
+ lappend mylist [set ::my(var) ""]
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ link remove ::my(var)
+ link create chars 4 ::my(var)
+ set ::my(var) x
+ catch {set ::my(var) xyzz} my(msg); lappend mylist $my(msg);unset my(msg)
+ link remove ::my(var)
+ link create -r chars 4 ::my(var)
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ link remove ::my(var); unset my; join $mylist "\n"
+} {
+can't set "::my(var)": wrong size of chars value
+can't set "::my(var)": wrong size of chars value
+can't set "::my(var)": linked variable is read-only}
+test link-11.1 {link char} {
+ set mylist [list]
+ link 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)
+ link remove ::my(var)
+ link 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)
+ link remove ::my(var)
+ link create -r char 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ link 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 {link unsigned char} {
+ set mylist [list]
+ link 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)
+ link remove ::my(var)
+ link 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)
+ link remove ::my(var)
+ link create -r uchar 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ link 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 {link short} {
+ set mylist [list]
+ link 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)
+ link remove ::my(var)
+ link 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)
+ link remove ::my(var)
+ link create -r short 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ link 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 {link unsigned short} {
+ set mylist [list]
+ link 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)
+ link remove ::my(var)
+ link 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)
+ link remove ::my(var)
+ link create -r ushort 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ link 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 {link int} {
+ set mylist [list]
+ link 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)
+ link remove ::my(var)
+ link 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)
+ link remove ::my(var)
+ link create -r int 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ link 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 {link unsigned int} {
+ set mylist [list]
+ link 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)
+ link remove ::my(var)
+ link 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)
+ link remove ::my(var)
+ link create -r uint 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ link 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 {link long} {
+ set mylist [list]
+ link 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)
+ link remove ::my(var)
+ link 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)
+ link remove ::my(var)
+ link create -r long 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ link 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 {link unsigned long} {
+ set mylist [list]
+ link 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)
+ link remove ::my(var)
+ link 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)
+ link remove ::my(var)
+ link create -r ulong 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ link 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 {link wide} {
+ set mylist [list]
+ link 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)
+ link remove ::my(var)
+ link 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)
+ link remove ::my(var)
+ link create -r wide 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ link 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 {link unsigned wide} {
+ set mylist [list]
+ link 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)
+ link remove ::my(var)
+ link 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)
+ link remove ::my(var)
+ link create -r uwide 2 ::my(var)
+ catch {set ::my(var) {1 2}} my(msg); lappend mylist $my(msg);unset my(msg)
+ link 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 {link string} {
+ set mylist [list]
+ link create string 1 ::my(var)
+ lappend mylist [set ::my(var) ""]
+ lappend mylist [set ::my(var) "xyz"]
+ lappend mylist $::my(var)
+ link remove ::my(var)
+ link create -r string 4 ::my(var)
+ catch {set ::my(var) x} my(msg); lappend mylist $my(msg);unset my(msg)
+ link remove ::my(var); unset my; join $mylist "\n"
+} {
+xyz
+xyz
+can't set "::my(var)": linked variable is read-only}
+test link-22.1 {link binary} {
+ set mylist [list]
+ link 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)
+ link remove ::my(var)
+ link 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)
+ link remove ::my(var)
+ link create -r binary 4 ::my(var)
+ catch {set ::my(var) xyzv} my(msg); lappend mylist $my(msg);unset my(msg)
+ link 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}
# cleanup
::tcltest::cleanupTests
