summaryrefslogtreecommitdiffstats
path: root/generic/tclLink.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclLink.c')
-rw-r--r--generic/tclLink.c519
1 files changed, 339 insertions, 180 deletions
diff --git a/generic/tclLink.c b/generic/tclLink.c
index 28b1786..f7911a4 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -1,102 +1,125 @@
-/*
+/*
* tclLink.c --
*
- * This file implements linked variables (a C variable that is
- * tied to a Tcl variable). The idea of linked variables was
- * first suggested by Andreas Stolcke and this implementation is
- * based heavily on a prototype implementation provided by
- * him.
+ * This file implements linked variables (a C variable that is tied to a
+ * Tcl variable). The idea of linked variables was first suggested by
+ * Andreas Stolcke and this implementation is based heavily on a
+ * prototype implementation provided by him.
*
* Copyright (c) 1993 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
- * For each linked variable there is a data structure of the following
- * type, which describes the link and is the clientData for the trace
- * set on the Tcl variable.
+ * For each linked variable there is a data structure of the following type,
+ * which describes the link and is the clientData for the trace set on the Tcl
+ * variable.
*/
typedef struct Link {
Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
- Tcl_Obj *varName; /* Name of variable (must be global). This
- * is needed during trace callbacks, since
- * the actual variable may be aliased at
- * that time via upvar. */
+ Tcl_Obj *varName; /* Name of variable (must be global). This is
+ * needed during trace callbacks, since the
+ * actual variable may be aliased at that time
+ * via upvar. */
char *addr; /* Location of C variable. */
int type; /* Type of link (TCL_LINK_INT, etc.). */
union {
+ char c;
+ unsigned char uc;
int i;
- double d;
+ unsigned int ui;
+ short s;
+ unsigned short us;
+ long l;
+ unsigned long ul;
Tcl_WideInt w;
- } lastValue; /* Last known value of C variable; used to
+ Tcl_WideUInt uw;
+ float f;
+ double d;
+ } lastValue; /* Last known value of C variable; used to
* avoid string conversions. */
- int flags; /* Miscellaneous one-bit values; see below
- * for definitions. */
+ int flags; /* Miscellaneous one-bit values; see below for
+ * definitions. */
} Link;
/*
* Definitions for flag bits:
* LINK_READ_ONLY - 1 means errors should be generated if Tcl
* script attempts to write variable.
- * 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_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.
*/
#define LINK_READ_ONLY 1
#define LINK_BEING_UPDATED 2
/*
- * Forward references to procedures defined later in this file:
+ * Forward references to functions defined later in this file:
+ */
+
+static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp,
+ CONST char *name1, CONST char *name2, int flags);
+static Tcl_Obj * ObjValue(Link *linkPtr);
+
+/*
+ * Convenience macro for accessing the value of the C variable pointed to by a
+ * link. Note that this macro produces something that may be regarded as an
+ * lvalue or rvalue; it may be assigned to as well as read. Also note that
+ * this macro assumes the name of the variable being accessed (linkPtr); this
+ * is not strictly a good thing, but it keeps the code much shorter and
+ * cleaner.
*/
-static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, CONST char *name1,
- CONST char *name2, int flags));
-static Tcl_Obj * ObjValue _ANSI_ARGS_((Link *linkPtr));
+#define LinkedVar(type) (*(type *) linkPtr->addr)
/*
*----------------------------------------------------------------------
*
* Tcl_LinkVar --
*
- * Link a C variable to a Tcl variable so that changes to either
- * one causes the other to change.
+ * Link a C variable 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).
+ * 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.
+ * 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_LinkVar(interp, varName, addr, type)
- 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. */
- int type; /* Type of C variable: TCL_LINK_INT, etc.
- * Also may have TCL_LINK_READ_ONLY
- * OR'ed in. */
+Tcl_LinkVar(
+ 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. */
+ int type) /* Type of C variable: TCL_LINK_INT, etc. Also
+ * may have TCL_LINK_READ_ONLY OR'ed in. */
{
- Tcl_Obj *objPtr, *resPtr;
+ Tcl_Obj *objPtr;
Link *linkPtr;
int code;
+ linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
+ LinkTraceProc, (ClientData) NULL);
+ if (linkPtr != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "variable '%s' is already linked", varName));
+ return TCL_ERROR;
+ }
+
linkPtr = (Link *) ckalloc(sizeof(Link));
linkPtr->interp = interp;
linkPtr->varName = Tcl_NewStringObj(varName, -1);
@@ -109,11 +132,8 @@ Tcl_LinkVar(interp, varName, addr, type)
linkPtr->flags = 0;
}
objPtr = ObjValue(linkPtr);
- Tcl_IncrRefCount(objPtr);
- resPtr = Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
- TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
- Tcl_DecrRefCount(objPtr);
- if (resPtr == NULL) {
+ if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
+ TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
return TCL_ERROR;
@@ -139,17 +159,17 @@ Tcl_LinkVar(interp, varName, addr, type)
* None.
*
* Side effects:
- * If "varName" was previously linked to a C variable, the link
- * is broken to make the variable independent. If there was no
- * previous link for "varName" then nothing happens.
+ * If "varName" was previously linked to a C variable, the link is broken
+ * to make the variable independent. If there was no previous link for
+ * "varName" then nothing happens.
*
*----------------------------------------------------------------------
*/
void
-Tcl_UnlinkVar(interp, varName)
- Tcl_Interp *interp; /* Interpreter containing variable to unlink. */
- CONST char *varName; /* Global variable in interp to unlink. */
+Tcl_UnlinkVar(
+ Tcl_Interp *interp, /* Interpreter containing variable to unlink */
+ CONST char *varName) /* Global variable in interp to unlink. */
{
Link *linkPtr;
@@ -170,28 +190,27 @@ Tcl_UnlinkVar(interp, varName)
*
* Tcl_UpdateLinkedVar --
*
- * This procedure is invoked after a linked variable has been
- * changed by C code. It updates the Tcl variable so that
- * traces on the variable will trigger.
+ * This function is invoked after a linked variable has been changed by C
+ * code. It updates the Tcl variable so that traces on the variable will
+ * trigger.
*
* Results:
* None.
*
* Side effects:
- * The Tcl variable "varName" is updated from its C value,
- * causing traces on the variable to trigger.
+ * The Tcl variable "varName" is updated from its C value, causing traces
+ * on the variable to trigger.
*
*----------------------------------------------------------------------
*/
void
-Tcl_UpdateLinkedVar(interp, varName)
- Tcl_Interp *interp; /* Interpreter containing variable. */
- CONST char *varName; /* Name of global variable that is linked. */
+Tcl_UpdateLinkedVar(
+ Tcl_Interp *interp, /* Interpreter containing variable. */
+ CONST char *varName) /* Name of global variable that is linked. */
{
Link *linkPtr;
int savedFlag;
- Tcl_Obj *objPtr;
linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
LinkTraceProc, (ClientData) NULL);
@@ -200,10 +219,8 @@ Tcl_UpdateLinkedVar(interp, varName)
}
savedFlag = linkPtr->flags & LINK_BEING_UPDATED;
linkPtr->flags |= LINK_BEING_UPDATED;
- objPtr = ObjValue(linkPtr);
- Tcl_IncrRefCount(objPtr);
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY);
- Tcl_DecrRefCount(objPtr);
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
/*
* Callback may have unlinked the variable. [Bug 1740631]
*/
@@ -219,39 +236,42 @@ Tcl_UpdateLinkedVar(interp, varName)
*
* LinkTraceProc --
*
- * This procedure is invoked when a linked Tcl variable is read,
- * written, or unset from Tcl. It's responsible for keeping the
- * C variable in sync with the Tcl variable.
+ * This function is invoked when a linked Tcl variable is read, written,
+ * or unset from Tcl. It's responsible for keeping the C variable in sync
+ * with the Tcl variable.
*
* Results:
- * If all goes well, NULL is returned; otherwise an error message
- * is returned.
+ * If all goes well, NULL is returned; otherwise an error message is
+ * returned.
*
* Side effects:
- * The C variable may be updated to make it consistent with the
- * Tcl variable, or the Tcl variable may be overwritten to reject
- * a modification.
+ * The C variable may be updated to make it consistent with the Tcl
+ * variable, or the Tcl variable may be overwritten to reject a
+ * modification.
*
*----------------------------------------------------------------------
*/
static char *
-LinkTraceProc(clientData, interp, name1, name2, flags)
- ClientData clientData; /* Contains information about the link. */
- Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
- CONST char *name1; /* First part of variable name. */
- CONST char *name2; /* Second part of variable name. */
- int flags; /* Miscellaneous additional information. */
+LinkTraceProc(
+ ClientData clientData, /* Contains information about the link. */
+ Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
+ CONST char *name1, /* First part of variable name. */
+ CONST char *name2, /* Second part of variable name. */
+ int flags) /* Miscellaneous additional information. */
{
Link *linkPtr = (Link *) clientData;
int changed, valueLength;
CONST char *value;
- char **pp, *result;
- Tcl_Obj *objPtr, *valueObj, *tmpPtr;
+ char **pp;
+ Tcl_Obj *valueObj;
+ int valueInt;
+ Tcl_WideInt valueWide;
+ double valueDouble;
/*
- * If the variable is being unset, then just re-create it (with a
- * trace) unless the whole interpreter is going away.
+ * If the variable is being unset, then just re-create it (with a trace)
+ * unless the whole interpreter is going away.
*/
if (flags & TCL_TRACE_UNSETS) {
@@ -259,11 +279,8 @@ LinkTraceProc(clientData, interp, name1, name2, flags)
Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
} else if (flags & TCL_TRACE_DESTROYED) {
- tmpPtr = ObjValue(linkPtr);
- Tcl_IncrRefCount(tmpPtr);
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- Tcl_DecrRefCount(tmpPtr);
Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName),
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr);
@@ -272,10 +289,9 @@ LinkTraceProc(clientData, interp, name1, name2, flags)
}
/*
- * If we were invoked because of a call to Tcl_UpdateLinkedVar, then
- * don't do anything at all. In particular, we don't want to get
- * upset that the variable is being modified, even if it is
- * supposed to be read-only.
+ * If we were invoked because of a call to Tcl_UpdateLinkedVar, then don't
+ * do anything at all. In particular, we don't want to get upset that the
+ * variable is being modified, even if it is supposed to be read-only.
*/
if (linkPtr->flags & LINK_BEING_UPDATED) {
@@ -283,21 +299,48 @@ LinkTraceProc(clientData, interp, name1, name2, flags)
}
/*
- * For read accesses, update the Tcl variable if the C variable
- * has changed since the last time we updated the Tcl variable.
+ * For read accesses, update the Tcl variable if the C variable has
+ * changed since the last time we updated the Tcl variable.
*/
if (flags & TCL_TRACE_READS) {
switch (linkPtr->type) {
case TCL_LINK_INT:
case TCL_LINK_BOOLEAN:
- changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
+ changed = (LinkedVar(int) != linkPtr->lastValue.i);
break;
case TCL_LINK_DOUBLE:
- changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
+ changed = (LinkedVar(double) != linkPtr->lastValue.d);
break;
case TCL_LINK_WIDE_INT:
- changed = *(Tcl_WideInt *)(linkPtr->addr) != linkPtr->lastValue.w;
+ changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w);
+ break;
+ case TCL_LINK_WIDE_UINT:
+ changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw);
+ break;
+ case TCL_LINK_CHAR:
+ changed = (LinkedVar(char) != linkPtr->lastValue.c);
+ break;
+ case TCL_LINK_UCHAR:
+ changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc);
+ break;
+ case TCL_LINK_SHORT:
+ changed = (LinkedVar(short) != linkPtr->lastValue.s);
+ break;
+ case TCL_LINK_USHORT:
+ changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us);
+ break;
+ case TCL_LINK_UINT:
+ changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui);
+ break;
+ case TCL_LINK_LONG:
+ changed = (LinkedVar(long) != linkPtr->lastValue.l);
+ break;
+ case TCL_LINK_ULONG:
+ changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul);
+ break;
+ case TCL_LINK_FLOAT:
+ changed = (LinkedVar(float) != linkPtr->lastValue.f);
break;
case TCL_LINK_STRING:
changed = 1;
@@ -306,30 +349,24 @@ LinkTraceProc(clientData, interp, name1, name2, flags)
return "internal error: bad linked variable type";
}
if (changed) {
- tmpPtr = ObjValue(linkPtr);
- Tcl_IncrRefCount(tmpPtr);
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- Tcl_DecrRefCount(tmpPtr);
}
return NULL;
}
/*
- * 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 error. Another tricky thing: we have to save
- * and restore the interpreter's result, since the variable access
- * could occur when the result has been partially set.
+ * 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
+ * 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.
*/
if (linkPtr->flags & LINK_READ_ONLY) {
- tmpPtr = ObjValue(linkPtr);
- Tcl_IncrRefCount(tmpPtr);
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- Tcl_DecrRefCount(tmpPtr);
return "linked variable is read-only";
}
valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY);
@@ -337,92 +374,172 @@ LinkTraceProc(clientData, interp, name1, name2, flags)
/*
* This shouldn't ever happen.
*/
+
return "internal error: linked variable couldn't be read";
}
- objPtr = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(objPtr);
- Tcl_ResetResult(interp);
- result = NULL;
-
switch (linkPtr->type) {
case TCL_LINK_INT:
- if (Tcl_GetIntFromObj(interp, valueObj, &linkPtr->lastValue.i)
+ if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
- Tcl_SetObjResult(interp, objPtr);
- tmpPtr = ObjValue(linkPtr);
- Tcl_IncrRefCount(tmpPtr);
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- Tcl_DecrRefCount(tmpPtr);
- result = "variable must have integer value";
- goto end;
+ return "variable must have integer value";
}
- *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
+ LinkedVar(int) = linkPtr->lastValue.i;
break;
case TCL_LINK_WIDE_INT:
- if (Tcl_GetWideIntFromObj(interp, valueObj, &linkPtr->lastValue.w)
+ if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w)
!= TCL_OK) {
- Tcl_SetObjResult(interp, objPtr);
- tmpPtr = ObjValue(linkPtr);
- Tcl_IncrRefCount(tmpPtr);
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- Tcl_DecrRefCount(tmpPtr);
- result = "variable must have integer value";
- goto end;
+ return "variable must have integer value";
}
- *(Tcl_WideInt *)(linkPtr->addr) = linkPtr->lastValue.w;
+ LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
break;
case TCL_LINK_DOUBLE:
- if (Tcl_GetDoubleFromObj(interp, valueObj, &linkPtr->lastValue.d)
+ if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d)
!= TCL_OK) {
- Tcl_SetObjResult(interp, objPtr);
- tmpPtr = ObjValue(linkPtr);
- Tcl_IncrRefCount(tmpPtr);
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
- TCL_GLOBAL_ONLY);
- Tcl_DecrRefCount(tmpPtr);
- result = "variable must have real value";
- goto end;
+#ifdef ACCEPT_NAN
+ if (valueObj->typePtr != &tclDoubleType) {
+#endif
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return "variable must have real value";
+#ifdef ACCEPT_NAN
+ }
+ linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
+#endif
}
- *(double *)(linkPtr->addr) = linkPtr->lastValue.d;
+ LinkedVar(double) = linkPtr->lastValue.d;
break;
case TCL_LINK_BOOLEAN:
- if (Tcl_GetBooleanFromObj(interp, valueObj, &linkPtr->lastValue.i)
- != TCL_OK) {
- Tcl_SetObjResult(interp, objPtr);
- tmpPtr = ObjValue(linkPtr);
- Tcl_IncrRefCount(tmpPtr);
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
+ if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i)
+ != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable must have boolean value";
+ }
+ LinkedVar(int) = linkPtr->lastValue.i;
+ break;
+
+ case TCL_LINK_CHAR:
+ if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable must have char value";
+ }
+ linkPtr->lastValue.c = (char)valueInt;
+ LinkedVar(char) = linkPtr->lastValue.c;
+ break;
+
+ case TCL_LINK_UCHAR:
+ if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ || valueInt < 0 || valueInt > UCHAR_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- Tcl_DecrRefCount(tmpPtr);
- result = "variable must have boolean value";
- goto end;
+ return "variable must have unsigned char value";
}
- *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
+ linkPtr->lastValue.uc = (unsigned char) valueInt;
+ LinkedVar(unsigned char) = linkPtr->lastValue.uc;
+ break;
+
+ case TCL_LINK_SHORT:
+ if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ || valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable must have short value";
+ }
+ linkPtr->lastValue.s = (short)valueInt;
+ LinkedVar(short) = linkPtr->lastValue.s;
+ break;
+
+ case TCL_LINK_USHORT:
+ if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ || valueInt < 0 || valueInt > USHRT_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable must have unsigned short value";
+ }
+ linkPtr->lastValue.us = (unsigned short)valueInt;
+ LinkedVar(unsigned short) = linkPtr->lastValue.us;
+ break;
+
+ case TCL_LINK_UINT:
+ if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
+ || valueWide < 0 || valueWide > UINT_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable must have unsigned int value";
+ }
+ linkPtr->lastValue.ui = (unsigned int)valueWide;
+ LinkedVar(unsigned int) = linkPtr->lastValue.ui;
+ break;
+
+ case TCL_LINK_LONG:
+ if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
+ || valueWide < LONG_MIN || valueWide > LONG_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable must have long value";
+ }
+ linkPtr->lastValue.l = (long)valueWide;
+ LinkedVar(long) = linkPtr->lastValue.l;
+ break;
+
+ case TCL_LINK_ULONG:
+ if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
+ || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable must have unsigned long value";
+ }
+ linkPtr->lastValue.ul = (unsigned long)valueWide;
+ LinkedVar(unsigned long) = linkPtr->lastValue.ul;
+ break;
+
+ case TCL_LINK_WIDE_UINT:
+ /*
+ * FIXME: represent as a bignum.
+ */
+ if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable must have unsigned wide int value";
+ }
+ linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
+ LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
+ break;
+
+ case TCL_LINK_FLOAT:
+ if (Tcl_GetDoubleFromObj(interp, valueObj, &valueDouble) != TCL_OK
+ || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return "variable must have float value";
+ }
+ linkPtr->lastValue.f = (float)valueDouble;
+ LinkedVar(float) = linkPtr->lastValue.f;
break;
case TCL_LINK_STRING:
value = Tcl_GetStringFromObj(valueObj, &valueLength);
valueLength++;
- pp = (char **)(linkPtr->addr);
- if (*pp != NULL) {
- ckfree(*pp);
- }
- *pp = (char *) ckalloc((unsigned) valueLength);
+ pp = (char **) linkPtr->addr;
+
+ *pp = ckrealloc(*pp, valueLength);
memcpy(*pp, value, (unsigned) valueLength);
break;
default:
return "internal error: bad linked variable type";
}
- end:
- Tcl_DecrRefCount(objPtr);
- return result;
+ return NULL;
}
/*
@@ -430,12 +547,12 @@ LinkTraceProc(clientData, interp, name1, name2, flags)
*
* ObjValue --
*
- * Converts the value of a C variable to a Tcl_Obj* for use in a
- * Tcl variable to which it is linked.
+ * Converts the value of a C variable to a Tcl_Obj* for use in a Tcl
+ * variable to which it is linked.
*
* Results:
- * The return value is a pointer to a Tcl_Obj that represents
- * the value of the C variable given by linkPtr.
+ * The return value is a pointer to a Tcl_Obj that represents the value
+ * of the C variable given by linkPtr.
*
* Side effects:
* None.
@@ -444,36 +561,78 @@ LinkTraceProc(clientData, interp, name1, name2, flags)
*/
static Tcl_Obj *
-ObjValue(linkPtr)
- Link *linkPtr; /* Structure describing linked variable. */
+ObjValue(
+ Link *linkPtr) /* Structure describing linked variable. */
{
char *p;
+ Tcl_Obj *resultObj;
switch (linkPtr->type) {
case TCL_LINK_INT:
- linkPtr->lastValue.i = *(int *)(linkPtr->addr);
+ linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewIntObj(linkPtr->lastValue.i);
case TCL_LINK_WIDE_INT:
- linkPtr->lastValue.w = *(Tcl_WideInt *)(linkPtr->addr);
+ linkPtr->lastValue.w = LinkedVar(Tcl_WideInt);
return Tcl_NewWideIntObj(linkPtr->lastValue.w);
case TCL_LINK_DOUBLE:
- linkPtr->lastValue.d = *(double *)(linkPtr->addr);
+ linkPtr->lastValue.d = LinkedVar(double);
return Tcl_NewDoubleObj(linkPtr->lastValue.d);
case TCL_LINK_BOOLEAN:
- linkPtr->lastValue.i = *(int *)(linkPtr->addr);
+ linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0);
+ case TCL_LINK_CHAR:
+ linkPtr->lastValue.c = LinkedVar(char);
+ return Tcl_NewIntObj(linkPtr->lastValue.c);
+ case TCL_LINK_UCHAR:
+ linkPtr->lastValue.uc = LinkedVar(unsigned char);
+ return Tcl_NewIntObj(linkPtr->lastValue.uc);
+ case TCL_LINK_SHORT:
+ linkPtr->lastValue.s = LinkedVar(short);
+ return Tcl_NewIntObj(linkPtr->lastValue.s);
+ case TCL_LINK_USHORT:
+ linkPtr->lastValue.us = LinkedVar(unsigned short);
+ return Tcl_NewIntObj(linkPtr->lastValue.us);
+ case TCL_LINK_UINT:
+ linkPtr->lastValue.ui = LinkedVar(unsigned int);
+ return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui);
+ case TCL_LINK_LONG:
+ linkPtr->lastValue.l = LinkedVar(long);
+ return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l);
+ case TCL_LINK_ULONG:
+ linkPtr->lastValue.ul = LinkedVar(unsigned long);
+ return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul);
+ case TCL_LINK_FLOAT:
+ linkPtr->lastValue.f = LinkedVar(float);
+ return Tcl_NewDoubleObj(linkPtr->lastValue.f);
+ case TCL_LINK_WIDE_UINT:
+ linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
+ /*
+ * FIXME: represent as a bignum.
+ */
+ return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw);
case TCL_LINK_STRING:
- p = *(char **)(linkPtr->addr);
+ p = LinkedVar(char *);
if (p == NULL) {
- return Tcl_NewStringObj("NULL", 4);
+ TclNewLiteralStringObj(resultObj, "NULL");
+ return resultObj;
}
return Tcl_NewStringObj(p, -1);
/*
- * This code only gets executed if the link type is unknown
- * (shouldn't ever happen).
+ * This code only gets executed if the link type is unknown (shouldn't
+ * ever happen).
*/
+
default:
- return Tcl_NewStringObj("??", 2);
+ TclNewLiteralStringObj(resultObj, "??");
+ return resultObj;
}
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
generated by cgit v0.12 at 2024-11-05 21:05:17 (GMT)