diff options
Diffstat (limited to 'generic/tclLink.c')
| -rw-r--r-- | generic/tclLink.c | 666 |
1 files changed, 488 insertions, 178 deletions
diff --git a/generic/tclLink.c b/generic/tclLink.c index 3476766..a39dfcd 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -1,110 +1,144 @@ -/* +/* * 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. - * - * RCS: @(#) $Id: tclLink.c,v 1.8 2002/08/05 03:24:41 dgp Exp $ + * 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; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) + long l; + unsigned long ul; +#endif 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); +static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr); +static int GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr); +static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr); + +/* + * 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; Link *linkPtr; int code; - linkPtr = (Link *) ckalloc(sizeof(Link)); + linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, + TCL_GLOBAL_ONLY, LinkTraceProc, (ClientData) NULL); + if (linkPtr != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "variable '%s' is already linked", varName)); + return TCL_ERROR; + } + + linkPtr = ckalloc(sizeof(Link)); linkPtr->interp = interp; linkPtr->varName = Tcl_NewStringObj(varName, -1); Tcl_IncrRefCount(linkPtr->varName); linkPtr->addr = addr; linkPtr->type = type & ~TCL_LINK_READ_ONLY; +#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \ + || defined(_WIN32) || defined(__CYGWIN__)) + if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) { + linkPtr->type = TCL_LINK_LONG; + } else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) { + linkPtr->type = TCL_LINK_ULONG; + } +#endif if (type & TCL_LINK_READ_ONLY) { linkPtr->flags = LINK_READ_ONLY; } else { @@ -114,16 +148,15 @@ Tcl_LinkVar(interp, varName, addr, type) if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(linkPtr->varName); - Tcl_DecrRefCount(objPtr); - ckfree((char *) linkPtr); + ckfree(linkPtr); return TCL_ERROR; } - code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS - |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, - (ClientData) linkPtr); + code = Tcl_TraceVar2(interp, varName, NULL, + 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); + ckfree(linkPtr); } return code; } @@ -139,30 +172,29 @@ 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; + Link *linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, + TCL_GLOBAL_ONLY, LinkTraceProc, NULL); - linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, - LinkTraceProc, (ClientData) NULL); if (linkPtr == NULL) { return; } - Tcl_UntraceVar(interp, varName, + Tcl_UntraceVar2(interp, varName, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - LinkTraceProc, (ClientData) linkPtr); + LinkTraceProc, linkPtr); Tcl_DecrRefCount(linkPtr->varName); - ckfree((char *) linkPtr); + ckfree(linkPtr); } /* @@ -170,30 +202,29 @@ 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; + Link *linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, + TCL_GLOBAL_ONLY, LinkTraceProc, NULL); int savedFlag; - linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, - LinkTraceProc, (ClientData) NULL); if (linkPtr == NULL) { return; } @@ -201,7 +232,14 @@ Tcl_UpdateLinkedVar(interp, varName) linkPtr->flags |= LINK_BEING_UPDATED; Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag; + /* + * Callback may have unlinked the variable. [Bug 1740631] + */ + linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, + TCL_GLOBAL_ONLY, LinkTraceProc, NULL); + if (linkPtr != NULL) { + linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag; + } } /* @@ -209,60 +247,63 @@ 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; + Link *linkPtr = clientData; + int changed; + size_t valueLength; + const char *value; + 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) { - if (flags & TCL_INTERP_DESTROYED) { + if (Tcl_InterpDeleted(interp)) { Tcl_DecrRefCount(linkPtr->varName); - ckfree((char *) linkPtr); + ckfree(linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName), + Tcl_TraceVar2(interp, Tcl_GetString(linkPtr->varName), NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES - |TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); + |TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); } return NULL; } /* - * 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) { @@ -270,27 +311,56 @@ 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; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) + case TCL_LINK_LONG: + changed = (LinkedVar(long) != linkPtr->lastValue.l); + break; + case TCL_LINK_ULONG: + changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); + break; +#endif + case TCL_LINK_FLOAT: + changed = (LinkedVar(float) != linkPtr->lastValue.f); break; case TCL_LINK_STRING: changed = 1; break; default: - return "internal error: bad linked variable type"; + return (char *) "internal error: bad linked variable type"; } if (changed) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), @@ -300,98 +370,192 @@ LinkTraceProc(clientData, interp, name1, name2, flags) } /* - * 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) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return "linked variable is read-only"; + return (char *) "linked variable is read-only"; } valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY); if (valueObj == NULL) { /* * 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; + return (char *) "internal error: linked variable couldn't be read"; + } switch (linkPtr->type) { case TCL_LINK_INT: - if (Tcl_GetIntFromObj(interp, valueObj, &linkPtr->lastValue.i) - != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); + if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK + && GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - result = "variable must have integer value"; - goto end; + return (char *) "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) - != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); + if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK + && GetInvalidWideFromObj(valueObj, &linkPtr->lastValue.w) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - result = "variable must have integer value"; - goto end; + return (char *) "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) - != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); + if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) { +#ifdef ACCEPT_NAN + if (valueObj->typePtr != &tclDoubleType) { +#endif + if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have real value"; + } +#ifdef ACCEPT_NAN + } + linkPtr->lastValue.d = valueObj->internalRep.doubleValue; +#endif + } + LinkedVar(double) = linkPtr->lastValue.d; + break; + + case TCL_LINK_BOOLEAN: + if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - result = "variable must have real value"; - goto end; + return (char *) "variable must have boolean value"; } - *(double *)(linkPtr->addr) = linkPtr->lastValue.d; + LinkedVar(int) = linkPtr->lastValue.i; break; - case TCL_LINK_BOOLEAN: - if (Tcl_GetBooleanFromObj(interp, valueObj, &linkPtr->lastValue.i) - != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); + case TCL_LINK_CHAR: + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) + || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - result = "variable must have boolean value"; - goto end; + return (char *) "variable must have char value"; } - *(int *)(linkPtr->addr) = linkPtr->lastValue.i; + LinkedVar(char) = linkPtr->lastValue.c = (char)valueInt; break; - case TCL_LINK_STRING: - value = Tcl_GetStringFromObj(valueObj, &valueLength); - valueLength++; - pp = (char **)(linkPtr->addr); - if (*pp != NULL) { - ckfree(*pp); + case TCL_LINK_UCHAR: + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) + || valueInt < 0 || valueInt > UCHAR_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned char value"; + } + LinkedVar(unsigned char) = linkPtr->lastValue.uc = (unsigned char) valueInt; + break; + + case TCL_LINK_SHORT: + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) + || valueInt < SHRT_MIN || valueInt > SHRT_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have short value"; + } + LinkedVar(short) = linkPtr->lastValue.s = (short)valueInt; + break; + + case TCL_LINK_USHORT: + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) + || valueInt < 0 || valueInt > USHRT_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned short value"; + } + LinkedVar(unsigned short) = linkPtr->lastValue.us = (unsigned short)valueInt; + break; + + case TCL_LINK_UINT: + if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) + || valueWide < 0 || valueWide > UINT_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned int value"; + } + LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide; + break; + +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) + case TCL_LINK_LONG: + if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) + || valueWide < LONG_MIN || valueWide > LONG_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have long value"; } - *pp = (char *) ckalloc((unsigned) valueLength); - memcpy(*pp, value, (unsigned) valueLength); + LinkedVar(long) = linkPtr->lastValue.l = (long)valueWide; + break; + + case TCL_LINK_ULONG: + if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) + || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned long value"; + } + LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide; + break; +#endif + + case TCL_LINK_WIDE_UINT: + /* + * FIXME: represent as a bignum. + */ + if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned wide int value"; + } + LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide; + break; + + case TCL_LINK_FLOAT: + if ((Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK + && GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK) + || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have float value"; + } + LinkedVar(float) = linkPtr->lastValue.f = (float)valueDouble; + break; + + case TCL_LINK_STRING: + value = TclGetString(valueObj); + valueLength = valueObj->length + 1; + pp = (char **) linkPtr->addr; + + *pp = ckrealloc(*pp, valueLength); + memcpy(*pp, value, valueLength); break; default: - return "internal error: bad linked variable type"; + return (char *) "internal error: bad linked variable type"; } - end: - Tcl_DecrRefCount(objPtr); - return result; + return NULL; } /* @@ -399,12 +563,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. @@ -413,36 +577,182 @@ 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); - return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0); + linkPtr->lastValue.i = LinkedVar(int); + return Tcl_NewBooleanObj(linkPtr->lastValue.i); + case TCL_LINK_CHAR: + linkPtr->lastValue.c = LinkedVar(char); + return Tcl_NewIntObj(linkPtr->lastValue.c); + case TCL_LINK_UCHAR: + linkPtr->lastValue.uc = LinkedVar(unsigned char); + return Tcl_NewIntObj(linkPtr->lastValue.uc); + case TCL_LINK_SHORT: + linkPtr->lastValue.s = LinkedVar(short); + return Tcl_NewIntObj(linkPtr->lastValue.s); + case TCL_LINK_USHORT: + linkPtr->lastValue.us = LinkedVar(unsigned short); + return Tcl_NewIntObj(linkPtr->lastValue.us); + case TCL_LINK_UINT: + linkPtr->lastValue.ui = LinkedVar(unsigned int); + return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui); +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) + case TCL_LINK_LONG: + linkPtr->lastValue.l = LinkedVar(long); + return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l); + case TCL_LINK_ULONG: + linkPtr->lastValue.ul = LinkedVar(unsigned long); + return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul); +#endif + case TCL_LINK_FLOAT: + linkPtr->lastValue.f = LinkedVar(float); + return Tcl_NewDoubleObj(linkPtr->lastValue.f); + case TCL_LINK_WIDE_UINT: + linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); + /* + * FIXME: represent as a bignum. + */ + return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw); case TCL_LINK_STRING: - p = *(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; + } +} + +static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); + +static Tcl_ObjType invalidRealType = { + "invalidReal", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetInvalidRealFromAny /* setFromAnyProc */ +}; + +static int +SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { + const char *str; + const char *endPtr; + + str = TclGetString(objPtr); + if ((objPtr->length == 1) && (str[0] == '.')){ + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = 0.0; + return TCL_OK; + } + if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->length, &endPtr, + TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { + /* If number is followed by [eE][+-]?, then it is an invalid + * double, but it could be the start of a valid double. */ + if (*endPtr == 'e' || *endPtr == 'E') { + ++endPtr; + if (*endPtr == '+' || *endPtr == '-') ++endPtr; + if (*endPtr == 0) { + double doubleValue = 0.0; + Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); + TclFreeIntRep(objPtr); + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = doubleValue; + return TCL_OK; + } + } } + return TCL_ERROR; } + + +/* + * This function checks for integer representations, which are valid + * when linking with C variables, but which are invalid in other + * contexts in Tcl. Handled are "+", "-", "", "0x", "0b" and "0o" + * (upperand lowercase). See bug [39f6304c2e]. + */ +int +GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr) +{ + const char *str = TclGetString(objPtr); + + if ((objPtr->length == 0) || + ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1]))) { + *intPtr = 0; + return TCL_OK; + } else if ((objPtr->length == 1) && strchr("+-", str[0])) { + *intPtr = (str[0] == '+'); + return TCL_OK; + } + return TCL_ERROR; +} + +int +GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr) +{ + int intValue; + + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return TCL_ERROR; + } + *widePtr = intValue; + return TCL_OK; +} + +/* + * This function checks for double representations, which are valid + * when linking with C variables, but which are invalid in other + * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o" + * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e]. + */ +int +GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr) +{ + int intValue; + + if (objPtr->typePtr == &invalidRealType) { + goto gotdouble; + } + if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) { + *doublePtr = (double) intValue; + return TCL_OK; + } + if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) { + gotdouble: + *doublePtr = objPtr->internalRep.doubleValue; + return TCL_OK; + } + return TCL_ERROR; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |