Index: doc/LinkVar.3 ================================================================== --- doc/LinkVar.3 +++ doc/LinkVar.3 @@ -7,39 +7,64 @@ '\" .TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable +Tcl_LinkArray, Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_LinkVar\fR(\fIinterp, varName, addr, type\fR) +.sp +.VS "TIP 312" +int +\fBTcl_LinkArray\fR(\fIinterp, varName, addr, type, size\fR) +.VE "TIP 312" .sp \fBTcl_UnlinkVar\fR(\fIinterp, varName\fR) .sp \fBTcl_UpdateLinkedVar\fR(\fIinterp, varName\fR) .SH ARGUMENTS -.AS Tcl_Interp writable +.AS Tcl_Interp varName in .AP Tcl_Interp *interp in Interpreter that contains \fIvarName\fR. Also used by \fBTcl_LinkVar\fR to return error messages. .AP "const char" *varName in Name of global variable. -.AP char *addr in +.AP void *addr in Address of C variable that is to be linked to \fIvarName\fR. +.sp +.VS "TIP 312" +In \fBTcl_LinkArray\fR, may be NULL to tell Tcl to create the storage +for the array in the variable. +.VE "TIP 312" .AP int type in -Type of C variable. Must be one of \fBTCL_LINK_INT\fR, +Type of C variable for \fBTcl_LinkVar\fR or type of array element for +\fBTcl_LinkArray\fR. Must be one of \fBTCL_LINK_INT\fR, \fBTCL_LINK_UINT\fR, \fBTCL_LINK_CHAR\fR, \fBTCL_LINK_UCHAR\fR, \fBTCL_LINK_SHORT\fR, \fBTCL_LINK_USHORT\fR, \fBTCL_LINK_LONG\fR, \fBTCL_LINK_ULONG\fR, \fBTCL_LINK_WIDE_INT\fR, -\fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR, -\fBTCL_LINK_DOUBLE\fR, \fBTCL_LINK_BOOLEAN\fR, or -\fBTCL_LINK_STRING\fR, optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR -to make Tcl variable read-only. +\fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR, \fBTCL_LINK_DOUBLE\fR, +\fBTCL_LINK_BOOLEAN\fR, or one of the extra ones listed below. +.sp +In \fBTcl_LinkVar\fR, the additional linked type \fBTCL_LINK_STRING\fR may be +used. +.sp +.VS "TIP 312" +In \fBTcl_LinkArray\fR, the additional linked types \fBTCL_LINK_CHARS\fR and +\fBTCL_LINK_BYTES\fR may be used. +.VE "TIP 312" +.sp +All the above for both functions may be +optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR to make the Tcl +variable read-only. +.AP int size in +.VS "TIP 312" +The number of elements in the C array. Must be greater than zero. +.VE "TIP 312" .BE .SH DESCRIPTION .PP \fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable named by \fIvarName\fR in sync with the C variable at the address @@ -49,124 +74,172 @@ variable will be updated to have the same value. \fBTcl_LinkVar\fR normally returns \fBTCL_OK\fR; if an error occurs while setting up the link (e.g. because \fIvarName\fR is the name of array) then \fBTCL_ERROR\fR is returned and the interpreter's result contains an error message. +.PP +.VS "TIP 312" +\fBTcl_LinkArray\fR is similar, but for arrays of fixed size (given by +the \fIsize\fR argument). When asked to allocate the backing C array +storage (via the \fIaddr\fR argument being NULL), it writes the +address that it allocated to the Tcl interpreter result. +.VE "TIP 312" .PP The \fItype\fR argument specifies the type of the C variable, +or the type of the elements of the C array, and must have one of the following values, optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR: .TP \fBTCL_LINK_INT\fR -The C variable is of type \fBint\fR. +. +The C variable, or each element of the C array, is of type \fBint\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_UINT\fR -The C variable is of type \fBunsigned int\fR. +. +The C variable, or each element of the C array, is of type \fBunsigned int\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the platform's defined range for the \fBunsigned int\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_CHAR\fR -The C variable is of type \fBchar\fR. +. +The C variable, or each element of the C array, is of type \fBchar\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the \fBchar\fR datatype; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. +.RS +.PP +.VS "TIP 312" +If using an array of these, consider using \fBTCL_LINK_CHARS\fR instead. +.VE "TIP 312" +.RE +.TP +\fBTCL_LINK_CHARS\fR +.VS "TIP 312" +The C array is of type \fBchar *\fR and is mapped into Tcl as a string. +Any value written into the Tcl variable must have the same length as +the underlying storage. Only supported with \fBTcl_LinkArray\fR. +.VE "TIP 312" .TP \fBTCL_LINK_UCHAR\fR -The C variable is of type \fBunsigned char\fR. +. +The C variable, or each element of the C array, is of type \fBunsigned char\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetIntFromObj\fR and in the platform's defined range for the \fBunsigned char\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. +.RS +.PP +.VS "TIP 312" +If using an array of these, consider using \fBTCL_LINK_BYTES\fR instead. +.VE "TIP 312" +.RE +.TP +\fBTCL_LINK_BYTES\fR +.VS "TIP 312" +The C array is of type \fBunsigned char *\fR and is mapped into Tcl +as a bytearray. +Any value written into the Tcl variable must have the same length as +the underlying storage. Only supported with \fBTcl_LinkArray\fR. +.VE "TIP 312" .TP \fBTCL_LINK_SHORT\fR -The C variable is of type \fBshort\fR. +. +The C variable, or each element of the C array, is of type \fBshort\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the \fBshort\fR datatype; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_USHORT\fR -The C variable is of type \fBunsigned short\fR. +. +The C variable, or each element of the C array, is of type \fBunsigned short\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetIntFromObj\fR and in the platform's defined range for the \fBunsigned short\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_LONG\fR -The C variable is of type \fBlong\fR. +. +The C variable, or each element of the C array, is of type \fBlong\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetLongFromObj\fR; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_ULONG\fR -The C variable is of type \fBunsigned long\fR. +. +The C variable, or each element of the C array, is of type \fBunsigned long\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the platform's defined range for the \fBunsigned long\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_DOUBLE\fR -The C variable is of type \fBdouble\fR. +. +The C variable, or each element of the C array, is of type \fBdouble\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR; attempts to write non-real values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer or real representations (like the empty string, '.', '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_FLOAT\fR -The C variable is of type \fBfloat\fR. +. +The C variable, or each element of the C array, is of type \fBfloat\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR and must be within the range acceptable for a \fBfloat\fR; attempts to write non-real values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer or real representations (like the empty string, '.', '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_WIDE_INT\fR -The C variable is of type \fBTcl_WideInt\fR (which is an integer type +. +The C variable, or each element of the C array, is of type \fBTcl_WideInt\fR +(which is an integer type at least 64-bits wide on all platforms that can support it.) Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetWideIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_WIDE_UINT\fR -The C variable is of type \fBTcl_WideUInt\fR (which is an unsigned -integer type at least 64-bits wide on all platforms that can support -it.) +. +The C variable, or each element of the C array, is of type \fBTcl_WideUInt\fR +(which is an unsigned integer type at least 64-bits wide on all platforms that +can support it.) Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR (it will be cast to unsigned); .\" FIXME! Use bignums instead. attempts to write non-integer values into \fIvarName\fR will be @@ -173,11 +246,12 @@ rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_BOOLEAN\fR -The C variable is of type \fBint\fR. +. +The C variable, or each element of the C array, is of type \fBint\fR. If its value is zero then it will read from Tcl as .QW 0 ; otherwise it will read from Tcl as .QW 1 . Whenever \fIvarName\fR is @@ -186,19 +260,21 @@ form acceptable to \fBTcl_GetBooleanFromObj\fR; attempts to write non-boolean values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_STRING\fR +. The C variable is of type \fBchar *\fR. If its value is not NULL then it must be a pointer to a string allocated with \fBTcl_Alloc\fR or \fBckalloc\fR. Whenever the Tcl variable is modified the current C string will be freed and new memory will be allocated to hold a copy of the variable's new value. If the C variable contains a NULL pointer then the Tcl variable will read as .QW NULL . +This is only supported by \fBTcl_LinkVar\fR. .PP If the \fBTCL_LINK_READ_ONLY\fR flag is present in \fItype\fR then the variable will be read-only from Tcl, so that its value can only be changed by modifying the C variable. Attempts to write the variable from Tcl will be rejected with errors. Index: generic/tcl.decls ================================================================== --- generic/tcl.decls +++ generic/tcl.decls @@ -665,11 +665,11 @@ declare 186 { char *Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr) } declare 187 { - int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, char *addr, + int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr, int type) } # This slot is reserved for use by the plus patch: # declare 188 { @@ -2376,10 +2376,16 @@ } declare 643 { int Tcl_IsShared(Tcl_Obj *objPtr) } + +# TIP#312 New Tcl_LinkArray() function +declare 644 { + int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr, + int type, int size) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## Index: generic/tcl.h ================================================================== --- generic/tcl.h +++ generic/tcl.h @@ -1091,10 +1091,12 @@ #define TCL_LINK_LONG 11 #define TCL_LINK_ULONG 12 #endif #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 /* *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. Index: generic/tclDecls.h ================================================================== --- generic/tclDecls.h +++ generic/tclDecls.h @@ -595,11 +595,11 @@ /* 186 */ EXTERN char * Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, - char *addr, int type); + void *addr, int type); /* Slot 188 is reserved */ /* 189 */ EXTERN Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode); /* 190 */ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp); @@ -1895,10 +1895,14 @@ EXTERN void Tcl_IncrRefCount(Tcl_Obj *objPtr); /* 642 */ EXTERN void Tcl_DecrRefCount(Tcl_Obj *objPtr); /* 643 */ EXTERN int Tcl_IsShared(Tcl_Obj *objPtr); +/* 644 */ +EXTERN int Tcl_LinkArray(Tcl_Interp *interp, + const char *varName, void *addr, int type, + int size); typedef struct { const struct TclPlatStubs *tclPlatStubs; const struct TclIntStubs *tclIntStubs; const struct TclIntPlatStubs *tclIntPlatStubs; @@ -2117,11 +2121,11 @@ int (*tcl_InputBlocked) (Tcl_Channel chan); /* 182 */ int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */ int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */ int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */ char * (*tcl_JoinPath) (int argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */ - int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, char *addr, int type); /* 187 */ + int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, void *addr, int type); /* 187 */ void (*reserved188)(void); Tcl_Channel (*tcl_MakeFileChannel) (ClientData handle, int mode); /* 189 */ int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ Tcl_Channel (*tcl_MakeTcpClientChannel) (ClientData tcpSocket); /* 191 */ char * (*tcl_Merge) (int argc, const char *const *argv); /* 192 */ @@ -2574,10 +2578,11 @@ void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */ int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */ void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */ void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */ int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */ + int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, int size); /* 644 */ } TclStubs; extern const TclStubs *tclStubsPtr; #ifdef __cplusplus @@ -3892,10 +3897,12 @@ (tclStubsPtr->tcl_IncrRefCount) /* 641 */ #define Tcl_DecrRefCount \ (tclStubsPtr->tcl_DecrRefCount) /* 642 */ #define Tcl_IsShared \ (tclStubsPtr->tcl_IsShared) /* 643 */ +#define Tcl_LinkArray \ + (tclStubsPtr->tcl_LinkArray) /* 644 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -4510,10 +4510,35 @@ *---------------------------------------------------------------- */ #define TclHasStringRep(objPtr) ((objPtr)->bytes != NULL) +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to get the bignum out of the bignum + * representation of a Tcl_Obj. + * The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE void TclUnpackBignum(Tcl_Obj *objPtr, mp_int bignum); + *---------------------------------------------------------------- + */ + +#define TclUnpackBignum(objPtr, bignum) \ + do { \ + register Tcl_Obj *bignumObj = (objPtr); \ + register int bignumPayload = \ + PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \ + if (bignumPayload == -1) { \ + (bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \ + } else { \ + (bignum).dp = bignumObj->internalRep.twoPtrValue.ptr1; \ + (bignum).sign = bignumPayload >> 30; \ + (bignum).alloc = (bignumPayload >> 15) & 0x7fff; \ + (bignum).used = bignumPayload & 0x7fff; \ + } \ + } while (0) + /* *---------------------------------------------------------------- * Macros used by the Tcl core to grow Tcl_Token arrays. They use the same * growth algorithm as used in tclStringObj.c for growing strings. The ANSI C * "prototype" for this macro is: Index: generic/tclLink.c ================================================================== --- generic/tclLink.c +++ generic/tclLink.c @@ -6,16 +6,20 @@ * 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. + * Copyright (c) 2008 Rene Zaumseil + * Copyright (c) 2019 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" +#include "tommath.h" +#include /* * 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. @@ -25,11 +29,16 @@ 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. */ - char *addr; /* Location of C variable. */ + void *addr; /* Location of C variable. */ + int bytes; /* Size of C variable array. This is 0 when + * single variables, and >0 used for array + * variables. */ + int numElems; /* Number of elements in C variable array. + * Zero for single variables. */ int type; /* Type of link (TCL_LINK_INT, etc.). */ union { char c; unsigned char uc; int i; @@ -42,10 +51,23 @@ #endif Tcl_WideInt w; Tcl_WideUInt uw; float f; double d; + void *aryPtr; /* Generic array. */ + char *cPtr; /* char array */ + unsigned char *ucPtr; /* unsigned char array */ + short *sPtr; /* short array */ + unsigned short *usPtr; /* unsigned short array */ + int *iPtr; /* int array */ + unsigned int *uiPtr; /* unsigned int array */ + long *lPtr; /* long array */ + unsigned long *ulPtr; /* unsigned long array */ + Tcl_WideInt *wPtr; /* wide (long long) array */ + Tcl_WideUInt *uwPtr; /* unsigned wide (long long) array */ + float *fPtr; /* float array */ + double *dPtr; /* double array */ } lastValue; /* Last known value of C variable; used to * avoid string conversions. */ int flags; /* Miscellaneous one-bit values; see below for * definitions. */ } Link; @@ -55,25 +77,46 @@ * 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_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: */ static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); +static void LinkFree(Link *linkPtr); static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr); -static int GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr); -static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr); +static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, + double *doublePtr); +static int SetInvalidRealFromAny(Tcl_Interp *interp, + Tcl_Obj *objPtr); + +/* + * A marker type used to flag weirdnesses so we can pass them around right. + */ + +static Tcl_ObjType invalidRealType = { + "invalidReal", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; /* * 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 @@ -106,11 +149,11 @@ int 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 + void *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; @@ -142,23 +185,190 @@ if (type & TCL_LINK_READ_ONLY) { linkPtr->flags = LINK_READ_ONLY; } else { linkPtr->flags = 0; } + linkPtr->bytes = 0; + linkPtr->numElems = 0; + 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_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); + 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. */ + void *addr, /* Address of a C variable to be linked to + * varName. If NULL then the necessary space + * will be allocated and returned as the + * interpreter result. */ + int type, /* Type of C variable: TCL_LINK_INT, etc. Also + * may have TCL_LINK_READ_ONLY OR'ed in. */ + int size) /* Size of C variable array, >1 if array */ +{ + Tcl_Obj *objPtr; + Link *linkPtr; + int code; + + if (size < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong array size given", -1)); + return TCL_ERROR; + } + + linkPtr = ckalloc(sizeof(Link)); + linkPtr->type = type & ~TCL_LINK_READ_ONLY; + linkPtr->numElems = size; + 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; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) + case TCL_LINK_LONG: + linkPtr->bytes = size * sizeof(long); + break; + case TCL_LINK_ULONG: + linkPtr->bytes = size * sizeof(unsigned long); + break; +#endif + 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.aryPtr = ckalloc(linkPtr->bytes); + linkPtr->flags |= LINK_ALLOC_LAST; + addr = (char *) &linkPtr->lastValue.cPtr; + } + break; + case TCL_LINK_CHARS: + case TCL_LINK_BINARY: + linkPtr->bytes = size * sizeof(char); + break; + default: + LinkFree(linkPtr); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad linked array variable type", -1)); + 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.aryPtr = 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); - ckfree(linkPtr); + LinkFree(linkPtr); return TCL_ERROR; } + code = Tcl_TraceVar2(interp, varName, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); if (code != TCL_OK) { Tcl_DecrRefCount(linkPtr->varName); - ckfree(linkPtr); + LinkFree(linkPtr); + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj((int) linkPtr->addr)); } return code; } /* @@ -192,11 +402,11 @@ } Tcl_UntraceVar2(interp, varName, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); Tcl_DecrRefCount(linkPtr->varName); - ckfree(linkPtr); + LinkFree(linkPtr); } /* *---------------------------------------------------------------------- * @@ -243,10 +453,245 @@ } /* *---------------------------------------------------------------------- * + * GetInt, GetWide, GetUWide, GetDouble, EqualDouble, IsSpecial -- + * + * Helper functions for LinkTraceProc and ObjValue. These are all + * factored out here to make those functions simpler. + * + *---------------------------------------------------------------------- + */ + +static inline int +GetInt( + Tcl_Obj *objPtr, + int *intPtr) +{ + return (Tcl_GetIntFromObj(NULL, objPtr, intPtr) != TCL_OK + && GetInvalidIntFromObj(objPtr, intPtr) != TCL_OK); +} + +static inline int +GetWide( + Tcl_Obj *objPtr, + Tcl_WideInt *widePtr) +{ + if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) { + int intValue; + + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return 1; + } + *widePtr = intValue; + } + return 0; +} + +static inline int +GetUWide( + Tcl_Obj *objPtr, + Tcl_WideUInt *uwidePtr) +{ + Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr; + ClientData clientData; + int type, intValue; + + if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { + if (type == TCL_NUMBER_INT) { + *widePtr = *((const Tcl_WideInt *) clientData); + return (*widePtr < 0); + } else if (type == TCL_NUMBER_BIG) { + mp_int *numPtr = clientData; + Tcl_WideUInt value = 0; + union { + Tcl_WideUInt value; + unsigned char bytes[sizeof(Tcl_WideUInt)]; + } scratch; + unsigned long numBytes = sizeof(Tcl_WideUInt); + unsigned char *bytes = scratch.bytes; + + if (numPtr->sign || (MP_OKAY != mp_to_unsigned_bin_n(numPtr, + bytes, &numBytes))) { + /* + * If the sign bit is set (a negative value) or if the value + * can't possibly fit in the bits of an unsigned wide, there's + * no point in doing further conversion. + */ + return 1; + } +#ifdef WORDS_BIGENDIAN + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } +#else /* !WORDS_BIGENDIAN */ + /* + * Little-endian can read the value directly. + */ + value = scratch.value; +#endif /* WORDS_BIGENDIAN */ + *uwidePtr = value; + return 0; + } + } + + /* + * Evil edge case fallback. + */ + + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return 1; + } + *uwidePtr = intValue; + return 0; +} + +static inline int +GetDouble( + Tcl_Obj *objPtr, + double *dblPtr) +{ + if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) { + return 0; + } else { +#ifdef ACCEPT_NAN + Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &tclDoubleType); + + if (irPtr != NULL) { + *dblPtr = irPtr->doubleValue; + return 0; + } +#endif /* ACCEPT_NAN */ + return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK; + } +} + +static inline int +EqualDouble( + double a, + double b) +{ + return (a == b) +#ifdef ACCEPT_NAN + || (TclIsNaN(a) && TclIsNaN(b)) +#endif /* ACCEPT_NAN */ + ; +} + +static inline int +IsSpecial( + double a) +{ + return TclIsInfinite(a) +#ifdef ACCEPT_NAN + || TclIsNaN(a) +#endif /* ACCEPT_NAN */ + ; +} + +/* + * Mark an object as holding a weird double. + */ + +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", "0d" and "0o" + * (upperand lowercase). See bug [39f6304c2e]. + */ + +static int +GetInvalidIntFromObj( + Tcl_Obj *objPtr, + int *intPtr) +{ + const char *str = TclGetString(objPtr); + + if ((objPtr->length == 0) || ((objPtr->length == 2) && (str[0] == '0') + && strchr("xXbBoOdD", str[1]))) { + *intPtr = 0; + return TCL_OK; + } else if ((objPtr->length == 1) && strchr("+-", str[0])) { + *intPtr = (str[0] == '+'); + return TCL_OK; + } + return TCL_ERROR; +} + +/* + * 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]. + */ + +static int +GetInvalidDoubleFromObj( + Tcl_Obj *objPtr, + double *doublePtr) +{ + int intValue; + + if (TclHasIntRep(objPtr, &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; +} + +/* + *---------------------------------------------------------------------- + * * LinkTraceProc -- * * 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. @@ -271,27 +716,31 @@ const char *name2, /* Second part of variable name. */ int flags) /* Miscellaneous additional information. */ { Link *linkPtr = clientData; int changed; - size_t valueLength; + int valueLength; const char *value; char **pp; Tcl_Obj *valueObj; int valueInt; Tcl_WideInt valueWide; + Tcl_WideUInt valueUWide; double valueDouble; + int objc; + Tcl_Obj **objv; + int i; /* * 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 (Tcl_InterpDeleted(interp)) { Tcl_DecrRefCount(linkPtr->varName); - ckfree(linkPtr); + LinkFree(linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); Tcl_TraceVar2(interp, Tcl_GetString(linkPtr->varName), NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES @@ -314,55 +763,68 @@ * 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 = (LinkedVar(int) != linkPtr->lastValue.i); - break; - case TCL_LINK_DOUBLE: - changed = (LinkedVar(double) != linkPtr->lastValue.d); - break; - case TCL_LINK_WIDE_INT: - changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w); - break; - case TCL_LINK_WIDE_UINT: - changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw); - break; - case TCL_LINK_CHAR: - changed = (LinkedVar(char) != linkPtr->lastValue.c); - break; - case TCL_LINK_UCHAR: - changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc); - break; - case TCL_LINK_SHORT: - changed = (LinkedVar(short) != linkPtr->lastValue.s); - break; - case TCL_LINK_USHORT: - changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us); - break; - case TCL_LINK_UINT: - changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); - break; + /* + * Variable arrays + */ + + if (linkPtr->flags & LINK_ALLOC_LAST) { + changed = memcmp(linkPtr->addr, linkPtr->lastValue.aryPtr, + linkPtr->bytes); + } else { + /* single variables */ + switch (linkPtr->type) { + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + changed = (LinkedVar(int) != linkPtr->lastValue.i); + break; + case TCL_LINK_DOUBLE: + changed = !EqualDouble(LinkedVar(double), linkPtr->lastValue.d); + break; + case TCL_LINK_WIDE_INT: + changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w); + break; + case TCL_LINK_WIDE_UINT: + changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw); + break; + case TCL_LINK_CHAR: + changed = (LinkedVar(char) != linkPtr->lastValue.c); + break; + case TCL_LINK_UCHAR: + changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc); + break; + case TCL_LINK_SHORT: + changed = (LinkedVar(short) != linkPtr->lastValue.s); + break; + case TCL_LINK_USHORT: + changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us); + break; + case TCL_LINK_UINT: + changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); + break; #if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) - case TCL_LINK_LONG: - changed = (LinkedVar(long) != linkPtr->lastValue.l); - break; - case TCL_LINK_ULONG: - changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); - break; + case TCL_LINK_LONG: + changed = (LinkedVar(long) != linkPtr->lastValue.l); + break; + case TCL_LINK_ULONG: + changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); + break; #endif - case TCL_LINK_FLOAT: - changed = (LinkedVar(float) != linkPtr->lastValue.f); - break; - case TCL_LINK_STRING: - changed = 1; - break; - default: - return (char *) "internal error: bad linked variable type"; + case TCL_LINK_FLOAT: + changed = !EqualDouble(LinkedVar(float), linkPtr->lastValue.f); + break; + case TCL_LINK_STRING: + case TCL_LINK_CHARS: + case TCL_LINK_BINARY: + changed = 1; + break; + default: + changed = 0; + /* return (char *) "internal error: bad linked variable type"; */ + } } if (changed) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); } @@ -390,174 +852,381 @@ */ return (char *) "internal error: linked variable couldn't be read"; } - switch (linkPtr->type) { - case TCL_LINK_INT: - if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK - && GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have integer value"; - } - LinkedVar(int) = linkPtr->lastValue.i; - break; - - case TCL_LINK_WIDE_INT: - 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); - return (char *) "variable must have integer value"; - } - LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w; - break; - - case TCL_LINK_DOUBLE: - if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) { -#ifdef ACCEPT_NAN - Tcl_ObjIntRep *irPtr = TclFetchIntRep(valueObj, &tclDoubleType); - if (irPtr == NULL) { -#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 = irPtr->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); - return (char *) "variable must have boolean value"; - } - LinkedVar(int) = linkPtr->lastValue.i; - break; - - 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); - return (char *) "variable must have char value"; - } - LinkedVar(char) = linkPtr->lastValue.c = (char)valueInt; - break; - - case TCL_LINK_UCHAR: - if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK - && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) - || valueInt < 0 || valueInt > UCHAR_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned char value"; - } - 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"; - } - 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; - + /* + * Special cases. + */ + + switch (linkPtr->type) { case TCL_LINK_STRING: value = TclGetString(valueObj); valueLength = valueObj->length + 1; pp = (char **) linkPtr->addr; *pp = ckrealloc(*pp, valueLength); memcpy(*pp, value, valueLength); + return NULL; + + case TCL_LINK_CHARS: + value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength); + valueLength++; /* include end of string char */ + if (valueLength > linkPtr->bytes) { + return (char *) "wrong size of char* value"; + } + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength); + memcpy(linkPtr->addr, value, (size_t) valueLength); + } else { + linkPtr->lastValue.c = '\0'; + LinkedVar(char) = linkPtr->lastValue.c; + } + return NULL; + + case TCL_LINK_BINARY: + value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength); + if (valueLength != linkPtr->bytes) { + return (char *) "wrong size of binary value"; + } + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength); + memcpy(linkPtr->addr, value, (size_t) valueLength); + } else { + linkPtr->lastValue.uc = (unsigned char) *value; + LinkedVar(unsigned char) = linkPtr->lastValue.uc; + } + return NULL; + } + + /* + * A helper macro. Writing this as a function is messy because of type + * variance. + */ + +#define InRange(lowerLimit, value, upperLimit) \ + ((value) >= (lowerLimit) && (value) <= (upperLimit)) + + /* + * If we're working with an array of numbers, extract the Tcl list. + */ + + if (linkPtr->flags & LINK_ALLOC_LAST) { + if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR + || objc != linkPtr->numElems) { + return (char *) "wrong dimension"; + } + } + + switch (linkPtr->type) { + case TCL_LINK_INT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + int *varPtr = &linkPtr->lastValue.iPtr[i]; + + if (GetInt(objv[i], varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have integer values"; + } + } + } else { + int *varPtr = &linkPtr->lastValue.i; + + if (GetInt(valueObj, varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have integer value"; + } + LinkedVar(int) = *varPtr; + } + break; + + case TCL_LINK_WIDE_INT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + Tcl_WideInt *varPtr = &linkPtr->lastValue.wPtr[i]; + + if (GetWide(objv[i], varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have wide integer value"; + } + } + } else { + Tcl_WideInt *varPtr = &linkPtr->lastValue.w; + + if (GetWide(valueObj, varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have wide integer value"; + } + LinkedVar(Tcl_WideInt) = *varPtr; + } + break; + + case TCL_LINK_DOUBLE: + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetDouble(objv[i], &linkPtr->lastValue.dPtr[i])) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have real value"; + } + } + } else { + double *varPtr = &linkPtr->lastValue.d; + + if (GetDouble(valueObj, varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have real value"; + } + LinkedVar(double) = *varPtr; + } + break; + + case TCL_LINK_BOOLEAN: + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + int *varPtr = &linkPtr->lastValue.iPtr[i]; + + if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have boolean value"; + } + } + } else { + int *varPtr = &linkPtr->lastValue.i; + + if (Tcl_GetBooleanFromObj(NULL, valueObj, varPtr) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have boolean value"; + } + LinkedVar(int) = *varPtr; + } + break; + + case TCL_LINK_CHAR: + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have char value"; + } + linkPtr->lastValue.cPtr[i] = (char) valueInt; + } + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have char value"; + } + LinkedVar(char) = linkPtr->lastValue.c = (char) valueInt; + } + break; + + case TCL_LINK_UCHAR: + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(0, valueInt, UCHAR_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned char value"; + } + linkPtr->lastValue.ucPtr[i] = (unsigned char) valueInt; + } + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(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 (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have short value"; + } + linkPtr->lastValue.sPtr[i] = (short) valueInt; + } + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(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 (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(0, valueInt, USHRT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned short value"; + } + linkPtr->lastValue.usPtr[i] = (unsigned short) valueInt; + } + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(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 (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetWide(objv[i], &valueWide) + || !InRange(0, valueWide, UINT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned int value"; + } + linkPtr->lastValue.uiPtr[i] = (unsigned int) valueWide; + } + } else { + if (GetWide(valueObj, &valueWide) + || !InRange(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 (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetWide(objv[i], &valueWide) + || !InRange(LONG_MIN, valueWide, LONG_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have long value"; + } + linkPtr->lastValue.lPtr[i] = (long) valueWide; + } + } else { + if (GetWide(valueObj, &valueWide) + || !InRange(LONG_MIN, valueWide, LONG_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have long value"; + } + LinkedVar(long) = linkPtr->lastValue.l = (long) valueWide; + } + break; + + case TCL_LINK_ULONG: + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetUWide(objv[i], &valueUWide) + || !InRange(0, valueUWide, ULONG_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned long value"; + } + linkPtr->lastValue.ulPtr[i] = (unsigned long) valueUWide; + } + } else { + if (GetUWide(valueObj, &valueUWide) + || !InRange(0, valueUWide, 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) valueUWide; + } + break; +#endif + + case TCL_LINK_WIDE_UINT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetUWide(objv[i], &valueUWide)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned wide int value"; + } + linkPtr->lastValue.uwPtr[i] = valueUWide; + } + } else { + if (GetUWide(valueObj, &valueUWide)) { + 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 = valueUWide; + } + break; + + case TCL_LINK_FLOAT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetDouble(objv[i], &valueDouble) + && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX) + && !IsSpecial(valueDouble)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have float value"; + } + linkPtr->lastValue.fPtr[i] = (float) valueDouble; + } + } else { + if (GetDouble(valueObj, &valueDouble) + && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX) + && !IsSpecial(valueDouble)) { + 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; default: return (char *) "internal error: bad linked variable type"; } + + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } return NULL; } /* *---------------------------------------------------------------------- @@ -580,65 +1249,214 @@ static Tcl_Obj * ObjValue( Link *linkPtr) /* Structure describing linked variable. */ { char *p; - Tcl_Obj *resultObj; + Tcl_Obj *resultObj, **objv; + int i; switch (linkPtr->type) { case TCL_LINK_INT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.iPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } 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.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.wPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } 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.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.dPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.d = LinkedVar(double); return Tcl_NewDoubleObj(linkPtr->lastValue.d); case TCL_LINK_BOOLEAN: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.iPtr[i] != 0); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.i = LinkedVar(int); return Tcl_NewBooleanObj(linkPtr->lastValue.i); case TCL_LINK_CHAR: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.cPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.c = LinkedVar(char); return Tcl_NewIntObj(linkPtr->lastValue.c); case TCL_LINK_UCHAR: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.ucPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } 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.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.sPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.s = LinkedVar(short); return Tcl_NewIntObj(linkPtr->lastValue.s); case TCL_LINK_USHORT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.usPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } 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.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.uiPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } 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: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.lPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } 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.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.ulPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.ul = LinkedVar(unsigned long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul); #endif case TCL_LINK_FLOAT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.fPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); case TCL_LINK_WIDE_UINT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewWideIntObj((Tcl_WideInt) + linkPtr->lastValue.uwPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); - /* - * FIXME: represent as a bignum. - */ return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw); + case TCL_LINK_STRING: p = LinkedVar(char *); if (p == NULL) { TclNewLiteralStringObj(resultObj, "NULL"); return resultObj; } return Tcl_NewStringObj(p, -1); + case TCL_LINK_CHARS: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + linkPtr->lastValue.cPtr[linkPtr->bytes-1] = '\0'; + /* take care of proper string end */ + return Tcl_NewStringObj(linkPtr->lastValue.cPtr, 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.aryPtr, 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). */ @@ -645,115 +1463,42 @@ default: 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 */ - NULL /* 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", "0d" 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("xXbBoOdD", 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 (TclHasIntRep(objPtr, &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; + +/* + *---------------------------------------------------------------------- + * + * 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.aryPtr); + } + ckfree((char *) linkPtr); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclObj.c ================================================================== --- generic/tclObj.c +++ generic/tclObj.c @@ -189,21 +189,10 @@ (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (bignum).dp; \ (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \ | ((bignum).alloc << 15) | ((bignum).used)); \ } -#define UNPACK_BIGNUM(objPtr, bignum) \ - if ((objPtr)->internalRep.twoPtrValue.ptr2 == INT2PTR(-1)) { \ - (bignum) = *((mp_int *) ((objPtr)->internalRep.twoPtrValue.ptr1)); \ - } else { \ - (bignum).dp = (objPtr)->internalRep.twoPtrValue.ptr1; \ - (bignum).sign = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 30; \ - (bignum).alloc = \ - (PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 15) & 0x7fff; \ - (bignum).used = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) & 0x7fff; \ - } - /* * Prototypes for functions defined later in this file: */ static int ParseBoolean(Tcl_Obj *objPtr); @@ -2515,11 +2504,11 @@ return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { mp_int big; - UNPACK_BIGNUM(objPtr, big); + TclUnpackBignum(objPtr, big); *dblPtr = TclBignumToDouble(&big); return TCL_OK; } } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); return TCL_ERROR; @@ -3031,11 +3020,11 @@ mp_int big; unsigned long scratch, value = 0, numBytes = sizeof(unsigned long); unsigned char *bytes = (unsigned char *) &scratch; - UNPACK_BIGNUM(objPtr, big); + TclUnpackBignum(objPtr, big); if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } if (big.sign) { @@ -3271,11 +3260,11 @@ Tcl_WideUInt value = 0; unsigned long numBytes = sizeof(Tcl_WideInt); Tcl_WideInt scratch; unsigned char *bytes = (unsigned char *) &scratch; - UNPACK_BIGNUM(objPtr, big); + TclUnpackBignum(objPtr, big); if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } if (big.sign) { @@ -3385,11 +3374,11 @@ FreeBignum( Tcl_Obj *objPtr) { mp_int toFree; /* Bignum to free */ - UNPACK_BIGNUM(objPtr, toFree); + TclUnpackBignum(objPtr, toFree); mp_clear(&toFree); if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) { ckfree(objPtr->internalRep.twoPtrValue.ptr1); } objPtr->typePtr = NULL; @@ -3418,11 +3407,11 @@ { mp_int bignumVal; mp_int bignumCopy; copyPtr->typePtr = &tclBignumType; - UNPACK_BIGNUM(srcPtr, bignumVal); + TclUnpackBignum(srcPtr, bignumVal); if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { Tcl_Panic("initialization failure in DupBignum"); } PACK_BIGNUM(bignumCopy, copyPtr); } @@ -3453,11 +3442,11 @@ { mp_int bignumVal; int size; char *stringVal; - UNPACK_BIGNUM(objPtr, bignumVal); + TclUnpackBignum(objPtr, bignumVal); if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) { Tcl_Panic("radix size failure in UpdateStringOfBignum"); } if (size < 2) { /* @@ -3592,14 +3581,14 @@ do { if (objPtr->typePtr == &tclBignumType) { if (copy || Tcl_IsShared(objPtr)) { mp_int temp; - UNPACK_BIGNUM(objPtr, temp); + TclUnpackBignum(objPtr, temp); mp_init_copy(bignumValue, &temp); } else { - UNPACK_BIGNUM(objPtr, *bignumValue); + TclUnpackBignum(objPtr, *bignumValue); /* Optimized TclFreeIntRep */ objPtr->internalRep.twoPtrValue.ptr1 = NULL; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = NULL; /* @@ -3836,11 +3825,11 @@ if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, (int) sizeof(mp_int)); - UNPACK_BIGNUM(objPtr, *bigPtr); + TclUnpackBignum(objPtr, *bigPtr); *typePtr = TCL_NUMBER_BIG; *clientDataPtr = bigPtr; return TCL_OK; } } while (TCL_OK == Index: generic/tclStubInit.c ================================================================== --- generic/tclStubInit.c +++ generic/tclStubInit.c @@ -1626,8 +1626,9 @@ Tcl_StoreIntRep, /* 639 */ Tcl_HasStringRep, /* 640 */ Tcl_IncrRefCount, /* 641 */ Tcl_DecrRefCount, /* 642 */ Tcl_IsShared, /* 643 */ + Tcl_LinkArray, /* 644 */ }; /* !END!: Do not edit above this line. */ Index: generic/tclTest.c ================================================================== --- generic/tclTest.c +++ generic/tclTest.c @@ -306,10 +306,12 @@ int objc, Tcl_Obj *const objv[]); static int TestinterpdeleteCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestlinkCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); +static int TestlinkarrayCmd(void *dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); static int TestlocaleCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestmainthreadCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); @@ -663,10 +665,11 @@ Tcl_CreateObjCommand(interp, "testgetvarfullname", TestgetvarfullnameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, NULL, NULL); Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, @@ -3277,10 +3280,127 @@ "\": should be create, delete, get, set, or update", NULL); return TCL_ERROR; } return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TestlinkarrayCmd -- + * + * This function is invoked to process the "testlinkarray" Tcl command. + * It is used to test the 'Tcl_LinkArray' function. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes, and invokes variable links. + * + *---------------------------------------------------------------------- + */ + +static int +TestlinkarrayCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *LinkOption[] = { + "update", "remove", "create", NULL + }; + enum LinkOption { LINK_UPDATE, LINK_REMOVE, LINK_CREATE }; + static const char *LinkType[] = { + "char", "uchar", "short", "ushort", "int", "uint", "long", "ulong", + "wide", "uwide", "float", "double", "string", "char*", "binary", NULL + }; + /* all values after TCL_LINK_CHARS_ARRAY are used as arrays (see below) */ + static int LinkTypes[] = { + TCL_LINK_CHAR, TCL_LINK_UCHAR, + TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT, + TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT, + TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS, + TCL_LINK_BINARY + }; + int optionIndex, typeIndex, readonly, i, addr, size, length; + char *name, *arg; + + 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