From 344b1355050cb57f8ec7d899a6294048748c0218 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Mar 2018 15:31:38 +0000 Subject: Rebooting a [string insert] implementation branch, bringing over pieces from the past branches and merging against the updated index parsing machinery. --- doc/string.n | 17 +++++++++++ generic/tclCmdMZ.c | 58 +++++++++++++++++++++++++++++++++++ tests/string.test | 89 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 161 insertions(+), 3 deletions(-) diff --git a/doc/string.n b/doc/string.n index 00ce85c..a5b7a29 100644 --- a/doc/string.n +++ b/doc/string.n @@ -89,6 +89,23 @@ If \fIcharIndex\fR is less than 0 or greater than or equal to the length of the string then this command returns an empty string. .RE .TP +\fBstring insert \fIstring index insertString\fR +. +Returns a copy of \fIstring\fR with \fIinsertString\fR inserted at the +\fIindex\fR'th character. \fIindex\fR may be specified as described in the +\fBSTRING INDICES\fR section. +.RS +.PP +If \fIindex\fR is start-relative, the first character inserted in the returned +string will be at the specified index. If \fIindex\fR is end-relative, the last +character inserted in the returned string will be at the specified index. +.PP +If \fIindex\fR is at or before the start of \fIstring\fR (e.g., \fIindex\fR is +\fB0\fR), \fIinsertString\fR is prepended to \fIstring\fR. If \fIindex\fR is at +or after the end of \fIstring\fR (e.g., \fIindex\fR is \fBend\fR), +\fIinsertString\fR is appended to \fIstring\fR. +.RE +.TP \fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR . Returns 1 if \fIstring\fR is a valid member of the specified character diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 0b65758..796a8a3 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1452,6 +1452,63 @@ StringIndexCmd( /* *---------------------------------------------------------------------- * + * StringInsertCmd -- + * + * This procedure is invoked to process the "string insert" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringInsertCmd( + ClientData dummy, /* Not used */ + Tcl_Interp *interp, /* Current interpreter */ + int objc, /* Number of arguments */ + Tcl_Obj *const objv[]) /* Argument objects */ +{ + int length; /* String length */ + int index; /* Insert index */ + Tcl_Obj *outObj; /* Output object */ + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "string index insertString"); + return TCL_ERROR; + } + + length = Tcl_GetCharLength(objv[1]); + if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) { + return TCL_ERROR; + } + + if (index < 0) { + index = 0; + } + if (index > length) { + index = length; + } + + outObj = TclStringReplace(interp, objv[1], index, 0, objv[3], + TCL_STRING_IN_PLACE); + + if (outObj != NULL) { + Tcl_SetObjResult(interp, outObj); + return TCL_OK; + } + + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * StringIsCmd -- * * This procedure is invoked to process the "string is" Tcl command. See @@ -3351,6 +3408,7 @@ TclInitStringCmd( {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, + {"insert", StringInsertCmd, NULL, NULL, NULL, 0}, {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0}, {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, diff --git a/tests/string.test b/tests/string.test index da302eb..172c066 100644 --- a/tests/string.test +++ b/tests/string.test @@ -73,7 +73,7 @@ if {$noComp} { test string-1.1.$noComp {error conditions} { list [catch {run {string gorp a b}} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2.$noComp {error conditions} { list [catch {run {string}} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} @@ -1775,7 +1775,7 @@ test string-20.1.$noComp {string trimright errors} { } {1 {wrong # args: should be "string trimright string ?chars?"}} test string-20.2.$noComp {string trimright errors} { list [catch {run {string trimg a}} msg] $msg -} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-20.3.$noComp {string trimright} { run {string trimright " XYZ "} } { XYZ} @@ -1834,7 +1834,7 @@ test string-21.14.$noComp {string wordend, unicode} { test string-22.1.$noComp {string wordstart} { list [catch {run {string word a}} msg] $msg -} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-22.2.$noComp {string wordstart} { list [catch {run {string wordstart a}} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} @@ -2300,6 +2300,89 @@ test string-29.15.$noComp {string cat, efficiency} -setup { } -match glob -result {*no string representation} } +# Note: string-30.* tests use [tcl::string::insert] rather than [string insert] +# to dodge ticket [3397978fff] which would cause all arguments to be shared, +# thereby preventing the optimizations from being tested. +test string-30.1.$noComp {string insert, start of string} { + run {tcl::string::insert 0123 0 _} +} _0123 +test string-30.2.$noComp {string insert, middle of string} { + run {tcl::string::insert 0123 2 _} +} 01_23 +test string-30.3.$noComp {string insert, end of string} { + run {tcl::string::insert 0123 4 _} +} 0123_ +test string-30.4.$noComp {string insert, start of string, end-relative} { + run {tcl::string::insert 0123 end-4 _} +} _0123 +test string-30.5.$noComp {string insert, middle of string, end-relative} { + run {tcl::string::insert 0123 end-2 _} +} 01_23 +test string-30.6.$noComp {string insert, end of string, end-relative} { + run {tcl::string::insert 0123 end _} +} 0123_ +test string-30.7.$noComp {string insert, empty target string} { + run {tcl::string::insert {} 0 _} +} _ +test string-30.8.$noComp {string insert, empty insert string} { + run {tcl::string::insert 0123 0 {}} +} 0123 +test string-30.9.$noComp {string insert, empty strings} { + run {tcl::string::insert {} 0 {}} +} {} +test string-30.10.$noComp {string insert, negative index} { + run {tcl::string::insert 0123 -1 _} +} _0123 +test string-30.11.$noComp {string insert, index beyond end} { + run {tcl::string::insert 0123 5 _} +} 0123_ +test string-30.12.$noComp {string insert, start of string, pure byte array} { + run {tcl::string::insert [makeByteArray 0123] 0 [makeByteArray _]} +} _0123 +test string-30.13.$noComp {string insert, middle of string, pure byte array} { + run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]} +} 01_23 +test string-30.14.$noComp {string insert, end of string, pure byte array} { + run {tcl::string::insert [makeByteArray 0123] 4 [makeByteArray _]} +} 0123_ +test string-30.15.$noComp {string insert, pure byte array, neither shared} { + run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]} +} 01_23 +test string-30.16.$noComp {string insert, pure byte array, first shared} { + run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\ + [makeByteArray _]} +} 01_23 +test string-30.17.$noComp {string insert, pure byte array, second shared} { + run {tcl::string::insert [makeByteArray 0123] 2\ + [makeShared [makeByteArray _]]} +} 01_23 +test string-30.18.$noComp {string insert, pure byte array, both shared} { + run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\ + [makeShared [makeByteArray _]]} +} 01_23 +test string-30.19.$noComp {string insert, start of string, pure Unicode} { + run {tcl::string::insert [makeUnicode 0123] 0 [makeUnicode _]} +} _0123 +test string-30.20.$noComp {string insert, middle of string, pure Unicode} { + run {tcl::string::insert [makeUnicode 0123] 2 [makeUnicode _]} +} 01_23 +test string-30.21.$noComp {string insert, end of string, pure Unicode} { + run {tcl::string::insert [makeUnicode 0123] 4 [makeUnicode _]} +} 0123_ +test string-30.22.$noComp {string insert, str start, pure Uni, first shared} { + run {tcl::string::insert [makeShared [makeUnicode 0123]] 0 [makeUnicode _]} +} _0123 +test string-30.23.$noComp {string insert, string mid, pure Uni, 2nd shared} { + run {tcl::string::insert [makeUnicode 0123] 2 [makeShared [makeUnicode _]]} +} 01_23 +test string-30.24.$noComp {string insert, string end, pure Uni, both shared} { + run {tcl::string::insert [makeShared [makeUnicode 0123]] 4\ + [makeShared [makeUnicode _]]} +} 0123_ +test string-30.25.$noComp {string insert, neither byte array nor Unicode} { + run {tcl::string::insert [makeList a b c] 1 zzzzzz} +} {azzzzzz b c} + } # cleanup -- cgit v0.12 From a6454e20a4ac5c7e3a1802e1080808c0d54f7d97 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Mar 2018 16:26:11 +0000 Subject: A compiler for [string insert] mirroring the one for [linsert]. --- generic/tclCmdMZ.c | 2 +- generic/tclCompCmdsSZ.c | 57 +++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 +++ 3 files changed, 61 insertions(+), 1 deletion(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 796a8a3..dc0cd63 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3408,7 +3408,7 @@ TclInitStringCmd( {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, - {"insert", StringInsertCmd, NULL, NULL, NULL, 0}, + {"insert", StringInsertCmd, TclCompileStringInsertCmd, NULL, NULL, 0}, {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0}, {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index cf088bb..ab82f82 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -449,6 +449,63 @@ TclCompileStringIndexCmd( } int +TclCompileStringInsertCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + int idx; + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + + /* Compute and push the string in which to insert */ + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* See what can be discovered about index at compile time */ + tokenPtr = TokenAfter(tokenPtr); + if (TCL_OK != TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, + TCL_INDEX_END, &idx)) { + + /* Nothing useful knowable - cease compile; let it direct eval */ + return TCL_OK; + } + + /* Compute and push the string to be inserted */ + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 3); + + if (idx == TCL_INDEX_START) { + /* Prepend the insertion string */ + OP4( REVERSE, 2); + OP1( STR_CONCAT1, 2); + } else if (idx == TCL_INDEX_END) { + /* Append the insertion string */ + OP1( STR_CONCAT1, 2); + } else { + /* Prefix + insertion + suffix */ + if (idx < TCL_INDEX_END) { + /* See comments in compiler for [linsert]. */ + idx++; + } + OP4( OVER, 1); + OP44( STR_RANGE_IMM, 0, idx-1); + OP4( REVERSE, 3); + OP44( STR_RANGE_IMM, idx, TCL_INDEX_END); + OP1( STR_CONCAT1, 3); + } + + return TCL_OK; +} + +int TclCompileStringIsCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclInt.h b/generic/tclInt.h index 81b1c05..daeb9eb 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3741,6 +3741,9 @@ MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringInsertCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From 8d4ff7c84a4acdc37c023fc436509c263f9455dc Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 24 Mar 2019 18:44:45 +0000 Subject: Start of implementation of TIP 160: better terminal control --- unix/tclUnixChan.c | 248 +++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 212 insertions(+), 36 deletions(-) diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 435579a..cede011 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -49,6 +49,16 @@ #endif /* HAVE_TERMIOS_H */ /* + * The bits supported for describing the closeMode field of TtyState. + */ + +enum CloseModeBits { + CLOSE_DEFAULT, + CLOSE_DRAIN, + CLOSE_DISCARD +}; + +/* * Helper macros to make parts of this file clearer. The macros do exactly * what they say on the tin. :-) They also only ever refer to their arguments * once, and so can be used without regard to side effects. @@ -58,7 +68,8 @@ #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) /* - * This structure describes per-instance state of a file based channel. + * These structures describe per-instance state of file-based and serial-based + * channels. */ typedef struct { @@ -69,6 +80,12 @@ typedef struct { * which operations are valid on the file. */ } FileState; +typedef struct { + FileState fileState; + int closeMode; /* One of CLOSE_DEFAULT, CLOSE_DRAIN or + * CLOSE_DISCARD. */ +} TtyState; + #ifdef SUPPORTS_TTY /* @@ -113,6 +130,8 @@ static Tcl_WideInt FileWideSeekProc(ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode); static void FileWatchProc(ClientData instanceData, int mask); #ifdef SUPPORTS_TTY +static int TtyCloseProc(ClientData instanceData, + Tcl_Interp *interp); static void TtyGetAttributes(int fd, TtyAttrs *ttyPtr); static int TtyGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, @@ -162,7 +181,7 @@ static const Tcl_ChannelType fileChannelType = { static const Tcl_ChannelType ttyChannelType = { "tty", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - FileCloseProc, /* Close proc. */ + TtyCloseProc, /* Close proc. */ FileInputProc, /* Input proc. */ FileOutputProc, /* Output proc. */ NULL, /* Seek proc. */ @@ -310,10 +329,11 @@ FileOutputProc( /* *---------------------------------------------------------------------- * - * FileCloseProc -- + * FileCloseProc, TtyCloseProc -- * - * This function is called from the generic IO level to perform - * channel-type-specific cleanup when a file based channel is closed. + * These functions are called from the generic IO level to perform + * channel-type-specific cleanup when a file- or tty-based channel is + * closed. * * Results: * 0 if successful, errno if failed. @@ -347,6 +367,38 @@ FileCloseProc( ckfree(fsPtr); return errorCode; } + +#ifdef SUPPORTS_TTY +static int +TtyCloseProc( + ClientData instanceData, + Tcl_Interp *interp) +{ + TtyState *ttyState = instanceData; + + /* + * If we've been asked by the user to drain or flush, do so now. + */ + + switch (ttyState->closeMode) { + case CLOSE_DRAIN: + tcdrain(ttyState->fileState.fd); + break; + case CLOSE_DISCARD: + tcflush(ttyState->fileState.fd, TCIOFLUSH); + break; + default: + /* Do nothing */ + break; + } + + /* + * Delegate to close for files. + */ + + return FileCloseProc(instanceData, interp); +} +#endif /* SUPPORTS_TTY */ /* *---------------------------------------------------------------------- @@ -578,7 +630,7 @@ TtySetOptionProc( const char *optionName, /* Which option to set? */ const char *value) /* New value for option. */ { - FileState *fsPtr = instanceData; + TtyState *fsPtr = instanceData; unsigned int len, vlen; TtyAttrs tty; int argc; @@ -601,7 +653,7 @@ TtySetOptionProc( * system calls results should be checked there. - dl */ - TtySetAttributes(fsPtr->fd, &tty); + TtySetAttributes(fsPtr->fileState.fd, &tty); return TCL_OK; } @@ -614,7 +666,7 @@ TtySetOptionProc( * Reset all handshake options. DTR and RTS are ON by default. */ - tcgetattr(fsPtr->fd, &iostate); + tcgetattr(fsPtr->fileState.fd, &iostate); CLEAR_BITS(iostate.c_iflag, IXON | IXOFF | IXANY); #ifdef CRTSCTS CLEAR_BITS(iostate.c_cflag, CRTSCTS); @@ -645,7 +697,7 @@ TtySetOptionProc( } return TCL_ERROR; } - tcsetattr(fsPtr->fd, TCSADRAIN, &iostate); + tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate); return TCL_OK; } @@ -670,7 +722,7 @@ TtySetOptionProc( return TCL_ERROR; } - tcgetattr(fsPtr->fd, &iostate); + tcgetattr(fsPtr->fileState.fd, &iostate); Tcl_UtfToExternalDString(NULL, argv[0], -1, &ds); iostate.c_cc[VSTART] = *(const cc_t *) Tcl_DStringValue(&ds); @@ -681,7 +733,7 @@ TtySetOptionProc( Tcl_DStringFree(&ds); ckfree(argv); - tcsetattr(fsPtr->fd, TCSADRAIN, &iostate); + tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate); return TCL_OK; } @@ -692,13 +744,13 @@ TtySetOptionProc( if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) { int msec; - tcgetattr(fsPtr->fd, &iostate); + tcgetattr(fsPtr->fileState.fd, &iostate); if (Tcl_GetInt(interp, value, &msec) != TCL_OK) { return TCL_ERROR; } iostate.c_cc[VMIN] = 0; iostate.c_cc[VTIME] = (msec==0) ? 0 : (msec<100) ? 1 : (msec+50)/100; - tcsetattr(fsPtr->fd, TCSADRAIN, &iostate); + tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate); return TCL_OK; } @@ -725,7 +777,7 @@ TtySetOptionProc( return TCL_ERROR; } - ioctl(fsPtr->fd, TIOCMGET, &control); + ioctl(fsPtr->fileState.fd, TIOCMGET, &control); for (i = 0; i < argc-1; i += 2) { if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) { ckfree(argv); @@ -746,9 +798,9 @@ TtySetOptionProc( } else if (Tcl_UtfNcasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) { #if defined(TIOCSBRK) && defined(TIOCCBRK) if (flag) { - ioctl(fsPtr->fd, TIOCSBRK, NULL); + ioctl(fsPtr->fileState.fd, TIOCSBRK, NULL); } else { - ioctl(fsPtr->fd, TIOCCBRK, NULL); + ioctl(fsPtr->fileState.fd, TIOCCBRK, NULL); } #else /* TIOCSBRK & TIOCCBRK */ UNSUPPORTED_OPTION("-ttycontrol BREAK"); @@ -768,7 +820,7 @@ TtySetOptionProc( } } /* -ttycontrol options loop */ - ioctl(fsPtr->fd, TIOCMSET, &control); + ioctl(fsPtr->fileState.fd, TIOCMSET, &control); ckfree(argv); return TCL_OK; #else /* TIOCMGET&TIOCMSET */ @@ -776,8 +828,79 @@ TtySetOptionProc( #endif /* TIOCMGET&TIOCMSET */ } + /* + * Option -closemode drain|discard + */ + + if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) { + if (Tcl_UtfNcasecmp(value, "DEFAULT", vlen) == 0) { + fsPtr->closeMode = CLOSE_DEFAULT; + } else if (Tcl_UtfNcasecmp(value, "DRAIN", vlen) == 0) { + fsPtr->closeMode = CLOSE_DRAIN; + } else if (Tcl_UtfNcasecmp(value, "DISCARD", vlen) == 0) { + fsPtr->closeMode = CLOSE_DISCARD; + } else { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad mode \"%s\" for -closemode: must be" + " default, discard, or drain", value)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", + "VALUE", NULL); + } + return TCL_ERROR; + } + return TCL_OK; + } + + /* + * Option -inputmode normal|password|raw + */ + + if ((len > 2) && (strncmp(optionName, "-inputmode", len) == 0)) { + if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read current serial state: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) { + iostate.c_iflag |= BRKINT | IGNPAR | ISTRIP | ICRNL | IXON; + iostate.c_oflag |= OPOST; + iostate.c_lflag |= ECHO | ICANON | ISIG; + } else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) { + iostate.c_iflag |= BRKINT | IGNPAR | ISTRIP | ICRNL | IXON; + iostate.c_oflag |= OPOST; + iostate.c_lflag &= ~(ECHO); + iostate.c_lflag |= ECHONL | ICANON | ISIG; + } else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) { + iostate.c_iflag = 0; + iostate.c_oflag &= ~(OPOST); + iostate.c_lflag &= ~(ECHO | ECHONL | ICANON | ISIG); + } else { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad mode \"%s\" for -inputmode: must be" + " normal, password, or raw", value)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", + "VALUE", NULL); + } + return TCL_ERROR; + } + if (tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate) < 0) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't update serial state: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + return TCL_OK; + } + return Tcl_BadChannelOption(interp, optionName, - "mode handshake timeout ttycontrol xchar"); + "closemode inputmode mode handshake timeout ttycontrol xchar"); } /* @@ -805,7 +928,7 @@ TtyGetOptionProc( const char *optionName, /* Option to get. */ Tcl_DString *dsPtr) /* Where to store value(s). */ { - FileState *fsPtr = instanceData; + TtyState *fsPtr = instanceData; unsigned int len; char buf[3*TCL_INTEGER_SPACE + 16]; int valid = 0; /* Flag if valid option parsed. */ @@ -815,6 +938,58 @@ TtyGetOptionProc( } else { len = strlen(optionName); } + + /* + * Get option -closemode + */ + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-closemode"); + } + if (len==0 || (len>1 && strncmp(optionName, "-closemode", len)==0)) { + switch (fsPtr->closeMode) { + case CLOSE_DRAIN: + Tcl_DStringAppendElement(dsPtr, "drain"); + break; + case CLOSE_DISCARD: + Tcl_DStringAppendElement(dsPtr, "discard"); + break; + default: + Tcl_DStringAppendElement(dsPtr, "default"); + break; + } + } + + /* + * Get option -inputmode + * + * This is a great simplification of the underlying reality, but actually + * represents what almost all scripts really want to know. + */ + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-inputmode"); + } + if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) { + struct termios iostate; + + valid = 1; + tcgetattr(fsPtr->fileState.fd, &iostate); + if (iostate.c_lflag & ICANON) { + if (iostate.c_lflag & ECHO) { + Tcl_DStringAppendElement(dsPtr, "normal"); + } else { + Tcl_DStringAppendElement(dsPtr, "password"); + } + } else { + Tcl_DStringAppendElement(dsPtr, "raw"); + } + } + + /* + * Get option -mode + */ + if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-mode"); } @@ -822,7 +997,7 @@ TtyGetOptionProc( TtyAttrs tty; valid = 1; - TtyGetAttributes(fsPtr->fd, &tty); + TtyGetAttributes(fsPtr->fileState.fd, &tty); sprintf(buf, "%d,%c,%d,%d", tty.baud, tty.parity, tty.data, tty.stop); Tcl_DStringAppendElement(dsPtr, buf); } @@ -840,7 +1015,7 @@ TtyGetOptionProc( Tcl_DString ds; valid = 1; - tcgetattr(fsPtr->fd, &iostate); + tcgetattr(fsPtr->fileState.fd, &iostate); Tcl_DStringInit(&ds); Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTART], 1, &ds); @@ -865,10 +1040,10 @@ TtyGetOptionProc( int inQueue=0, outQueue=0, inBuffered, outBuffered; valid = 1; - GETREADQUEUE(fsPtr->fd, inQueue); - GETWRITEQUEUE(fsPtr->fd, outQueue); - inBuffered = Tcl_InputBuffered(fsPtr->channel); - outBuffered = Tcl_OutputBuffered(fsPtr->channel); + GETREADQUEUE(fsPtr->fileState.fd, inQueue); + GETWRITEQUEUE(fsPtr->fileState.fd, outQueue); + inBuffered = Tcl_InputBuffered(fsPtr->fileState.channel); + outBuffered = Tcl_OutputBuffered(fsPtr->fileState.channel); sprintf(buf, "%d", inBuffered+inQueue); Tcl_DStringAppendElement(dsPtr, buf); @@ -887,7 +1062,7 @@ TtyGetOptionProc( int status; valid = 1; - ioctl(fsPtr->fd, TIOCMGET, &status); + ioctl(fsPtr->fileState.fd, TIOCMGET, &status); TtyModemStatusStr(status, dsPtr); } #endif /* TIOCMGET */ @@ -896,7 +1071,7 @@ TtyGetOptionProc( return TCL_OK; } return Tcl_BadChannelOption(interp, optionName, - "mode queue ttystatus xchar"); + "closemode inputmode mode queue ttystatus xchar"); } static const struct {int baud; speed_t speed;} speeds[] = { @@ -1367,7 +1542,7 @@ TclpOpenFileChannel( * what modes to create it? */ { int fd, channelPermissions; - FileState *fsPtr; + TtyState *fsPtr; const char *native, *translation; char channelName[16 + TCL_INTEGER_SPACE]; const Tcl_ChannelType *channelTypePtr; @@ -1451,11 +1626,12 @@ TclpOpenFileChannel( channelTypePtr = &fileChannelType; } - fsPtr = ckalloc(sizeof(FileState)); - fsPtr->validMask = channelPermissions | TCL_EXCEPTION; - fsPtr->fd = fd; + fsPtr = ckalloc(sizeof(TtyState)); + fsPtr->fileState.validMask = channelPermissions | TCL_EXCEPTION; + fsPtr->fileState.fd = fd; + fsPtr->closeMode = CLOSE_DEFAULT; - fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName, + fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName, fsPtr, channelPermissions); if (translation != NULL) { @@ -1467,14 +1643,14 @@ TclpOpenFileChannel( * reports that the serial port isn't working. */ - if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation", - translation) != TCL_OK) { - Tcl_Close(NULL, fsPtr->channel); + if (Tcl_SetChannelOption(interp, fsPtr->fileState.channel, + "-translation", translation) != TCL_OK) { + Tcl_Close(NULL, fsPtr->fileState.channel); return NULL; } } - return fsPtr->channel; + return fsPtr->fileState.channel; } /* -- cgit v0.12 From 4701c749af472143bba603d903ea764623614f94 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 24 Mar 2019 22:08:26 +0000 Subject: Better handling, reset capabilty, and ensure that inherited channels are correct --- unix/tclUnixChan.c | 121 ++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 91 insertions(+), 30 deletions(-) diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index cede011..605e317 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -82,8 +82,14 @@ typedef struct { typedef struct { FileState fileState; +#ifdef SUPPORTS_TTY int closeMode; /* One of CLOSE_DEFAULT, CLOSE_DRAIN or * CLOSE_DISCARD. */ + int doReset; /* Whether we should do a terminal reset on + * close. */ + struct termios initState; /* The state of the terminal when it was + * opened. */ +#endif /* SUPPORTS_TTY */ } TtyState; #ifdef SUPPORTS_TTY @@ -100,7 +106,7 @@ typedef struct { int stop; } TtyAttrs; -#endif /* !SUPPORTS_TTY */ +#endif /* SUPPORTS_TTY */ #define UNSUPPORTED_OPTION(detail) \ if (interp) { \ @@ -374,18 +380,18 @@ TtyCloseProc( ClientData instanceData, Tcl_Interp *interp) { - TtyState *ttyState = instanceData; + TtyState *ttyPtr = instanceData; /* * If we've been asked by the user to drain or flush, do so now. */ - switch (ttyState->closeMode) { + switch (ttyPtr->closeMode) { case CLOSE_DRAIN: - tcdrain(ttyState->fileState.fd); + tcdrain(ttyPtr->fileState.fd); break; case CLOSE_DISCARD: - tcflush(ttyState->fileState.fd, TCIOFLUSH); + tcflush(ttyPtr->fileState.fd, TCIOFLUSH); break; default: /* Do nothing */ @@ -393,6 +399,14 @@ TtyCloseProc( } /* + * If we've had our state changed from the default, reset now. + */ + + if (ttyPtr->doReset) { + tcsetattr(ttyPtr->fileState.fd, TCSANOW, &ttyPtr->initState); + } + + /* * Delegate to close for files. */ @@ -860,29 +874,48 @@ TtySetOptionProc( if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read current serial state: %s", + "couldn't read serial terminal control state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) { - iostate.c_iflag |= BRKINT | IGNPAR | ISTRIP | ICRNL | IXON; - iostate.c_oflag |= OPOST; - iostate.c_lflag |= ECHO | ICANON | ISIG; + SET_BITS(iostate.c_iflag, BRKINT | IGNPAR | ISTRIP | ICRNL | IXON); + SET_BITS(iostate.c_oflag, OPOST); + SET_BITS(iostate.c_lflag, ECHO | ECHONL | ICANON | ISIG); } else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) { - iostate.c_iflag |= BRKINT | IGNPAR | ISTRIP | ICRNL | IXON; - iostate.c_oflag |= OPOST; - iostate.c_lflag &= ~(ECHO); - iostate.c_lflag |= ECHONL | ICANON | ISIG; + SET_BITS(iostate.c_iflag, BRKINT | IGNPAR | ISTRIP | ICRNL | IXON); + SET_BITS(iostate.c_oflag, OPOST); + CLEAR_BITS(iostate.c_lflag, ECHO); + /* + * Note: password input turns out to be best if you echo the + * newline that the user types. Theoretically we could get users + * to do the processing of this in their scripts, but it always + * feels highly unnatural to do so in practice. + */ + SET_BITS(iostate.c_lflag, ECHONL | ICANON | ISIG); } else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) { - iostate.c_iflag = 0; - iostate.c_oflag &= ~(OPOST); - iostate.c_lflag &= ~(ECHO | ECHONL | ICANON | ISIG); +#ifdef HAVE_CFMAKERAW + cfmakeraw(&iostate); +#else /* !HAVE_CFMAKERAW */ + CLEAR_BITS(iostate.c_iflag, IGNBRK | BRKINT | PARMRK | ISTRIP + | INLCR | IGNCR | ICRNL | IXON); + CLEAR_BITS(iostate.c_oflag, OPOST); + CLEAR_BITS(iostate.c_lflag, ECHO | ECHONL | ICANON | ISIG | IEXTEN); + CLEAR_BITS(iostate.c_cflag, CSIZE | PARENB); + SET_BITS(iostate.c_cflag, CS8); +#endif /* HAVE_CFMAKERAW */ + } else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) { + /* + * Reset to the initial state, whatever that is. + */ + + memcpy(&iostate, &fsPtr->initState, sizeof(struct termios)); } else { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad mode \"%s\" for -inputmode: must be" - " normal, password, or raw", value)); + " normal, password, raw, or reset", value)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } @@ -891,11 +924,25 @@ TtySetOptionProc( if (tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate) < 0) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't update serial state: %s", + "couldn't update serial terminal control state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } + + /* + * If we've changed the state from default, schedule a reset later. + * Note that this specifically does not detect changes made by calling + * an external stty program; that is deliberate, as it maintains + * compatibility with existing code! + * + * This mechanism in Tcl is not intended to be a full replacement for + * what stty does; it just handles a few common cases and tries not to + * leave things in a broken state. + */ + + fsPtr->doReset = (memcmp(&iostate, &fsPtr->initState, + sizeof(struct termios)) != 0); return TCL_OK; } @@ -1598,8 +1645,6 @@ TclpOpenFileChannel( fcntl(fd, F_SETFD, FD_CLOEXEC); - sprintf(channelName, "file%d", fd); - #ifdef SUPPORTS_TTY if (strcmp(native, "/dev/tty") != 0 && isatty(fd)) { /* @@ -1619,17 +1664,25 @@ TclpOpenFileChannel( translation = "auto crlf"; channelTypePtr = &ttyChannelType; TtyInit(fd); + sprintf(channelName, "serial%d", fd); } else #endif /* SUPPORTS_TTY */ { translation = NULL; channelTypePtr = &fileChannelType; + sprintf(channelName, "file%d", fd); } fsPtr = ckalloc(sizeof(TtyState)); fsPtr->fileState.validMask = channelPermissions | TCL_EXCEPTION; fsPtr->fileState.fd = fd; - fsPtr->closeMode = CLOSE_DEFAULT; +#ifdef SUPPORTS_TTY + if (channelTypePtr == &ttyChannelType) { + fsPtr->closeMode = CLOSE_DEFAULT; + fsPtr->doReset = 0; + tcgetattr(fsPtr->fileState.fd, &fsPtr->initState); + } +#endif /* SUPPORTS_TTY */ fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName, fsPtr, channelPermissions); @@ -1675,7 +1728,7 @@ Tcl_MakeFileChannel( int mode) /* ORed combination of TCL_READABLE and * TCL_WRITABLE to indicate file mode. */ { - FileState *fsPtr; + TtyState *fsPtr; char channelName[16 + TCL_INTEGER_SPACE]; int fd = PTR2INT(handle); const Tcl_ChannelType *channelTypePtr; @@ -1694,22 +1747,30 @@ Tcl_MakeFileChannel( sprintf(channelName, "serial%d", fd); } else #endif /* SUPPORTS_TTY */ - if ((getsockname(fd, (struct sockaddr *)&sockaddr, &sockaddrLen) == 0) - && (sockaddrLen > 0) - && (sockaddr.sa_family == AF_INET || sockaddr.sa_family == AF_INET6)) { + if ((getsockname(fd, (struct sockaddr *) &sockaddr, &sockaddrLen) == 0) + && (sockaddrLen > 0) + && (sockaddr.sa_family == AF_INET + || sockaddr.sa_family == AF_INET6)) { return TclpMakeTcpClientChannelMode(INT2PTR(fd), mode); } else { channelTypePtr = &fileChannelType; sprintf(channelName, "file%d", fd); } - fsPtr = ckalloc(sizeof(FileState)); - fsPtr->fd = fd; - fsPtr->validMask = mode | TCL_EXCEPTION; - fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName, + fsPtr = ckalloc(sizeof(TtyState)); + fsPtr->fileState.fd = fd; + fsPtr->fileState.validMask = mode | TCL_EXCEPTION; + fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName, fsPtr, mode); +#ifdef SUPPORTS_TTY + if (channelTypePtr == &ttyChannelType) { + fsPtr->closeMode = CLOSE_DEFAULT; + fsPtr->doReset = 0; + tcgetattr(fsPtr->fileState.fd, &fsPtr->initState); + } +#endif /* SUPPORTS_TTY */ - return fsPtr->channel; + return fsPtr->fileState.channel; } /* -- cgit v0.12 From 7ff500ca4d515a5bbf1b6b4442d857c369c727fd Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 27 Mar 2019 08:29:13 +0000 Subject: Add autoconf support --- unix/configure | 4 ++-- unix/configure.ac | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/configure b/unix/configure index ea26c4f..2de5b54 100755 --- a/unix/configure +++ b/unix/configure @@ -9455,10 +9455,10 @@ $as_echo "$langinfo_ok" >&6; } #-------------------------------------------------------------------- -# Check for support of chflags and mkstemps functions +# Check for support of cfmakeraw, chflags and mkstemps functions #-------------------------------------------------------------------- -for ac_func in chflags mkstemps +for ac_func in cfmakeraw chflags mkstemps do : as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" diff --git a/unix/configure.ac b/unix/configure.ac index f34091f..74dbe08 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -553,10 +553,10 @@ fi SC_ENABLE_LANGINFO #-------------------------------------------------------------------- -# Check for support of chflags and mkstemps functions +# Check for support of cfmakeraw, chflags and mkstemps functions #-------------------------------------------------------------------- -AC_CHECK_FUNCS(chflags mkstemps) +AC_CHECK_FUNCS(cfmakeraw chflags mkstemps) #-------------------------------------------------------------------- # Check for support of isnan() function or macro -- cgit v0.12 From bc322bfae7b2bcfc1c9946a184ddf7a7c7e5d4e1 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 27 Mar 2019 13:54:18 +0000 Subject: Partial implementation on Windows. UNTESTED --- unix/tclUnixChan.c | 13 +++- win/tclWinConsole.c | 212 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 215 insertions(+), 10 deletions(-) diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 605e317..152de88 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -979,6 +979,7 @@ TtyGetOptionProc( unsigned int len; char buf[3*TCL_INTEGER_SPACE + 16]; int valid = 0; /* Flag if valid option parsed. */ + struct termios iostate; if (optionName == NULL) { len = 0; @@ -1018,10 +1019,15 @@ TtyGetOptionProc( Tcl_DStringAppendElement(dsPtr, "-inputmode"); } if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) { - struct termios iostate; - valid = 1; - tcgetattr(fsPtr->fileState.fd, &iostate); + if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read serial terminal control state: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } if (iostate.c_lflag & ICANON) { if (iostate.c_lflag & ECHO) { Tcl_DStringAppendElement(dsPtr, "normal"); @@ -1058,7 +1064,6 @@ TtyGetOptionProc( Tcl_DStringStartSublist(dsPtr); } if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) { - struct termios iostate; Tcl_DString ds; valid = 1; diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index f8b67a3..acb00cb 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -31,8 +31,10 @@ TCL_DECLARE_MUTEX(consoleMutex) * Bit masks used in the flags field of the ConsoleInfo structure below. */ -#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */ -#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ +#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */ +#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ +#define CONSOLE_READ_OPS (1<<4) /* Channel supports read-related ops. */ +#define CONSOLE_RESET (1<<5) /* Console mode needs to be reset. */ /* * Bit masks used in the sharedFlags field of the ConsoleInfo structure below. @@ -102,6 +104,7 @@ typedef struct ConsoleInfo { * readable object. */ int bytesRead; /* Number of bytes in the buffer. */ int offset; /* Number of bytes read out of the buffer. */ + DWORD initMode; /* Initial console mode. */ char buffer[CONSOLE_BUFFER_SIZE]; /* Data consumed by reader thread. */ } ConsoleInfo; @@ -144,12 +147,18 @@ static int ConsoleEventProc(Tcl_Event *evPtr, int flags); static void ConsoleExitHandler(ClientData clientData); static int ConsoleGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); +static int ConsoleGetOptionProc(ClientData instanceData, + Tcl_Interp *interp, const char *optionName, + Tcl_DString *dsPtr); static void ConsoleInit(void); static int ConsoleInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int ConsoleOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCode); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); +static int ConsoleSetOptionProc(ClientData instanceData, + Tcl_Interp *interp, const char *optionName, + const char *value); static void ConsoleSetupProc(ClientData clientData, int flags); static void ConsoleWatchProc(ClientData instanceData, int mask); static DWORD WINAPI ConsoleWriterThread(LPVOID arg); @@ -175,8 +184,8 @@ static const Tcl_ChannelType consoleChannelType = { ConsoleInputProc, /* Input proc. */ ConsoleOutputProc, /* Output proc. */ NULL, /* Seek proc. */ - NULL, /* Set option proc. */ - NULL, /* Get option proc. */ + ConsoleSetOptionProc, /* Set option proc. */ + ConsoleGetOptionProc, /* Get option proc. */ ConsoleWatchProc, /* Set up notifier to watch the channel. */ ConsoleGetHandleProc, /* Get an OS handle from channel. */ NULL, /* close2proc. */ @@ -569,6 +578,17 @@ ConsoleCloseProc( consolePtr->validMask &= ~TCL_WRITABLE; /* + * If the user has been tinkering with the mode, reset it now. We ignore + * any errors from this; we're quite possibly about to close or exit + * anyway. + */ + + if ((consolePtr->flags & CONSOLE_READ_OPS) && + (consolePtr->flags & CONSOLE_RESET)) { + SetConsoleMode(consolePtr->handle, consolePtr->initMode); + } + + /* * Don't close the Win32 handle if the handle is a standard channel during * the thread exit process. Otherwise, one thread may kill the stdio of * another. @@ -590,7 +610,7 @@ ConsoleCloseProc( * Remove the file from the list of watched files. */ - for (nextPtrPtr = &(tsdPtr->firstConsolePtr), infoPtr = *nextPtrPtr; + for (nextPtrPtr = &tsdPtr->firstConsolePtr, infoPtr = *nextPtrPtr; infoPtr != NULL; nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) { if (infoPtr == (ConsoleInfo *) consolePtr) { @@ -1332,7 +1352,9 @@ TclWinOpenConsoleChannel( * we only want to catch when complete lines are ready for reading. */ - GetConsoleMode(infoPtr->handle, &modes); + infoPtr->flags |= CONSOLE_READ_OPS; + GetConsoleMode(infoPtr->handle, &infoPtr->initMode); + modes = infoPtr->initMode; modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT); modes |= ENABLE_LINE_INPUT; SetConsoleMode(infoPtr->handle, modes); @@ -1415,6 +1437,184 @@ ConsoleThreadActionProc( } /* + *---------------------------------------------------------------------- + * + * ConsoleSetOptionProc -- + * + * Sets an option on a channel. + * + * Results: + * A standard Tcl result. Also sets the interp's result on error if + * interp is not NULL. + * + * Side effects: + * May modify an option on a console. Sets Error message if needed (by + * calling Tcl_BadChannelOption). + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleSetOptionProc( + ClientData instanceData, /* File state. */ + Tcl_Interp *interp, /* For error reporting - can be NULL. */ + const char *optionName, /* Which option to set? */ + const char *value) /* New value for option. */ +{ + ConsoleInfo *infoPtr = instanceData; + int len = strlen(optionName); + + /* + * Option -inputmode normal|password|raw + */ + + if ((infoPtr->flags & CONSOLE_READ_OPS) && (len > 1) && + (strncmp(optionName, "-inputmode", len) == 0)) { + DWORD mode; + + if (GetConsoleMode(infoPtr->handle, &mode) == 0) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read console mode: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) { + mode |= ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT; + } else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) { + mode |= ENABLE_LINE_INPUT; + mode &= ~ENABLE_ECHO_INPUT; + } else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) { + mode &= ~(ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT); + } else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) { + /* + * Reset to the initial mode, whatever that is. + */ + + mode = infoPtr->initMode; + } else { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad mode \"%s\" for -inputmode: must be" + " normal, password, raw, or reset", value)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", + "VALUE", NULL); + } + return TCL_ERROR; + } + if (SetConsoleMode(infoPtr->handle, mode) == 0) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set console mode: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + + /* + * If we've changed the mode from default, schedule a reset later. + */ + + if (mode == infoPtr->initMode) { + infoPtr->flags &= ~CONSOLE_RESET; + } else { + infoPtr->flags |= CONSOLE_RESET; + } + return TCL_OK; + } + + if (infoPtr->flags & CONSOLE_READ_OPS) { + return Tcl_BadChannelOption(interp, optionName, "inputmode"); + } else { + return Tcl_BadChannelOption(interp, optionName, "inputmode"); + } +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleGetOptionProc -- + * + * Gets a mode associated with an IO channel. If the optionName arg is + * non-NULL, retrieves the value of that option. If the optionName arg is + * NULL, retrieves a list of alternating option names and values for the + * given channel. + * + * Results: + * A standard Tcl result. Also sets the supplied DString to the string + * value of the option(s) returned. Sets error message if needed + * (by calling Tcl_BadChannelOption). + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleGetOptionProc( + ClientData instanceData, /* File state. */ + Tcl_Interp *interp, /* For error reporting - can be NULL. */ + const char *optionName, /* Option to get. */ + Tcl_DString *dsPtr) /* Where to store value(s). */ +{ + ConsoleInfo *infoPtr = instanceData; + int valid = 0; /* Flag if valid option parsed. */ + unsigned int len; + + if (optionName == NULL) { + len = 0; + } else { + len = strlen(optionName); + } + + /* + * Get option -inputmode + * + * This is a great simplification of the underlying reality, but actually + * represents what almost all scripts really want to know. + */ + + if (infoPtr->flags & CONSOLE_READ_OPS) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-inputmode"); + } + if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) { + DWORD mode; + + valid = 1; + if (GetConsoleMode(infoPtr->handle, &mode) == 0) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read console mode: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + if (mode & ENABLE_LINE_INPUT) { + if (mode & ENABLE_ECHO_INPUT) { + Tcl_DStringAppendElement(dsPtr, "normal"); + } else { + Tcl_DStringAppendElement(dsPtr, "password"); + } + } else { + Tcl_DStringAppendElement(dsPtr, "raw"); + } + } + } + + if (valid) { + return TCL_OK; + } + if (infoPtr->flags & CONSOLE_READ_OPS) { + return Tcl_BadChannelOption(interp, optionName, "inputmode"); + } else { + return Tcl_BadChannelOption(interp, optionName, ""); + } +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 -- cgit v0.12 From f787bc7152549932e82fc955ace3eb11f2bf8496 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 27 Mar 2019 21:14:46 +0000 Subject: Implement -closemode --- win/tclWinSerial.c | 85 ++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 80 insertions(+), 5 deletions(-) diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 8ee426b..e4393a8 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -44,6 +44,15 @@ TCL_DECLARE_MUTEX(serialMutex) #define SERIAL_ERROR (1<<4) /* + * Bit masks used for noting whether to drain or discard output on close. They + * are disjoint from each other; at most one may be set at a time. + */ + +#define SERIAL_CLOSE_DRAIN (1<<6) /* Drain all output on close. */ +#define SERIAL_CLOSE_DISCARD (1<<7) /* Discard all output on close. */ +#define SERIAL_CLOSE_MASK (3<<6) /* Both two bits above. */ + +/* * Default time to block between checking status on the serial port. */ @@ -604,7 +613,6 @@ SerialCloseProc( serialPtr->validMask &= ~TCL_READABLE; if (serialPtr->writeThread) { - TclPipeThreadStop(&serialPtr->writeTI, serialPtr->writeThread); CloseHandle(serialPtr->osWrite.hEvent); @@ -1278,7 +1286,7 @@ SerialWriterThread( /* exit */ break; } - infoPtr = (SerialInfo *)pipeTI->clientData; + infoPtr = (SerialInfo *) pipeTI->clientData; buf = infoPtr->writeBuf; toWrite = infoPtr->toWrite; @@ -1342,7 +1350,25 @@ SerialWriterThread( Tcl_MutexUnlock(&serialMutex); } - /* Worker exit, so inform the main thread or free TI-structure (if owned) */ + /* + * We're about to close, so do any drain or discard required. + */ + + if (infoPtr) { + switch (infoPtr->flags & SERIAL_CLOSE_MASK) { + case SERIAL_CLOSE_DRAIN: + FlushFileBuffers(infoPtr->handle); + break; + case SERIAL_CLOSE_DISCARD: + PurgeComm(infoPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR); + break; + } + } + + /* + * Worker exit, so inform the main thread or free TI-structure (if owned). + */ + TclPipeThreadExit(&pipeTI); return 0; @@ -1610,6 +1636,32 @@ SerialSetOptionProc( vlen = strlen(value); /* + * Option -closemode drain|discard|default + */ + + if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) { + if (Tcl_UtfNcasecmp(value, "DEFAULT", vlen) == 0) { + infoPtr->flags &= ~SERIAL_CLOSE_MASK; + } else if (Tcl_UtfNcasecmp(value, "DRAIN", vlen) == 0) { + infoPtr->flags &= ~SERIAL_CLOSE_MASK; + infoPtr->flags |= SERIAL_CLOSE_DRAIN; + } else if (Tcl_UtfNcasecmp(value, "DISCARD", vlen) == 0) { + infoPtr->flags &= ~SERIAL_CLOSE_MASK; + infoPtr->flags |= SERIAL_CLOSE_DISCARD; + } else { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad mode \"%s\" for -closemode: must be" + " default, discard, or drain", value)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", + "VALUE", NULL); + } + return TCL_ERROR; + } + return TCL_OK; + } + + /* * Option -mode baud,parity,databits,stopbits */ @@ -1938,7 +1990,8 @@ SerialSetOptionProc( } return Tcl_BadChannelOption(interp, optionName, - "mode handshake pollinterval sysbuffer timeout ttycontrol xchar"); + "closemode mode handshake pollinterval sysbuffer timeout " + "ttycontrol xchar"); getStateFailed: if (interp != NULL) { @@ -1999,6 +2052,27 @@ SerialGetOptionProc( } /* + * Get option -closemode + */ + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-closemode"); + } + if (len==0 || (len>1 && strncmp(optionName, "-closemode", len)==0)) { + switch (infoPtr->flags & SERIAL_CLOSE_MASK) { + case SERIAL_CLOSE_DRAIN: + Tcl_DStringAppendElement(dsPtr, "drain"); + break; + case SERIAL_CLOSE_DISCARD: + Tcl_DStringAppendElement(dsPtr, "discard"); + break; + default: + Tcl_DStringAppendElement(dsPtr, "default"); + break; + } + } + + /* * Get option -mode */ @@ -2174,7 +2248,8 @@ SerialGetOptionProc( return TCL_OK; } return Tcl_BadChannelOption(interp, optionName, - "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); + "closemode mode pollinterval lasterror queue sysbuffer ttystatus " + "xchar"); } /* -- cgit v0.12 From ba13f3330ac8409d661a5713012837ede410b32a Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 28 Mar 2019 10:53:55 +0000 Subject: Documentation --- doc/open.n | 134 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 128 insertions(+), 6 deletions(-) diff --git a/doc/open.n b/doc/open.n index 1cccc0a..f6aca52 100644 --- a/doc/open.n +++ b/doc/open.n @@ -166,8 +166,9 @@ is opened and initialized in a platform-dependent manner. Acceptable values for the \fIfileName\fR to use to open a serial port are described in the PORTABILITY ISSUES section. .PP -The \fBfconfigure\fR command can be used to query and set additional -configuration options specific to serial ports (where supported): +The \fBchan configure\fR and \fBfconfigure\fR commands can be used to query +and set additional configuration options specific to serial ports (where +supported): .TP \fB\-mode\fR \fIbaud\fB,\fIparity\fB,\fIdata\fB,\fIstop\fR . @@ -249,6 +250,69 @@ handshake characters. Normally the operating system default should be DC1 (0x11) and DC3 (0x13) representing the ASCII standard XON and XOFF characters. .TP +\fB\-closemode\fR \fIcloseMode\fR +.VS "8.7, TIP 160" +(Windows and Unix). This option is used to query or change the close mode of +the serial channel, which defines how pending output in operating system +buffers is handled when the channel is closed. The following values for +\fIcloseMode\fR are supported: +.RS +.TP +\fBdefault\fR +. +indicates that a system default operation should be used; all serial channels +default to this. +.TP +\fBdiscard\fR +. +indicates that the contents of the OS buffers should be discarded. Note that +this is \fInot recommended\fR when writing to a POSIX terminal, as it can +interact unexpectedly with handling of \fBstderr\fR. +.TP +\fBdrain\fR +. +indicates that Tcl should wait when closing the channel until all output has +been consumed. This may slow down \fBclose\fR noticeably. +.RE +.VE "8.7, TIP 160" +.TP +\fB\-inputmode\fR \fIinputMode\fR +.VS "8.7, TIP 160" +(Unix only; Windows has the equivalent option on console channels). This +option is used to query or change the input mode of the serial channel under +the assumption that it is talking to a termina, which controls how interactive +input from users is handled. The following values for \fIinputMode\fR are +supported: +.RS +.TP +\fBnormal\fR +. +indicates that normal line-oriented input should be used, with standard +terminal editing capabilities enabled. +.TP +\fBpassword\fR +. +indicates that non-echoing input should be used, with standard terminal +editing capabilitied enabled but no writing of typed characters to the +terminal (except for newlines). Some terminals may indicate this specially. +.TP +\fBraw\fR +. +indicates that all keyboard input should be given directly to Tcl with the +terminal doing no processing at all. It does not echo the keys, leaving it up +to the Tcl script to interpret what to do. +.TP +\fBreset\fR (set only) +. +indicates that the terminal should be reset to what state it was in when the +terminal was opened. +.PP +Note that setting this option (technically, anything that changes the terminal +state from its initial value \fIvia this option\fR) will cause the channel to +turn on an automatic reset of the terminal when the channel is closed. +.RE +.VE "8.7, TIP 160" +.TP \fB\-pollinterval\fR \fImsec\fR . (Windows only). This option is used to set the maximum time between @@ -275,7 +339,7 @@ In case of a serial communication error, \fBread\fR or \fBputs\fR returns a general Tcl file I/O error. \fBfconfigure\fR \fB\-lasterror\fR can be called to get a list of error details. See below for an explanation of the various error codes. -.SH "SERIAL PORT SIGNALS" +.SS "SERIAL PORT SIGNALS" .PP RS-232 is the most commonly used standard electrical interface for serial communications. A negative voltage (-3V..-12V) define a mark (on=1) bit and @@ -316,7 +380,7 @@ milliseconds. Normally a receive or transmit data signal stays at the mark (on=1) voltage until the next character is transferred. A BREAK is sometimes used to reset the communications line or change the operating mode of communications hardware. -.SH "ERROR CODES (Windows only)" +.SS "ERROR CODES (Windows only)" .PP A lot of different errors may occur during serial read operations or during event polling in background. The external device may have been switched @@ -359,7 +423,7 @@ may cause this error. \fBBREAK\fR . A BREAK condition has been detected by your UART (see above). -.SH "PORTABILITY ISSUES" +.SS "PORTABILITY ISSUES" .TP \fBWindows \fR . @@ -408,7 +472,49 @@ input, but is redirected from a file, then the above problem does not occur. See the \fBPORTABILITY ISSUES\fR section of the \fBexec\fR command for additional information not specific to command pipelines about executing applications on the various platforms -.SH "EXAMPLE" +.SH "CONSOLE CHANNELS" +.VS "8.7, TIP 160" +On Windows only, console channels (usually \fBstdin\fR or \fBstdout\fR) +support the following option: +.TP +\fB\-inputmode\fR \fIinputMode\fR +. +This option is used to query or change the input mode of the console channel, +which controls how interactive input from users is handled. The following +values for \fIinputMode\fR are supported: +.RS +.TP +\fBnormal\fR +. +indicates that normal line-oriented input should be used, with standard +console editing capabilities enabled. +.TP +\fBpassword\fR +. +indicates that non-echoing input should be used, with standard console +editing capabilitied enabled but no writing of typed characters to the +terminal (except for newlines). +.TP +\fBraw\fR +. +indicates that all keyboard input should be given directly to Tcl with the +console doing no processing at all. It does not echo the keys, leaving it up +to the Tcl script to interpret what to do. +.TP +\fBreset\fR (set only) +. +indicates that the console should be reset to what state it was in when the +console channel was opened. +.PP +Note that setting this option (technically, anything that changes the console +state from its default \fIvia this option\fR) will cause the channel to turn +on an automatic reset of the console when the channel is closed. +.RE +.PP +Note that the equivalent option exists on Unix, but is on the serial channel +type. +.VE "8.7, TIP 160" +.SH "EXAMPLES" .PP Open a command pipeline and catch any errors: .PP @@ -419,6 +525,22 @@ if {[catch {close $fl} err]} { puts "ls command failed: $err" } .CE +.PP +.VS "8.7, TIP 160" +Read a password securely from the user (assuming that the script is being run +interactively): +.PP +.CS +chan configure stdin \fB-inputmode password\fR +try { + chan puts -nonewline "Password: " + chan flush stdout + set thePassword [chan gets stdin] +} finally { + chan configure stdin \fB-inputmode reset\fR +} +.CE +.VE "8.7, TIP 160" .SH "SEE ALSO" file(n), close(n), filename(n), fconfigure(n), gets(n), read(n), puts(n), exec(n), pid(n), fopen(3) -- cgit v0.12 From 99c5fed89eb2433b809000fb6846d2224a812762 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 28 Mar 2019 13:11:58 +0000 Subject: Tests, but not working ones... --- tests/ioCmd.test | 128 +++++++++++++++++++++++++++++++------------------------ 1 file changed, 73 insertions(+), 55 deletions(-) diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 68bc542..9c93102 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -206,78 +206,90 @@ test iocmd-7.5 {close command} -setup { close $chan } -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed" -test iocmd-8.1 {fconfigure command} { - list [catch {fconfigure} msg] $msg -} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}} -test iocmd-8.2 {fconfigure command} { - list [catch {fconfigure a b c d e f} msg] $msg -} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}} -test iocmd-8.3 {fconfigure command} { - list [catch {fconfigure a b} msg] $msg -} {1 {can not find channel named "a"}} -test iocmd-8.4 {fconfigure command} { +proc expectedOpts {got extra} { + set basicOpts { + -blocking -buffering -buffersize -encoding -eofchar -translation + } + set opts [list {*}$basicOpts {*}$extra] + lset opts end [string cat "or " [lindex $opts end]] + return [format {bad option "%s": should be one of %s} $got [join $opts ", "]] +} +test iocmd-8.1 {fconfigure command} -returnCodes error -body { + fconfigure +} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"} +test iocmd-8.2 {fconfigure command} -returnCodes error -body { + fconfigure a b c d e f +} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"} +test iocmd-8.3 {fconfigure command} -returnCodes error -body { + fconfigure a b +} -result {can not find channel named "a"} +test iocmd-8.4 {fconfigure command} -setup { file delete $path(test1) set f1 [open $path(test1) w] - set x [list [catch {fconfigure $f1 froboz} msg] $msg] +} -body { + fconfigure $f1 froboz +} -returnCodes error -cleanup { close $f1 - set x -} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -test iocmd-8.5 {fconfigure command} { - list [catch {fconfigure stdin -buffering froboz} msg] $msg -} {1 {bad value for -buffering: must be one of full, line, or none}} -test iocmd-8.6 {fconfigure command} { - list [catch {fconfigure stdin -translation froboz} msg] $msg -} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}} -test iocmd-8.7 {fconfigure command} { +} -result [expectedOpts "froboz" {}] +test iocmd-8.5 {fconfigure command} -returnCodes error -body { + fconfigure stdin -buffering froboz +} -result {bad value for -buffering: must be one of full, line, or none} +test iocmd-8.6 {fconfigure command} -returnCodes error -body { + fconfigure stdin -translation froboz +} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform} +test iocmd-8.7 {fconfigure command} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] fconfigure $f1 -translation lf -eofchar {} -encoding unicode - set x [fconfigure $f1] - close $f1 - set x -} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} -test iocmd-8.8 {fconfigure command} { + fconfigure $f1 +} -cleanup { + catch {close $f1} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} +test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) + set x {} +} -body { set f1 [open $path(test1) w] fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ -eofchar {} -encoding unicode - set x "" lappend x [fconfigure $f1 -buffering] lappend x [fconfigure $f1] - close $f1 - set x -} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} -test iocmd-8.9 {fconfigure command} { +} -cleanup { + catch {close $f1} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} +test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ -eofchar {} -encoding binary - set x [fconfigure $f1] - close $f1 - set x -} {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} -test iocmd-8.10 {fconfigure command} { - list [catch {fconfigure a b} msg] $msg -} {1 {can not find channel named "a"}} + fconfigure $f1 +} -cleanup { + catch {close $f1} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} +test iocmd-8.10 {fconfigure command} -returnCodes error -body { + fconfigure a b +} -result {can not find channel named "a"} set path(fconfigure.dummy) [makeFile {} fconfigure.dummy] -test iocmd-8.11 {fconfigure command} { +test iocmd-8.11 {fconfigure command} -body { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg] - close $chan - set res -} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -test iocmd-8.12 {fconfigure command} { + fconfigure $chan -froboz blarfo +} -returnCodes error -cleanup { + catch {close $chan} +} -result [expectedOpts "-froboz" {}] +test iocmd-8.12 {fconfigure command} -body { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -b blarfo} msg] $msg] - close $chan - set res -} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -test iocmd-8.13 {fconfigure command} { + fconfigure $chan -b blarfo +} -returnCodes error -cleanup { + catch {close $chan} +} -result [expectedOpts "-b" {}] +test iocmd-8.13 {fconfigure command} -body { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg] - close $chan - set res -} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} + fconfigure $chan -buffer blarfo +} -returnCodes error -cleanup { + catch {close $chan} +} -result [expectedOpts "-buffer" {}] removeFile fconfigure.dummy test iocmd-8.14 {fconfigure command} { fconfigure stdin -buffers @@ -294,7 +306,7 @@ test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOr close $srv unset cli srv port rename iocmdSRV {} -} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -connecting, -peername, or -sockname} +} -returnCodes error -result [expectedOpts "-blah" {-connecting -peername -sockname}] test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] set port [lindex [fconfigure $srv -sockname] 2] @@ -337,7 +349,7 @@ test iocmd-8.18 {fconfigure command / unix tty channel} -constraints {nonPortabl if {$tty ne ""} { close $tty } -} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -mode} +} -returnCodes error -result [expectedOpts "-blah" {-closemode -inputmode -mode -queue -ttystatus -xchar}] test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable win} -setup { set tty "" } -body { @@ -348,7 +360,13 @@ test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable if {$tty ne ""} { close $tty } -} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, -handshake, -pollinterval, -sysbuffer, -timeout, -ttycontrol, or -xchar} +} -returnCodes error -result [expectedOpts "-blah" {-closemode -mode -handshake -pollinterval -sysbuffer -timeout -ttycontrol -xchar}] +test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPortable win} -setup { + # I don't know how else to open the console, but this is non-portable + set console stdin +} -body { + fconfigure $console -blah blih +} -returnCodes error -result [expectedOpts "-blah" {-inputmode}] # TODO: Test parsing of serial channel options (nonPortable, since requires an # open channel to work with). -- cgit v0.12 From 5624496889a065617fbded91ff512c4066b51f64 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 29 Mar 2019 11:57:23 +0000 Subject: Oops --- win/tclWinConsole.c | 1 + 1 file changed, 1 insertion(+) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index acb00cb..de2723b 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -1463,6 +1463,7 @@ ConsoleSetOptionProc( { ConsoleInfo *infoPtr = instanceData; int len = strlen(optionName); + int vlen = strlen(value); /* * Option -inputmode normal|password|raw -- cgit v0.12 From 8ac5057a32d3241ca2ca4a353b1cb650c09e3eb0 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 29 Mar 2019 14:22:23 +0000 Subject: Support -winsize read-only option --- doc/open.n | 16 ++++++++++++++-- unix/tclUnixChan.c | 28 +++++++++++++++++++++++++++- win/tclWinConsole.c | 31 +++++++++++++++++++++++++++++-- 3 files changed, 70 insertions(+), 5 deletions(-) diff --git a/doc/open.n b/doc/open.n index f6aca52..d128512 100644 --- a/doc/open.n +++ b/doc/open.n @@ -311,6 +311,12 @@ Note that setting this option (technically, anything that changes the terminal state from its initial value \fIvia this option\fR) will cause the channel to turn on an automatic reset of the terminal when the channel is closed. .RE +.TP +\fB\-winsize\fR +. +(Unix only; Windows has the equivalent option on console channels). This +option is query only. It retrieves a two-element list with the the current +width and height of the terminal. .VE "8.7, TIP 160" .TP \fB\-pollinterval\fR \fImsec\fR @@ -475,7 +481,7 @@ applications on the various platforms .SH "CONSOLE CHANNELS" .VS "8.7, TIP 160" On Windows only, console channels (usually \fBstdin\fR or \fBstdout\fR) -support the following option: +support the following options: .TP \fB\-inputmode\fR \fIinputMode\fR . @@ -510,8 +516,14 @@ Note that setting this option (technically, anything that changes the console state from its default \fIvia this option\fR) will cause the channel to turn on an automatic reset of the console when the channel is closed. .RE +.TP +\fB\-winsize\fR +. +This option is query only. +It retrieves a two-element list with the the current width and height of the +console that this channel is talking to. .PP -Note that the equivalent option exists on Unix, but is on the serial channel +Note that the equivalent options exist on Unix, but are on the serial channel type. .VE "8.7, TIP 160" .SH "EXAMPLES" diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 152de88..ffeb0a7 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -1119,11 +1119,37 @@ TtyGetOptionProc( } #endif /* TIOCMGET */ +#if defined(TIOCGWINSZ) + /* + * Get option -winsize + * Option is readonly and returned by [fconfigure chan -winsize] but not + * returned by [fconfigure chan] without explicit option name. + */ + + if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) { + struct winsize ws; + + valid = 1; + if (ioctl(fsPtr->fileState.fd, TIOCGWINSZ, &ws) < 0) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read terminal size: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + sprintf(buf, "%d", ws.ws_col); + Tcl_DStringAppendElement(dsPtr, buf); + sprintf(buf, "%d", ws.ws_row); + Tcl_DStringAppendElement(dsPtr, buf); + } +#endif /* TIOCGWINSZ */ + if (valid) { return TCL_OK; } return Tcl_BadChannelOption(interp, optionName, - "closemode inputmode mode queue ttystatus xchar"); + "closemode inputmode mode queue ttystatus winsize xchar"); } static const struct {int baud; speed_t speed;} speeds[] = { diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index de2723b..d07bd3a 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -1530,7 +1530,7 @@ ConsoleSetOptionProc( if (infoPtr->flags & CONSOLE_READ_OPS) { return Tcl_BadChannelOption(interp, optionName, "inputmode"); } else { - return Tcl_BadChannelOption(interp, optionName, "inputmode"); + return Tcl_BadChannelOption(interp, optionName, ""); } } @@ -1605,11 +1605,38 @@ ConsoleGetOptionProc( } } + /* + * Get option -winsize + * Option is readonly and returned by [fconfigure chan -winsize] but not + * returned by [fconfigure chan] without explicit option name. + */ + + if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) { + CONSOLE_SCREEN_BUFFER_INFO consoleInfo; + + valid = 1; + if (!GetConsoleScreenBufferInfo(infoPtr->handle, &consoleInfo)) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read console size: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + sprintf(buf, "%d", + consoleInfo.srWindow.Right - consoleInfo.srWindow.Left + 1); + Tcl_DStringAppendElement(dsPtr, buf); + sprintf(buf, "%d", + consoleInfo.srWindow.Bottom - consoleInfo.srWindow.Top + 1); + Tcl_DStringAppendElement(dsPtr, buf); + } + if (valid) { return TCL_OK; } if (infoPtr->flags & CONSOLE_READ_OPS) { - return Tcl_BadChannelOption(interp, optionName, "inputmode"); + return Tcl_BadChannelOption(interp, optionName, "inputmode winsize"); } else { return Tcl_BadChannelOption(interp, optionName, ""); } -- cgit v0.12 From d78f576dc5981f706b44ef783bdc285e992db779 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 30 Mar 2019 10:36:58 +0000 Subject: Implementation of [lremove]. --- generic/tclBasic.c | 1 + generic/tclCmdIL.c | 114 +++++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 ++ 3 files changed, 118 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 1806557..e377951 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -262,6 +262,7 @@ static const CmdInfo builtInCmds[] = { {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, {"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE}, + {"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index a1a7f3e..0e36455 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2704,6 +2704,120 @@ Tcl_LrangeObjCmd( /* *---------------------------------------------------------------------- * + * Tcl_LremoveObjCmd -- + * + * This procedure is invoked to process the "lremove" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +typedef int list_index_t; + +static int +LremoveIndexCompare( + const void *el1Ptr, + const void *el2Ptr) +{ + list_index_t idx1 = *((const list_index_t *) el1Ptr); + list_index_t idx2 = *((const list_index_t *) el2Ptr); + + /* + * This will put the larger element first. + */ + + return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0; +} + +int +Tcl_LremoveObjCmd( + ClientData notUsed, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int i, idxc; + list_index_t listLen, *idxv, prevIdx; + Tcl_Obj *listObj; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?"); + return TCL_ERROR; + } + + listObj = objv[1]; + if (TclListObjLength(interp, listObj, &listLen) != TCL_OK) { + return TCL_ERROR; + } + + idxc = objc - 2; + if (idxc == 0) { + Tcl_SetObjResult(interp, listObj); + return TCL_OK; + } + idxv = ckalloc((objc - 2) * sizeof(list_index_t)); + for (i = 2; i < objc; i++) { + if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1, + &idxv[i - 2]) != TCL_OK) { + ckfree(idxv); + return TCL_ERROR; + } + } + + /* + * Sort the indices, large to small so that when we remove an index we + * don't change the indices still to be processed. + */ + + if (idxc > 1) { + qsort(idxv, idxc, sizeof(list_index_t), LremoveIndexCompare); + } + + /* + * Make our working copy, then do the actual removes piecemeal. It would + * be more efficient to do range coalescing; contributions accepted! + */ + + if (Tcl_IsShared(listObj)) { + listObj = TclListObjCopy(NULL, listObj); + } + for (i = 0, prevIdx = -1 ; i < idxc ; i++) { + list_index_t idx = idxv[i]; + + /* + * Repeated index and sanity check. + */ + + if (idx == prevIdx) { + continue; + } + prevIdx = idx; + if (idx < 0 || idx >= listLen) { + continue; + } + + /* + * Note that this operation can't fail now; we know we have a list and + * we're only ever contracting that list. + */ + + (void) Tcl_ListObjReplace(interp, listObj, idx, 1, 0, NULL); + listLen--; + } + ckfree(idxv); + Tcl_SetObjResult(interp, listObj); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_LrepeatObjCmd -- * * This procedure is invoked to process the "lrepeat" Tcl command. See diff --git a/generic/tclInt.h b/generic/tclInt.h index 9fc778b..6a3eafe 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3471,6 +3471,9 @@ MODULE_SCOPE int Tcl_LpopObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LremoveObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LrepeatObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -- cgit v0.12 From 83f6cc3841131f68cf0b1b4bb410ce6b52157629 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 30 Mar 2019 12:41:59 +0000 Subject: Tests, and reduce number of copies. --- generic/tclCmdIL.c | 36 +++++++++++++++++++++++++++++------- tests/cmdIL.test | 51 ++++++++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 77 insertions(+), 10 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 0e36455..441090c 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2743,9 +2743,13 @@ Tcl_LremoveObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int i, idxc; - list_index_t listLen, *idxv, prevIdx; + list_index_t listLen, *idxv, prevIdx, first, num; Tcl_Obj *listObj; + /* + * Parse the arguments. + */ + if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?"); return TCL_ERROR; @@ -2780,13 +2784,14 @@ Tcl_LremoveObjCmd( } /* - * Make our working copy, then do the actual removes piecemeal. It would - * be more efficient to do range coalescing; contributions accepted! + * Make our working copy, then do the actual removes piecemeal. */ if (Tcl_IsShared(listObj)) { listObj = TclListObjCopy(NULL, listObj); } + num = 0; + first = listLen; for (i = 0, prevIdx = -1 ; i < idxc ; i++) { list_index_t idx = idxv[i]; @@ -2803,12 +2808,29 @@ Tcl_LremoveObjCmd( } /* - * Note that this operation can't fail now; we know we have a list and - * we're only ever contracting that list. + * Coalesce adjacent removes to reduce the number of copies. */ - (void) Tcl_ListObjReplace(interp, listObj, idx, 1, 0, NULL); - listLen--; + if (num == 0) { + num = 1; + first = idx; + } else if (idx + 1 == first) { + num++; + first = idx; + } else { + /* + * Note that this operation can't fail now; we know we have a list + * and we're only ever contracting that list. + */ + + (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL); + listLen -= num; + num = 1; + first = idx; + } + } + if (num != 0) { + (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL); } ckfree(idxv); Tcl_SetObjResult(interp, listObj); diff --git a/tests/cmdIL.test b/tests/cmdIL.test index e4931a4..215796f 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -19,7 +19,7 @@ catch [list package require -exact Tcltest [info patchlevel]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] testConstraint testobj [llength [info commands testobj]] - + test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body { lsort } -result {wrong # args: should be "lsort ?-option value ...? list"} @@ -774,6 +774,52 @@ test cmdIL-7.8 {lreverse command - shared intrep [Bug 1675044]} -setup { rename K {} } -result 1 +test cmdIL-8.1 {lremove command: error path} -returnCodes error -body { + lremove +} -result {wrong # args: should be "lremove list ?index ...?"} +test cmdIL-8.2 {lremove command: error path} -returnCodes error -body { + lremove {{}{}} +} -result {list element in braces followed by "{}" instead of space} +test cmdIL-8.3 {lremove command: error path} -returnCodes error -body { + lremove {a b c} gorp +} -result {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?} +test cmdIL-8.4 {lremove command: no indices} -body { + lremove {a b c} +} -result {a b c} +test cmdIL-8.5 {lremove command: before start} -body { + lremove {a b c} -1 +} -result {a b c} +test cmdIL-8.6 {lremove command: after end} -body { + lremove {a b c} 3 +} -result {a b c} +test cmdIL-8.7 {lremove command} -body { + lremove {a b c} 0 +} -result {b c} +test cmdIL-8.8 {lremove command} -body { + lremove {a b c} 1 +} -result {a c} +test cmdIL-8.9 {lremove command} -body { + lremove {a b c} end +} -result {a b} +test cmdIL-8.10 {lremove command} -body { + lremove {a b c} end-1 +} -result {a c} +test cmdIL-8.11 {lremove command} -body { + lremove {a b c d e} 1 3 +} -result {a c e} +test cmdIL-8.12 {lremove command} -body { + lremove {a b c d e} 3 1 +} -result {a c e} +test cmdIL-8.13 {lremove command: same index twice} -body { + lremove {a b c d e} 2 2 +} -result {a b d e} +test cmdIL-8.14 {lremove command: same index twice} -body { + lremove {a b c d e} 3 end-1 +} -result {a b c e} +test cmdIL-8.15 {lremove command: many indices} -body { + lremove {a b c d e} 1 3 1 4 0 +} -result {c} + # This belongs in info test, but adding tests there breaks tests # that compute source file line numbers. test info-20.6 {Bug 3587651} -setup { @@ -782,8 +828,7 @@ test info-20.6 {Bug 3587651} -setup { }}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup { namespace delete my } -result 1 - - + # cleanup ::tcltest::cleanupTests return -- cgit v0.12 From 3471a570b685e48a9da13cc60a506f175ba0283b Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 30 Mar 2019 12:54:52 +0000 Subject: Added documentation --- doc/lrange.n | 2 +- doc/lremove.n | 55 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ doc/lreplace.n | 2 +- 3 files changed, 57 insertions(+), 2 deletions(-) create mode 100644 doc/lremove.n diff --git a/doc/lrange.n b/doc/lrange.n index ba068f6..a4fd98b 100644 --- a/doc/lrange.n +++ b/doc/lrange.n @@ -72,7 +72,7 @@ elements to .CE .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lset(n), lreplace(n), lsort(n), +lset(n), lremove(n), lreplace(n), lsort(n), string(n) .SH KEYWORDS element, list, range, sublist diff --git a/doc/lremove.n b/doc/lremove.n new file mode 100644 index 0000000..b947863 --- /dev/null +++ b/doc/lremove.n @@ -0,0 +1,55 @@ +'\" +'\" 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. +'\" +.TH lremove n 8.7 Tcl "Tcl Built-In Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lremove \- Remove elements from a list by index +.SH SYNOPSIS +\fBlremove \fIlist\fR ?\fIindex ...\fR? +.BE +.SH DESCRIPTION +.PP +\fBlremove\fR returns a new list formed by simultaneously removing zero or +more elements of \fIlist\fR at each of the indices given by an arbirary number +of \fIindex\fR arguments. The indices may be in any order and may be repeated; +the element at index will only be removed once. The index values are +interpreted the same as index values for the command \fBstring index\fR, +supporting simple index arithmetic and indices relative to the end of the +list. 0 refers to the first element of the list, and \fBend\fR refers to the +last element of the list. +.SH EXAMPLES +.PP +Removing the third element of a list: +.PP +.CS +% \fBlremove\fR {a b c d e} 2 +a b d e +.CE +.PP +Removing two elements from a list: +.PP +.CS +% \fBlremove\fR {a b c d e} end-1 1 +a c e +.CE +.PP +Removing the same element indicated in two different ways: +.PP +.CS +% \fBlremove\fR {a b c d e} 2 end-2 +a b d e +.CE +.SH "SEE ALSO" +list(n), lrange(n), lsearch(n), lsearch(n) +.SH KEYWORDS +element, list, remove +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/lreplace.n b/doc/lreplace.n index 32b7356..68cddfe 100644 --- a/doc/lreplace.n +++ b/doc/lreplace.n @@ -96,7 +96,7 @@ a b c d e f g h i .VE TIP505 .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lset(n), lrange(n), lsort(n), +lset(n), lrange(n), lremove(n), lsort(n), string(n) .SH KEYWORDS element, list, replace -- cgit v0.12 From d2fb211d208690336c1cc183cbd4c8d488411ff2 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 1 Apr 2019 08:48:16 +0000 Subject: Implement [dict getwithdefault] --- generic/tclDictObj.c | 66 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 66 insertions(+) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index baf96a8..c312242 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -34,6 +34,9 @@ static int DictFilterCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictGetCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +static int DictGetWithDefaultCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); static int DictIncrCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictInfoCmd(ClientData dummy, Tcl_Interp *interp, @@ -89,6 +92,7 @@ static const EnsembleImplMap implementationMap[] = { {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, + {"getwithdefault", DictGetWithDefaultCmd, NULL, NULL, NULL, 0 }, {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, @@ -1627,6 +1631,68 @@ DictGetCmd( /* *---------------------------------------------------------------------- * + * DictGetWithDefaultCmd -- + * + * This function implements the "dict getwithdefault" Tcl command. See + * the user documentation for details on what it does, and TIP#342 for + * the formal specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DictGetWithDefaultCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Obj *dictPtr, *keyPtr, *valuePtr, *defaultPtr; + Tcl_Obj *const *keyPath; + int numKeys; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...? key value"); + return TCL_ERROR; + } + + /* + * Give the bits of arguments names for clarity. + */ + + dictPtr = objv[1]; + keyPath = &objv[2]; + numKeys = objc - 4; + keyPtr = objv[objc - 2]; + defaultPtr = objv[objc - 1]; + + /* + * Implement the getting-with-default operation. + */ + + dictPtr = TclTraceDictPath(interp, dictPtr, numKeys, keyPath, + DICT_PATH_READ); + if (dictPtr == NULL) { + return TCL_ERROR; + } else if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) { + return TCL_ERROR; + } else if (valuePtr == NULL) { + Tcl_SetObjResult(interp, defaultPtr); + } else { + Tcl_SetObjResult(interp, valuePtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * DictReplaceCmd -- * * This function implements the "dict replace" Tcl command. See the user -- cgit v0.12 From 8d4509eafc4ae6d4ebc12d6b08180fca038bdf8f Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 1 Apr 2019 10:38:47 +0000 Subject: Add tests --- generic/tclDictObj.c | 9 ++++++--- tests/dict.test | 28 ++++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 3 deletions(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index c312242..75dcd09 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -1658,7 +1658,7 @@ DictGetWithDefaultCmd( int numKeys; if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...? key value"); + Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...? key default"); return TCL_ERROR; } @@ -1668,7 +1668,8 @@ DictGetWithDefaultCmd( dictPtr = objv[1]; keyPath = &objv[2]; - numKeys = objc - 4; + numKeys = objc - 4; /* Number of keys in keyPath; there's always + * one extra key afterwards too. */ keyPtr = objv[objc - 2]; defaultPtr = objv[objc - 1]; @@ -1677,9 +1678,11 @@ DictGetWithDefaultCmd( */ dictPtr = TclTraceDictPath(interp, dictPtr, numKeys, keyPath, - DICT_PATH_READ); + DICT_PATH_EXISTS); if (dictPtr == NULL) { return TCL_ERROR; + } else if (dictPtr == DICT_PATH_NON_EXISTENT) { + Tcl_SetObjResult(interp, defaultPtr); } else if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) { return TCL_ERROR; } else if (valuePtr == NULL) { diff --git a/tests/dict.test b/tests/dict.test index 904ec53..50e4db7 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -2047,6 +2047,34 @@ test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]} dict update item item item two two {} }} } {} + +test dict-26.1 {dict getwithdefault command} -body { + dict getwithdefault {a b} a c +} -result b +test dict-26.2 {dict getwithdefault command} -body { + dict getwithdefault {a b} b c +} -result c +test dict-26.3 {dict getwithdefault command} -body { + dict getwithdefault {a {b c}} a b d +} -result c +test dict-26.4 {dict getwithdefault command} -body { + dict getwithdefault {a {b c}} a c d +} -result d +test dict-26.5 {dict getwithdefault command} -body { + dict getwithdefault {a {b c}} b c d +} -result d +test dict-26.6 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault {a {b c d}} a b d +} -result {missing value to go with key} +test dict-26.7 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault +} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} +test dict-26.8 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault {} +} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} +test dict-26.9 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault {} {} +} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 325bbf57920315a1457d500d5fec8867c0e0744b Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 1 Apr 2019 10:51:33 +0000 Subject: Document --- doc/dict.n | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/doc/dict.n b/doc/dict.n index 1829768..12c9b1a 100644 --- a/doc/dict.n +++ b/doc/dict.n @@ -120,6 +120,19 @@ It is an error to attempt to retrieve a value for a key that is not present in the dictionary. .RE .TP +\fBdict getwithdefault \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR +.VS "8.7, TIP342" +This behaves the same as \fBdict get\fR (with at least one \fIkey\fR +argument), returning the value that the key path maps to in the +dictionary \fIdictionaryValue\fR, except that instead of producing an +error because the \fIkey\fR (or one of the \fIkey\fRs on the key path) +is absent, it returns the \fIdefault\fR argument instead. +.RS +.PP +Note that there must always be at least one \fIkey\fR provided. +.RE +.VE "8.7, TIP342" +.TP \fBdict incr \fIdictionaryVariable key \fR?\fIincrement\fR? . This adds the given increment value (an integer that defaults to 1 if -- cgit v0.12 From dab604e786914f07c525dfc438f35b3d860d8261 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 1 Apr 2019 16:15:45 +0000 Subject: typos --- doc/open.n | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/open.n b/doc/open.n index d128512..b0d9781 100644 --- a/doc/open.n +++ b/doc/open.n @@ -280,7 +280,7 @@ been consumed. This may slow down \fBclose\fR noticeably. .VS "8.7, TIP 160" (Unix only; Windows has the equivalent option on console channels). This option is used to query or change the input mode of the serial channel under -the assumption that it is talking to a termina, which controls how interactive +the assumption that it is talking to a terminal, which controls how interactive input from users is handled. The following values for \fIinputMode\fR are supported: .RS @@ -293,7 +293,7 @@ terminal editing capabilities enabled. \fBpassword\fR . indicates that non-echoing input should be used, with standard terminal -editing capabilitied enabled but no writing of typed characters to the +editing capabilities enabled but no writing of typed characters to the terminal (except for newlines). Some terminals may indicate this specially. .TP \fBraw\fR -- cgit v0.12 From d1069c7b4fe1fb124221c35f0671fc9ed238619e Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 3 Apr 2019 07:58:17 +0000 Subject: Import of TIP 312 implementation --- generic/tcl.decls | 6 + generic/tcl.h | 2 + generic/tclDecls.h | 7 + generic/tclLink.c | 927 ++++++++++++++++++++++++++++++++++++++++++-------- generic/tclStubInit.c | 1 + generic/tclTest.c | 120 +++++++ tests/link.test | 455 ++++++++++++++++++++++++- 7 files changed, 1373 insertions(+), 145 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index d404d25..f2ceeee 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2379,6 +2379,12 @@ 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 ----- # ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index c287a84..e34a609 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1093,6 +1093,8 @@ typedef struct Tcl_DString { #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 /* diff --git a/generic/tclDecls.h b/generic/tclDecls.h index c50b41f..e43923b 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1897,6 +1897,10 @@ EXTERN void Tcl_IncrRefCount(Tcl_Obj *objPtr); 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; @@ -2576,6 +2580,7 @@ typedef struct TclStubs { 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; @@ -3894,6 +3899,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DecrRefCount) /* 642 */ #define Tcl_IsShared \ (tclStubsPtr->tcl_IsShared) /* 643 */ +#define Tcl_LinkArray \ + (tclStubsPtr->tcl_LinkArray) /* 644 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclLink.c b/generic/tclLink.c index e7dcb8c..fe0785d 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -8,12 +8,14 @@ * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 2008 Rene Zaumseil * * 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 /* * For each linked variable there is a data structure of the following type, @@ -28,6 +30,9 @@ typedef struct Link { * actual variable may be aliased at that time * via upvar. */ char *addr; /* Location of C variable. */ + int bytes; /* Size of C variable array. This is 0 when + * single variables, and >0 used for array + * variables */ int type; /* Type of link (TCL_LINK_INT, etc.). */ union { char c; @@ -44,6 +49,19 @@ typedef struct Link { Tcl_WideUInt uw; float f; double d; + void *aryPtr; + char *pc; + unsigned char *puc; + int *pi; + unsigned int *pui; + short *ps; + unsigned short *pus; + long *pl; + unsigned long *pul; + Tcl_WideInt *pw; + Tcl_WideUInt *puw; + float *pf; + double *pd; } lastValue; /* Last known value of C variable; used to * avoid string conversions. */ int flags; /* Miscellaneous one-bit values; see below for @@ -57,10 +75,16 @@ typedef struct Link { * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar is * in progress for this variable, so trace * callbacks on the variable should be ignored. + * LINK_ALLOC_ADDR - 1 means linkPtr->addr was allocated on the + * heap. + * LINK_ALLOC_LAST - 1 means linkPtr->valueLast.p was allocated on + * the heap. */ #define LINK_READ_ONLY 1 #define LINK_BEING_UPDATED 2 +#define LINK_ALLOC_ADDR 4 +#define LINK_ALLOC_LAST 8 /* * Forward references to functions defined later in this file: @@ -69,9 +93,12 @@ typedef struct Link { static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); +static void LinkFree(Link *linkPtr); 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 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 @@ -144,11 +171,12 @@ Tcl_LinkVar( } else { linkPtr->flags = 0; } + linkPtr->bytes = 0; objPtr = ObjValue(linkPtr); if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(linkPtr->varName); - ckfree(linkPtr); + LinkFree(linkPtr); return TCL_ERROR; } code = Tcl_TraceVar2(interp, varName, NULL, @@ -156,7 +184,172 @@ Tcl_LinkVar( LinkTraceProc, linkPtr); if (code != TCL_OK) { Tcl_DecrRefCount(linkPtr->varName); - ckfree(linkPtr); + LinkFree(linkPtr); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LinkArray -- + * + * Link a C variable array to a Tcl variable so that changes to either + * one causes the other to change. + * + * Results: + * The return value is TCL_OK if everything went well or TCL_ERROR if an + * error occurred (the interp's result is also set after errors). + * + * Side effects: + * The value at *addr is linked to the Tcl variable "varName", using + * "type" to convert between string values for Tcl and binary values for + * *addr. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LinkArray( + Tcl_Interp *interp, /* Interpreter in which varName exists. */ + const char *varName, /* Name of a global variable in interp. */ + 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 and + * TCL_LINK_ALLOC OR'ed in. */ + int size) /* Size of C variable array, >1 if array */ +{ + Tcl_Obj *objPtr; + Link *linkPtr; + int code; + + if (size < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong array size given", -1)); + return TCL_ERROR; + } + + linkPtr = ckalloc(sizeof(Link)); + linkPtr->type = type & ~TCL_LINK_READ_ONLY; + if (type & TCL_LINK_READ_ONLY) { + linkPtr->flags = LINK_READ_ONLY; + } else { + linkPtr->flags = 0; + } + + switch (linkPtr->type) { + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + linkPtr->bytes = size * sizeof(int); + break; + case TCL_LINK_DOUBLE: + linkPtr->bytes = size * sizeof(double); + break; + case TCL_LINK_WIDE_INT: + linkPtr->bytes = size * sizeof(Tcl_WideInt); + break; + case TCL_LINK_WIDE_UINT: + linkPtr->bytes = size * sizeof(Tcl_WideUInt); + break; + case TCL_LINK_CHAR: + linkPtr->bytes = size * sizeof(char); + break; + case TCL_LINK_UCHAR: + linkPtr->bytes = size * sizeof(unsigned char); + break; + case TCL_LINK_SHORT: + linkPtr->bytes = size * sizeof(short); + break; + case TCL_LINK_USHORT: + linkPtr->bytes = size * sizeof(unsigned short); + break; + case TCL_LINK_UINT: + linkPtr->bytes = size * sizeof(unsigned int); + break; +#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.pc; + } + 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); + 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); + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj((int) linkPtr->addr)); } return code; } @@ -194,7 +387,7 @@ Tcl_UnlinkVar( TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); Tcl_DecrRefCount(linkPtr->varName); - ckfree(linkPtr); + LinkFree(linkPtr); } /* @@ -242,6 +435,44 @@ Tcl_UpdateLinkedVar( } } +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) +{ + return (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK + && GetInvalidWideFromObj(objPtr, widePtr) != TCL_OK); +} + +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 + return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK; + } +} + /* *---------------------------------------------------------------------- * @@ -273,13 +504,16 @@ LinkTraceProc( { Link *linkPtr = clientData; int changed; - size_t valueLength; + int valueLength; const char *value; char **pp; Tcl_Obj *valueObj; int valueInt; Tcl_WideInt valueWide; double valueDouble; + int objc; + Tcl_Obj **objv; + int i; /* * If the variable is being unset, then just re-create it (with a trace) @@ -289,7 +523,7 @@ LinkTraceProc( 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); @@ -316,51 +550,64 @@ LinkTraceProc( */ 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 = (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 = (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), @@ -392,131 +639,295 @@ LinkTraceProc( return (char *) "internal error: linked variable couldn't be read"; } + /* + * A couple of helper macros. + */ + +#define CheckHaveList(valueObj, underlyingType) \ + if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR \ + || objc != linkPtr->bytes / sizeof(underlyingType)) { \ + return (char *) "wrong dimension"; \ + } +#define InRange(lowerLimit, value, upperLimit) \ + ((value) >= (lowerLimit) && (value) <= (upperLimit)) + 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"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, int); + for (i=0; i < objc; i++) { + int *varPtr = &linkPtr->lastValue.pi[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"; + } + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } 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; } - 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"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, Tcl_WideInt); + for (i=0; i < objc; i++) { + Tcl_WideInt *varPtr = &linkPtr->lastValue.pw[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"; + } + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } 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; } - 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"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, double); + for (i=0; i < objc; i++) { + if (GetDouble(objv[i], &linkPtr->lastValue.pd[i])) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have real value"; } -#ifdef ACCEPT_NAN } - linkPtr->lastValue.d = irPtr->doubleValue; -#endif + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } 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; } - 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"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, int); + for (i=0; i < objc; i++) { + int *varPtr = &linkPtr->lastValue.pi[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"; + } + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } 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; } - 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"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, char); + 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.pc[i] = (char) valueInt; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + break; + } 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; } - 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"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, unsigned char); + 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.puc[i] = (unsigned char) valueInt; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } 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; } - 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"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, short); + 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.ps[i] = (short) valueInt; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } 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; } - 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"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, unsigned short); + 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.pus[i] = (unsigned short) valueInt; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } 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; } - 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"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, unsigned int); + 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.pui[i] = (unsigned int) valueWide; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } 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; } - 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"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, long); + 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.pl[i] = (long) valueWide; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + break; + } 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; } - 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"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, unsigned long); + for (i=0; i < objc; i++) { + if (GetWide(objv[i], &valueWide) + || !InRange(0, valueWide, ULONG_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned long value"; + } + linkPtr->lastValue.pul[i] = (unsigned long) valueWide; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } else { + if (GetWide(valueObj, &valueWide) + || !InRange(0, 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; } - LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide; break; #endif @@ -524,24 +935,54 @@ LinkTraceProc( /* * 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"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, Tcl_WideUInt); + for (i=0; i < objc; i++) { + if (GetWide(objv[i], &valueWide)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned wide int value"; + } + linkPtr->lastValue.puw[i] = (Tcl_WideUInt) valueWide; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } else { + if (GetWide(valueObj, &valueWide)) { + 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; } - 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"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, float); + for (i=0; i < objc; i++) { + if (GetDouble(objv[i], &valueDouble) + && !InRange(FLT_MIN, valueDouble, FLT_MAX) + && !TclIsInfinite(valueDouble) + && !TclIsNaN(valueDouble)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have float value"; + } + linkPtr->lastValue.pf[i] = (float) valueDouble; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } else { + if (GetDouble(valueObj, &valueDouble) + && !InRange(FLT_MIN, valueDouble, FLT_MAX) + && !TclIsInfinite(valueDouble) && !TclIsNaN(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; } - LinkedVar(float) = linkPtr->lastValue.f = (float)valueDouble; break; case TCL_LINK_STRING: @@ -553,6 +994,35 @@ LinkTraceProc( memcpy(*pp, value, valueLength); break; + 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; + } + break; + + 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; + } + break; + default: return (char *) "internal error: bad linked variable type"; } @@ -583,51 +1053,172 @@ ObjValue( { char *p; Tcl_Obj *resultObj; + int objc; + static Tcl_Obj **objv = NULL; // WTF? + int i; switch (linkPtr->type) { case TCL_LINK_INT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(int); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pi[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.i = LinkedVar(int); return Tcl_NewIntObj(linkPtr->lastValue.i); case TCL_LINK_WIDE_INT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(Tcl_WideInt); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pw[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.w = LinkedVar(Tcl_WideInt); return Tcl_NewWideIntObj(linkPtr->lastValue.w); case TCL_LINK_DOUBLE: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(double); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.pd[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.d = LinkedVar(double); return Tcl_NewDoubleObj(linkPtr->lastValue.d); case TCL_LINK_BOOLEAN: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes/sizeof(int); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.pi[i] != 0); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.i = LinkedVar(int); return Tcl_NewBooleanObj(linkPtr->lastValue.i); case TCL_LINK_CHAR: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(char); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pc[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.c = LinkedVar(char); return Tcl_NewIntObj(linkPtr->lastValue.c); case TCL_LINK_UCHAR: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(unsigned char); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.puc[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.uc = LinkedVar(unsigned char); return Tcl_NewIntObj(linkPtr->lastValue.uc); case TCL_LINK_SHORT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(short); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj*)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.ps[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.s = LinkedVar(short); return Tcl_NewIntObj(linkPtr->lastValue.s); case TCL_LINK_USHORT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(unsigned short); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj*)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pus[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.us = LinkedVar(unsigned short); return Tcl_NewIntObj(linkPtr->lastValue.us); case TCL_LINK_UINT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(unsigned int); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pui[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.ui = LinkedVar(unsigned int); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui); #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); + objc = linkPtr->bytes / sizeof(long); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pl[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.l = LinkedVar(long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l); case TCL_LINK_ULONG: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(unsigned long); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pul[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.ul = LinkedVar(unsigned long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul); #endif case TCL_LINK_FLOAT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(float); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.pf[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); case TCL_LINK_WIDE_UINT: - linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); /* * FIXME: represent as a bignum. */ + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(Tcl_WideUInt); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewWideIntObj((Tcl_WideInt) + linkPtr->lastValue.puw[i]); + } + return Tcl_NewListObj(objc, objv); + } + linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw); case TCL_LINK_STRING: p = LinkedVar(char *); @@ -637,6 +1228,25 @@ ObjValue( } 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.pc[linkPtr->bytes-1] = '\0'; + /* take care of proper string end */ + return Tcl_NewStringObj(linkPtr->lastValue.pc, linkPtr->bytes); + } + linkPtr->lastValue.c = '\0'; + return Tcl_NewStringObj(&linkPtr->lastValue.c, 1); + + case TCL_LINK_BINARY: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.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). @@ -696,6 +1306,7 @@ SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { * contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o" * (upperand lowercase). See bug [39f6304c2e]. */ + int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr) { @@ -730,6 +1341,7 @@ GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr) * 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) { @@ -751,6 +1363,35 @@ GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr) } /* + *---------------------------------------------------------------------- + * + * 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 diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 197ed84..2eb2259 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1628,6 +1628,7 @@ const TclStubs tclStubs = { Tcl_IncrRefCount, /* 641 */ Tcl_DecrRefCount, /* 642 */ Tcl_IsShared, /* 643 */ + Tcl_LinkArray, /* 644 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 349d935..f075500 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -308,6 +308,8 @@ 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[]); @@ -665,6 +667,7 @@ Tcltest_Init( 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); @@ -3283,6 +3286,123 @@ TestlinkCmd( /* *---------------------------------------------------------------------- * + * 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 Date: Wed, 3 Apr 2019 09:08:37 +0000 Subject: Some fixes. Still broken on 64-bit systems --- generic/tclLink.c | 134 ++++++++++-------- tests/link.test | 417 +++++++++++++++++++++++++----------------------------- 2 files changed, 269 insertions(+), 282 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index fe0785d..bc9e6be 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -32,7 +32,9 @@ typedef struct Link { char *addr; /* Location of C variable. */ int bytes; /* Size of C variable array. This is 0 when * single variables, and >0 used for array - * variables */ + * 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; @@ -49,7 +51,7 @@ typedef struct Link { Tcl_WideUInt uw; float f; double d; - void *aryPtr; + void *aryPtr; /* Generic array. */ char *pc; unsigned char *puc; int *pi; @@ -172,6 +174,7 @@ Tcl_LinkVar( 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) { @@ -234,6 +237,7 @@ Tcl_LinkArray( 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 { @@ -565,6 +569,7 @@ LinkTraceProc( changed = (LinkedVar(int) != linkPtr->lastValue.i); break; case TCL_LINK_DOUBLE: + /* FIXME: handle NaN */ changed = (LinkedVar(double) != linkPtr->lastValue.d); break; case TCL_LINK_WIDE_INT: @@ -597,6 +602,7 @@ LinkTraceProc( break; #endif case TCL_LINK_FLOAT: + /* FIXME: handle NaN */ changed = (LinkedVar(float) != linkPtr->lastValue.f); break; case TCL_LINK_STRING: @@ -645,7 +651,7 @@ LinkTraceProc( #define CheckHaveList(valueObj, underlyingType) \ if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR \ - || objc != linkPtr->bytes / sizeof(underlyingType)) { \ + || objc != linkPtr->numElems) { \ return (char *) "wrong dimension"; \ } #define InRange(lowerLimit, value, upperLimit) \ @@ -1052,117 +1058,124 @@ ObjValue( Link *linkPtr) /* Structure describing linked variable. */ { char *p; - Tcl_Obj *resultObj; - int objc; - static Tcl_Obj **objv = NULL; // WTF? + 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); - objc = linkPtr->bytes / sizeof(int); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pi[i]); } - return Tcl_NewListObj(objc, objv); + 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); - objc = linkPtr->bytes / sizeof(Tcl_WideInt); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pw[i]); } - return Tcl_NewListObj(objc, objv); + 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); - objc = linkPtr->bytes / sizeof(double); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.pd[i]); } - return Tcl_NewListObj(objc, objv); + 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); - objc = linkPtr->bytes/sizeof(int); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.pi[i] != 0); } - return Tcl_NewListObj(objc, objv); + 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); - objc = linkPtr->bytes / sizeof(char); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pc[i]); } - return Tcl_NewListObj(objc, objv); + 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); - objc = linkPtr->bytes / sizeof(unsigned char); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewIntObj(linkPtr->lastValue.puc[i]); } - return Tcl_NewListObj(objc, objv); + 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); - objc = linkPtr->bytes / sizeof(short); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj*)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewIntObj(linkPtr->lastValue.ps[i]); } - return Tcl_NewListObj(objc, objv); + 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); - objc = linkPtr->bytes / sizeof(unsigned short); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj*)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pus[i]); } - return Tcl_NewListObj(objc, objv); + 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); - objc = linkPtr->bytes / sizeof(unsigned int); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pui[i]); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.ui = LinkedVar(unsigned int); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui); @@ -1170,24 +1183,26 @@ ObjValue( case TCL_LINK_LONG: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objc = linkPtr->bytes / sizeof(long); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pl[i]); } - return Tcl_NewListObj(objc, objv); + 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); - objc = linkPtr->bytes / sizeof(unsigned long); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pul[i]); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.ul = LinkedVar(unsigned long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul); @@ -1195,12 +1210,13 @@ ObjValue( case TCL_LINK_FLOAT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objc = linkPtr->bytes / sizeof(float); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.pf[i]); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); @@ -1210,16 +1226,18 @@ ObjValue( */ if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objc = linkPtr->bytes / sizeof(Tcl_WideUInt); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.puw[i]); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw); + case TCL_LINK_STRING: p = LinkedVar(char *); if (p == NULL) { diff --git a/tests/link.test b/tests/link.test index 1f40189..e0f7e3c 100644 --- a/tests/link.test +++ b/tests/link.test @@ -400,31 +400,27 @@ test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { } msg] $msg $int } {0 {} 47} -test link-9.1 {linkarray usage messages} { +test link-9.1 {linkarray usage messages} -setup { set mylist [list] - catch {testlinkarray} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {testlinkarray x} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {testlinkarray update} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {testlinkarray remove} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {testlinkarray create} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {testlinkarray create xx 1 my} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {testlinkarray create char* 0 my} my(msg) - lappend mylist $my(msg) - unset my(msg) +} -body { + catch {testlinkarray} msg + lappend mylist $msg + catch {testlinkarray x} msg + lappend mylist $msg + catch {testlinkarray update} msg + lappend mylist $msg + catch {testlinkarray remove} msg + lappend mylist $msg + catch {testlinkarray create} msg + lappend mylist $msg + catch {testlinkarray create xx 1 my} msg + lappend mylist $msg + catch {testlinkarray create char* 0 my} msg + lappend mylist $msg join $mylist "\n" -} {wrong # args: should be "testlinkarray option args" +} -cleanup { + unset -nocomplain my +} -result {wrong # args: should be "testlinkarray option args" bad option "x": must be update, remove, or create @@ -432,93 +428,87 @@ wrong # args: should be "testlinkarray create ?-readonly? type size name ?addres bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, char*, or binary wrong array size given} -test link-10.1 {linkarray char*} { +test link-10.1 {linkarray char*} -setup { set mylist [list] +} -body { testlinkarray create char* 1 ::my(var) lappend mylist [set ::my(var) ""] - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create char* 4 ::my(var) set ::my(var) x - catch {set ::my(var) xyzz} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) xyzz} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create -r char* 4 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} { +} -cleanup { + unset -nocomplain my +} -result { can't set "::my(var)": wrong size of char* value can't set "::my(var)": wrong size of char* value can't set "::my(var)": linked variable is read-only} -test link-11.1 {linkarray char} { +test link-11.1 {linkarray char} -setup { set mylist [list] +} -body { testlinkarray create char 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1234} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1234} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create char 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r char 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have char value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have char value 120 can't set "::my(var)": variable must have char value can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-12.1 {linkarray unsigned char} { +test link-12.1 {linkarray unsigned char} -setup { set mylist [list] +} -body { testlinkarray create uchar 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1234} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {set ::my(var) -1} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1234} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create uchar 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r uchar 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have unsigned char value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned char value 120 can't set "::my(var)": variable must have unsigned char value can't set "::my(var)": variable must have unsigned char value @@ -526,67 +516,62 @@ can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-13.1 {linkarray short} { +test link-13.1 {linkarray short} -setup { set mylist [list] +} -body { testlinkarray create short 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 123456} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 123456} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create short 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r short 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have short value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have short value 120 can't set "::my(var)": variable must have short value can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-14.1 {linkarray unsigned short} { +test link-14.1 {linkarray unsigned short} -setup { set mylist [list] +} -body { testlinkarray create ushort 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 123456} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {set ::my(var) -1} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 123456} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create ushort 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r ushort 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have unsigned short value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned short value 120 can't set "::my(var)": variable must have unsigned short value can't set "::my(var)": variable must have unsigned short value @@ -594,67 +579,62 @@ can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-15.1 {linkarray int} { +test link-15.1 {linkarray int} -setup { set mylist [list] +} -body { testlinkarray create int 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e3} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1e3} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create int 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r int 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have integer value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have integer value 120 can't set "::my(var)": variable must have integer value can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-16.1 {linkarray unsigned int} { +test link-16.1 {linkarray unsigned int} -setup { set mylist [list] +} -body { testlinkarray create uint 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e33} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {set ::my(var) -1} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1e33} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create uint 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r uint 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have unsigned int value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned int value 120 can't set "::my(var)": variable must have unsigned int value can't set "::my(var)": variable must have unsigned int value @@ -662,135 +642,125 @@ can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-17.1 {linkarray long} { +test link-17.1 {linkarray long} -setup { set mylist [list] +} -body { testlinkarray create long 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e33} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1e33} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create long 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r long 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have long value +} -cleanup { + unset -nocomplain my +} -match glob -result {can't set "::my(var)": variable must have * value 120 -can't set "::my(var)": variable must have long value +can't set "::my(var)": variable must have * value can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-18.1 {linkarray unsigned long} { +test link-18.1 {linkarray unsigned long} -setup { set mylist [list] +} -body { testlinkarray create ulong 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e33} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {set ::my(var) -1} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1e33} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create ulong 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r ulong 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have unsigned long value +} -cleanup { + unset -nocomplain my +} -match glob -result {can't set "::my(var)": variable must have unsigned * value 120 -can't set "::my(var)": variable must have unsigned long value -can't set "::my(var)": variable must have unsigned long value +can't set "::my(var)": variable must have unsigned * value +can't set "::my(var)": variable must have unsigned * value can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-19.1 {linkarray wide} { +test link-19.1 {linkarray wide} -setup { set mylist [list] +} -body { testlinkarray create wide 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e33} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1e33} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create wide 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r wide 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have wide integer value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have wide integer value 120 can't set "::my(var)": variable must have wide integer value can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-20.1 {linkarray unsigned wide} { +test link-20.1 {linkarray unsigned wide} -setup { set mylist [list] +} -body { testlinkarray create uwide 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e33} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {set ::my(var) -1} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1e33} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create uwide 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r uwide 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have unsigned wide int value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned wide int value 120 can't set "::my(var)": variable must have unsigned wide int value can't set "::my(var)": variable must have unsigned wide int value @@ -798,52 +768,51 @@ can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-21.1 {linkarray string} { +test link-21.1 {linkarray string} -setup { set mylist [list] +} -body { testlinkarray create string 1 ::my(var) lappend mylist [set ::my(var) ""] lappend mylist [set ::my(var) "xyz"] lappend mylist $::my(var) testlinkarray remove ::my(var) testlinkarray create -r string 4 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} { +} -cleanup { + unset -nocomplain my +} -result { xyz xyz can't set "::my(var)": linked variable is read-only} -test link-22.1 {linkarray binary} { +test link-22.1 {linkarray binary} -setup { set mylist [list] +} -body { testlinkarray create binary 1 ::my(var) set ::my(var) x - catch {set ::my(var) xy} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) xy} msg + lappend mylist $msg lappend mylist $::my(var) testlinkarray remove ::my(var) testlinkarray create binary 4 ::my(var) - catch {set ::my(var) abc} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {set ::my(var) abcde} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) abc} msg + lappend mylist $msg + catch {set ::my(var) abcde} msg + lappend mylist $msg set ::my(var) abcd lappend mylist $::my(var) testlinkarray remove ::my(var) testlinkarray create -r binary 4 ::my(var) - catch {set ::my(var) xyzv} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) xyzv} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": wrong size of binary value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": wrong size of binary value x can't set "::my(var)": wrong size of binary value can't set "::my(var)": wrong size of binary value -- cgit v0.12 From 515da61c9dd1ca932c9bd1cb0c63e49ed26527d0 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 3 Apr 2019 09:36:33 +0000 Subject: refactor; mark broken tests as broken --- generic/tclLink.c | 215 ++++++++++++++++++++++++++---------------------------- tests/link.test | 6 +- 2 files changed, 106 insertions(+), 115 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index bc9e6be..8ba02dd 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -52,18 +52,18 @@ typedef struct Link { float f; double d; void *aryPtr; /* Generic array. */ - char *pc; - unsigned char *puc; - int *pi; - unsigned int *pui; - short *ps; - unsigned short *pus; - long *pl; - unsigned long *pul; - Tcl_WideInt *pw; - Tcl_WideUInt *puw; - float *pf; - double *pd; + 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 @@ -297,7 +297,7 @@ Tcl_LinkArray( if (addr == NULL) { linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes); linkPtr->flags |= LINK_ALLOC_LAST; - addr = (char *) &linkPtr->lastValue.pc; + addr = (char *) &linkPtr->lastValue.cPtr; } break; case TCL_LINK_CHARS: @@ -646,23 +646,73 @@ LinkTraceProc( } /* - * A couple of helper macros. + * Special cases. */ -#define CheckHaveList(valueObj, underlyingType) \ - if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR \ - || objc != linkPtr->numElems) { \ - return (char *) "wrong dimension"; \ + 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; } -#define InRange(lowerLimit, value, upperLimit) \ + + /* + * 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) { - CheckHaveList(valueObj, int); for (i=0; i < objc; i++) { - int *varPtr = &linkPtr->lastValue.pi[i]; + int *varPtr = &linkPtr->lastValue.iPtr[i]; if (GetInt(objv[i], varPtr)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, @@ -670,7 +720,6 @@ LinkTraceProc( return (char *) "variable array must have integer values"; } } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { int *varPtr = &linkPtr->lastValue.i; @@ -685,9 +734,8 @@ LinkTraceProc( case TCL_LINK_WIDE_INT: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, Tcl_WideInt); for (i=0; i < objc; i++) { - Tcl_WideInt *varPtr = &linkPtr->lastValue.pw[i]; + Tcl_WideInt *varPtr = &linkPtr->lastValue.wPtr[i]; if (GetWide(objv[i], varPtr)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, @@ -696,7 +744,6 @@ LinkTraceProc( "variable array must have wide integer value"; } } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { Tcl_WideInt *varPtr = &linkPtr->lastValue.w; @@ -711,15 +758,13 @@ LinkTraceProc( case TCL_LINK_DOUBLE: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, double); for (i=0; i < objc; i++) { - if (GetDouble(objv[i], &linkPtr->lastValue.pd[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"; } } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { double *varPtr = &linkPtr->lastValue.d; @@ -734,9 +779,8 @@ LinkTraceProc( case TCL_LINK_BOOLEAN: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, int); for (i=0; i < objc; i++) { - int *varPtr = &linkPtr->lastValue.pi[i]; + int *varPtr = &linkPtr->lastValue.iPtr[i]; if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, @@ -744,7 +788,6 @@ LinkTraceProc( return (char *) "variable array must have boolean value"; } } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { int *varPtr = &linkPtr->lastValue.i; @@ -759,7 +802,6 @@ LinkTraceProc( case TCL_LINK_CHAR: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, char); for (i=0; i < objc; i++) { if (GetInt(objv[i], &valueInt) || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { @@ -767,10 +809,8 @@ LinkTraceProc( ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have char value"; } - linkPtr->lastValue.pc[i] = (char) valueInt; + linkPtr->lastValue.cPtr[i] = (char) valueInt; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); - break; } else { if (GetInt(valueObj, &valueInt) || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { @@ -784,7 +824,6 @@ LinkTraceProc( case TCL_LINK_UCHAR: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, unsigned char); for (i=0; i < objc; i++) { if (GetInt(objv[i], &valueInt) || !InRange(0, valueInt, UCHAR_MAX)) { @@ -793,9 +832,8 @@ LinkTraceProc( return (char *) "variable array must have unsigned char value"; } - linkPtr->lastValue.puc[i] = (unsigned char) valueInt; + linkPtr->lastValue.ucPtr[i] = (unsigned char) valueInt; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { if (GetInt(valueObj, &valueInt) || !InRange(0, valueInt, UCHAR_MAX)) { @@ -810,7 +848,6 @@ LinkTraceProc( case TCL_LINK_SHORT: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, short); for (i=0; i < objc; i++) { if (GetInt(objv[i], &valueInt) || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { @@ -818,9 +855,8 @@ LinkTraceProc( ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have short value"; } - linkPtr->lastValue.ps[i] = (short) valueInt; + linkPtr->lastValue.sPtr[i] = (short) valueInt; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { if (GetInt(valueObj, &valueInt) || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { @@ -834,7 +870,6 @@ LinkTraceProc( case TCL_LINK_USHORT: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, unsigned short); for (i=0; i < objc; i++) { if (GetInt(objv[i], &valueInt) || !InRange(0, valueInt, USHRT_MAX)) { @@ -843,9 +878,8 @@ LinkTraceProc( return (char *) "variable array must have unsigned short value"; } - linkPtr->lastValue.pus[i] = (unsigned short) valueInt; + linkPtr->lastValue.usPtr[i] = (unsigned short) valueInt; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { if (GetInt(valueObj, &valueInt) || !InRange(0, valueInt, USHRT_MAX)) { @@ -860,7 +894,6 @@ LinkTraceProc( case TCL_LINK_UINT: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, unsigned int); for (i=0; i < objc; i++) { if (GetWide(objv[i], &valueWide) || !InRange(0, valueWide, UINT_MAX)) { @@ -869,9 +902,8 @@ LinkTraceProc( return (char *) "variable array must have unsigned int value"; } - linkPtr->lastValue.pui[i] = (unsigned int) valueWide; + linkPtr->lastValue.uiPtr[i] = (unsigned int) valueWide; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { if (GetWide(valueObj, &valueWide) || !InRange(0, valueWide, UINT_MAX)) { @@ -887,7 +919,6 @@ LinkTraceProc( #if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, long); for (i=0; i < objc; i++) { if (GetWide(objv[i], &valueWide) || !InRange(LONG_MIN, valueWide, LONG_MAX)) { @@ -895,10 +926,8 @@ LinkTraceProc( ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have long value"; } - linkPtr->lastValue.pl[i] = (long) valueWide; + linkPtr->lastValue.lPtr[i] = (long) valueWide; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); - break; } else { if (GetWide(valueObj, &valueWide) || !InRange(LONG_MIN, valueWide, LONG_MAX)) { @@ -912,7 +941,6 @@ LinkTraceProc( case TCL_LINK_ULONG: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, unsigned long); for (i=0; i < objc; i++) { if (GetWide(objv[i], &valueWide) || !InRange(0, valueWide, ULONG_MAX)) { @@ -921,9 +949,8 @@ LinkTraceProc( return (char *) "variable array must have unsigned long value"; } - linkPtr->lastValue.pul[i] = (unsigned long) valueWide; + linkPtr->lastValue.ulPtr[i] = (unsigned long) valueWide; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { if (GetWide(valueObj, &valueWide) || !InRange(0, valueWide, ULONG_MAX)) { @@ -942,7 +969,6 @@ LinkTraceProc( * FIXME: represent as a bignum. */ if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, Tcl_WideUInt); for (i=0; i < objc; i++) { if (GetWide(objv[i], &valueWide)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, @@ -950,9 +976,8 @@ LinkTraceProc( return (char *) "variable array must have unsigned wide int value"; } - linkPtr->lastValue.puw[i] = (Tcl_WideUInt) valueWide; + linkPtr->lastValue.uwPtr[i] = (Tcl_WideUInt) valueWide; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { if (GetWide(valueObj, &valueWide)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, @@ -966,7 +991,6 @@ LinkTraceProc( case TCL_LINK_FLOAT: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, float); for (i=0; i < objc; i++) { if (GetDouble(objv[i], &valueDouble) && !InRange(FLT_MIN, valueDouble, FLT_MAX) @@ -976,9 +1000,8 @@ LinkTraceProc( ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have float value"; } - linkPtr->lastValue.pf[i] = (float) valueDouble; + linkPtr->lastValue.fPtr[i] = (float) valueDouble; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { if (GetDouble(valueObj, &valueDouble) && !InRange(FLT_MIN, valueDouble, FLT_MAX) @@ -991,47 +1014,13 @@ LinkTraceProc( } 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; - - 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; - } - break; - - 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; - } - 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; } @@ -1067,7 +1056,7 @@ ObjValue( 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.pi[i]); + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.iPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1080,7 +1069,7 @@ ObjValue( 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.pw[i]); + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.wPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1093,7 +1082,7 @@ ObjValue( 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.pd[i]); + objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.dPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1106,7 +1095,7 @@ ObjValue( 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.pi[i] != 0); + objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.iPtr[i] != 0); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1119,7 +1108,7 @@ ObjValue( 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.pc[i]); + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.cPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1132,7 +1121,7 @@ ObjValue( 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.puc[i]); + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.ucPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1145,7 +1134,7 @@ ObjValue( 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.ps[i]); + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.sPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1158,7 +1147,7 @@ ObjValue( 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.pus[i]); + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.usPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1171,7 +1160,7 @@ ObjValue( 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.pui[i]); + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.uiPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1185,7 +1174,7 @@ ObjValue( 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.pl[i]); + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.lPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1198,7 +1187,7 @@ ObjValue( 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.pul[i]); + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.ulPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1212,7 +1201,7 @@ ObjValue( 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.pf[i]); + objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.fPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1229,7 +1218,7 @@ ObjValue( objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewWideIntObj((Tcl_WideInt) - linkPtr->lastValue.puw[i]); + linkPtr->lastValue.uwPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1249,9 +1238,9 @@ ObjValue( case TCL_LINK_CHARS: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - linkPtr->lastValue.pc[linkPtr->bytes-1] = '\0'; + linkPtr->lastValue.cPtr[linkPtr->bytes-1] = '\0'; /* take care of proper string end */ - return Tcl_NewStringObj(linkPtr->lastValue.pc, linkPtr->bytes); + return Tcl_NewStringObj(linkPtr->lastValue.cPtr, linkPtr->bytes); } linkPtr->lastValue.c = '\0'; return Tcl_NewStringObj(&linkPtr->lastValue.c, 1); diff --git a/tests/link.test b/tests/link.test index e0f7e3c..0a865d8 100644 --- a/tests/link.test +++ b/tests/link.test @@ -672,9 +672,10 @@ can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-18.1 {linkarray unsigned long} -setup { +test link-18.1 {linkarray unsigned long} -constraints knownBug -setup { set mylist [list] } -body { + # Implementation needs to use bignums on 64-bit platforms testlinkarray create ulong 1 ::my(var) catch {set ::my(var) x} msg lappend mylist $msg @@ -735,9 +736,10 @@ can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-20.1 {linkarray unsigned wide} -setup { +test link-20.1 {linkarray unsigned wide} -constraints knownBug -setup { set mylist [list] } -body { + # Implementation needs to use bignums testlinkarray create uwide 1 ::my(var) catch {set ::my(var) x} msg lappend mylist $msg -- cgit v0.12 From cbb2ececd3a0056acbb5ecdcfa39d7b035ca9b1c Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 3 Apr 2019 12:22:07 +0000 Subject: Docs --- doc/LinkVar.3 | 120 +++++++++++++++++++++++++++++++++++++++++++---------- generic/tcl.decls | 2 +- generic/tclDecls.h | 4 +- generic/tclLink.c | 4 +- 4 files changed, 102 insertions(+), 28 deletions(-) diff --git a/doc/LinkVar.3 b/doc/LinkVar.3 index c80d30d..a38610b 100644 --- a/doc/LinkVar.3 +++ b/doc/LinkVar.3 @@ -9,7 +9,7 @@ .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 @@ -17,27 +17,49 @@ Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variab 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. .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. \fBTCL_LINK_ALLOC\fR may also be OR'ed in +to tell Tcl to manage the storage for the array in the variable (that is, the +C variable is technically a pointer to an array, not the array itself). +.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 @@ -52,12 +74,22 @@ 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 \fBTCL_LINK_ALLOC\fR bit), it writes the address that +it allocated to the Tcl interpreter result in addition to storing the +location of the array in the C variable pointed to by \fIaddr\fR. +.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 @@ -66,7 +98,8 @@ 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 @@ -76,16 +109,31 @@ 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 @@ -93,9 +141,24 @@ 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 @@ -104,7 +167,8 @@ 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 @@ -114,7 +178,8 @@ 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 @@ -123,7 +188,8 @@ 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 @@ -133,7 +199,8 @@ 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 @@ -142,7 +209,8 @@ 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 @@ -152,7 +220,9 @@ 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 @@ -162,9 +232,10 @@ 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); @@ -175,7 +246,8 @@ 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 @@ -188,6 +260,7 @@ 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. @@ -197,6 +270,7 @@ 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 diff --git a/generic/tcl.decls b/generic/tcl.decls index f2ceeee..7d3b535 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -667,7 +667,7 @@ declare 186 { 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) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index e43923b..3b67796 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -597,7 +597,7 @@ 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); @@ -2123,7 +2123,7 @@ typedef struct TclStubs { 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 */ diff --git a/generic/tclLink.c b/generic/tclLink.c index 8ba02dd..456f868 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -29,7 +29,7 @@ typedef struct Link { * 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. */ @@ -137,7 +137,7 @@ 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. */ -- cgit v0.12 From c4cf1a4e2ced76f5b42e1f6467a252e101768b3f Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 4 Apr 2019 08:52:43 +0000 Subject: Split up tests to get better focus on what is being tested --- tests/link.test | 357 ++++++++++++++++++++++++++++++++------------------------ 1 file changed, 205 insertions(+), 152 deletions(-) diff --git a/tests/link.test b/tests/link.test index 0a865d8..97bd631 100644 --- a/tests/link.test +++ b/tests/link.test @@ -400,33 +400,27 @@ test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { } msg] $msg $int } {0 {} 47} -test link-9.1 {linkarray usage messages} -setup { - set mylist [list] -} -body { - catch {testlinkarray} msg - lappend mylist $msg - catch {testlinkarray x} msg - lappend mylist $msg - catch {testlinkarray update} msg - lappend mylist $msg - catch {testlinkarray remove} msg - lappend mylist $msg - catch {testlinkarray create} msg - lappend mylist $msg - catch {testlinkarray create xx 1 my} msg - lappend mylist $msg - catch {testlinkarray create char* 0 my} msg - lappend mylist $msg - join $mylist "\n" -} -cleanup { - unset -nocomplain my -} -result {wrong # args: should be "testlinkarray option args" -bad option "x": must be update, remove, or create - - -wrong # args: should be "testlinkarray create ?-readonly? type size name ?address?" -bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, char*, or binary -wrong array size given} +test link-9.1 {linkarray usage messages} -returnCodes error -body { + testlinkarray +} -result {wrong # args: should be "testlinkarray option args"} +test link-9.2 {linkarray usage messages} -returnCodes error -body { + testlinkarray x +} -result {bad option "x": must be update, remove, or create} +test link-9.3 {linkarray usage messages} -body { + testlinkarray update +} -result {} +test link-9.4 {linkarray usage messages} -body { + testlinkarray remove +} -result {} +test link-9.5 {linkarray usage messages} -returnCodes error -body { + testlinkarray create +} -result {wrong # args: should be "testlinkarray create ?-readonly? type size name ?address?"} +test link-9.6 {linkarray usage messages} -returnCodes error -body { + testlinkarray create xx 1 my +} -result {bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, char*, or binary} +test link-9.7 {linkarray usage messages} -returnCodes error -body { + testlinkarray create char* 0 my +} -result {wrong array size given} test link-10.1 {linkarray char*} -setup { set mylist [list] @@ -435,23 +429,27 @@ test link-10.1 {linkarray char*} -setup { lappend mylist [set ::my(var) ""] catch {set ::my(var) x} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{} {can't set "::my(var)": wrong size of char* value}} +test link-10.2 {linkarray char*} -body { testlinkarray create char* 4 ::my(var) set ::my(var) x catch {set ::my(var) xyzz} msg - lappend mylist $msg + return $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": wrong size of char* value} +test link-10.3 {linkarray char*} -body { testlinkarray create -r char* 4 ::my(var) catch {set ::my(var) x} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result { -can't set "::my(var)": wrong size of char* value -can't set "::my(var)": wrong size of char* value -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-11.1 {linkarray char} -setup { set mylist [list] @@ -462,26 +460,30 @@ test link-11.1 {linkarray char} -setup { lappend mylist [set ::my(var) 120] catch {set ::my(var) 1234} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have char value} 120 {can't set "::my(var)": variable must have char value}} +test link-11.2 {linkarray char} -setup { + set mylist [list] +} -body { testlinkarray create char 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-11.3 {linkarray char} -body { testlinkarray create -r char 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have char value -120 -can't set "::my(var)": variable must have char value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-12.1 {linkarray unsigned char} -setup { set mylist [list] @@ -494,27 +496,30 @@ test link-12.1 {linkarray unsigned char} -setup { lappend mylist $msg catch {set ::my(var) -1} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned char value} 120 {can't set "::my(var)": variable must have unsigned char value} {can't set "::my(var)": variable must have unsigned char value}} +test link-12.2 {linkarray unsigned char} -setup { + set mylist [list] +} -body { testlinkarray create uchar 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-12.3 {linkarray unsigned char} -body { testlinkarray create -r uchar 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have unsigned char value -120 -can't set "::my(var)": variable must have unsigned char value -can't set "::my(var)": variable must have unsigned char value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-13.1 {linkarray short} -setup { set mylist [list] @@ -525,26 +530,30 @@ test link-13.1 {linkarray short} -setup { lappend mylist [set ::my(var) 120] catch {set ::my(var) 123456} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have short value} 120 {can't set "::my(var)": variable must have short value}} +test link-13.2 {linkarray short} -setup { + set mylist [list] +} -body { testlinkarray create short 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-13.3 {linkarray short} -body { testlinkarray create -r short 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have short value -120 -can't set "::my(var)": variable must have short value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-14.1 {linkarray unsigned short} -setup { set mylist [list] @@ -557,27 +566,30 @@ test link-14.1 {linkarray unsigned short} -setup { lappend mylist $msg catch {set ::my(var) -1} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned short value} 120 {can't set "::my(var)": variable must have unsigned short value} {can't set "::my(var)": variable must have unsigned short value}} +test link-14.2 {linkarray unsigned short} -setup { + set mylist [list] +} -body { testlinkarray create ushort 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-14.3 {linkarray unsigned short} -body { testlinkarray create -r ushort 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have unsigned short value -120 -can't set "::my(var)": variable must have unsigned short value -can't set "::my(var)": variable must have unsigned short value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-15.1 {linkarray int} -setup { set mylist [list] @@ -588,26 +600,30 @@ test link-15.1 {linkarray int} -setup { lappend mylist [set ::my(var) 120] catch {set ::my(var) 1e3} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have integer value} 120 {can't set "::my(var)": variable must have integer value}} +test link-15.2 {linkarray int} -setup { + set mylist [list] +} -body { testlinkarray create int 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-15.3 {linkarray int} -body { testlinkarray create -r int 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have integer value -120 -can't set "::my(var)": variable must have integer value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-16.1 {linkarray unsigned int} -setup { set mylist [list] @@ -620,27 +636,30 @@ test link-16.1 {linkarray unsigned int} -setup { lappend mylist $msg catch {set ::my(var) -1} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain ::my +} -result {{can't set "::my(var)": variable must have unsigned int value} 120 {can't set "::my(var)": variable must have unsigned int value} {can't set "::my(var)": variable must have unsigned int value}} +test link-16.2 {linkarray unsigned int} -setup { + set mylist [list] +} -body { testlinkarray create uint 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain ::my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-16.3 {linkarray unsigned int} -body { testlinkarray create -r uint 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have unsigned int value -120 -can't set "::my(var)": variable must have unsigned int value -can't set "::my(var)": variable must have unsigned int value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-17.1 {linkarray long} -setup { set mylist [list] @@ -651,60 +670,74 @@ test link-17.1 {linkarray long} -setup { lappend mylist [set ::my(var) 120] catch {set ::my(var) 1e33} msg lappend mylist $msg +} -match glob -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have * value} 120 {can't set "::my(var)": variable must have * value}} +test link-17.2 {linkarray long} -setup { + set mylist [list] +} -body { testlinkarray create long 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-17.3 {linkarray long} -body { testlinkarray create -r long 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -match glob -result {can't set "::my(var)": variable must have * value -120 -can't set "::my(var)": variable must have * value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} -test link-18.1 {linkarray unsigned long} -constraints knownBug -setup { +test link-18.1 {linkarray unsigned long} -setup { set mylist [list] } -body { - # Implementation needs to use bignums on 64-bit platforms testlinkarray create ulong 1 ::my(var) catch {set ::my(var) x} msg lappend mylist $msg lappend mylist [set ::my(var) 120] catch {set ::my(var) 1e33} msg lappend mylist $msg +} -match glob -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned * value} 120 {can't set "::my(var)": variable must have unsigned * value}} +test link-18.2 {linkarray unsigned long} -constraints knownBug -body { + # BUG: Implementation needs to use bignums on 64-bit platforms + testlinkarray create ulong 1 ::my(var) + set ::my(var) 120 catch {set ::my(var) -1} msg - lappend mylist $msg + return $msg +} -match glob -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned * value} +test link-18.3 {linkarray unsigned long} -setup { + set mylist [list] +} -body { testlinkarray create ulong 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-18.4 {linkarray unsigned long} -body { testlinkarray create -r ulong 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -match glob -result {can't set "::my(var)": variable must have unsigned * value -120 -can't set "::my(var)": variable must have unsigned * value -can't set "::my(var)": variable must have unsigned * value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-19.1 {linkarray wide} -setup { set mylist [list] @@ -715,60 +748,76 @@ test link-19.1 {linkarray wide} -setup { lappend mylist [set ::my(var) 120] catch {set ::my(var) 1e33} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have wide integer value} 120 {can't set "::my(var)": variable must have wide integer value}} +test link-19.2 {linkarray wide} -setup { + set mylist [list] +} -body { testlinkarray create wide 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-19.3 {linkarray wide} -body { testlinkarray create -r wide 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have wide integer value -120 -can't set "::my(var)": variable must have wide integer value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} -test link-20.1 {linkarray unsigned wide} -constraints knownBug -setup { +test link-20.1 {linkarray unsigned wide} -setup { set mylist [list] } -body { - # Implementation needs to use bignums testlinkarray create uwide 1 ::my(var) catch {set ::my(var) x} msg lappend mylist $msg lappend mylist [set ::my(var) 120] catch {set ::my(var) 1e33} msg lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned wide int value} 120 {can't set "::my(var)": variable must have unsigned wide int value}} +test link-20.2 {linkarray unsigned wide} -constraints knownBug -setup { + set mylist [list] +} -body { + # BUG: Implementation needs to use bignums + testlinkarray create uwide 1 ::my(var) + set ::my(var) 120 catch {set ::my(var) -1} msg - lappend mylist $msg + return $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned wide int value} +test link-20.3 {linkarray unsigned wide} -setup { + set mylist [list] +} -body { testlinkarray create uwide 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-20.4 {linkarray unsigned wide} -body { testlinkarray create -r uwide 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have unsigned wide int value -120 -can't set "::my(var)": variable must have unsigned wide int value -can't set "::my(var)": variable must have unsigned wide int value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-21.1 {linkarray string} -setup { set mylist [list] @@ -777,18 +826,18 @@ test link-21.1 {linkarray string} -setup { lappend mylist [set ::my(var) ""] lappend mylist [set ::my(var) "xyz"] lappend mylist $::my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{} xyz xyz} +test link-21.2 {linkarray string} -body { testlinkarray create -r string 4 ::my(var) catch {set ::my(var) x} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result { -xyz -xyz -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-22.1 {linkarray binary} -setup { set mylist [list] @@ -798,7 +847,13 @@ test link-22.1 {linkarray binary} -setup { catch {set ::my(var) xy} msg lappend mylist $msg lappend mylist $::my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong size of binary value} x} +test link-22.2 {linkarray binary} -setup { + set mylist [list] +} -body { testlinkarray create binary 4 ::my(var) catch {set ::my(var) abc} msg lappend mylist $msg @@ -806,20 +861,18 @@ test link-22.1 {linkarray binary} -setup { lappend mylist $msg set ::my(var) abcd lappend mylist $::my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong size of binary value} {can't set "::my(var)": wrong size of binary value} abcd} +test link-22.3 {linkarray binary} -body { testlinkarray create -r binary 4 ::my(var) catch {set ::my(var) xyzv} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": wrong size of binary value -x -can't set "::my(var)": wrong size of binary value -can't set "::my(var)": wrong size of binary value -abcd -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0} catch {testlink delete} -- cgit v0.12 From 3c6834dbe3162f2682b83b0539451b4526dcd2c2 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 4 Apr 2019 22:48:15 +0000 Subject: Fix unsigned wide linking. --- generic/tclLink.c | 106 ++++++++++++++++++++++++++++++++++++++++-------------- tests/link.test | 8 ++--- 2 files changed, 82 insertions(+), 32 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index 456f868..39ddbdd 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -15,6 +15,7 @@ */ #include "tclInt.h" +#include "tommath.h" #include /* @@ -458,6 +459,45 @@ GetWide( } static inline int +GetUWide( + Tcl_Obj *objPtr, + Tcl_WideUInt *uwidePtr) +{ + Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr; + ClientData clientData; + int type; + + if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { + if (type == TCL_NUMBER_BIG) { + mp_int num; + Tcl_WideUInt scratch, value = 0; + unsigned long numBytes = sizeof(Tcl_WideUInt); + unsigned char *bytes = (unsigned char *) &scratch; + + Tcl_GetBignumFromObj(NULL, objPtr, &num); + if (num.sign) { + return 1; + } + if (mp_to_unsigned_bin_n(&num, bytes, &numBytes) != MP_OKAY) { + return 1; + } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + *uwidePtr = value; + return 0; + } else { + if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) == TCL_OK + && (*widePtr >= 0)) { + return 0; + } + } + } + + return (GetInvalidWideFromObj(objPtr, widePtr) != TCL_OK); +} + +static inline int GetDouble( Tcl_Obj *objPtr, double *dblPtr) @@ -476,6 +516,29 @@ GetDouble( 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 + ; +} + +static inline int +IsSpecial( + double a) +{ + return TclIsInfinite(a) +#ifdef ACCEPT_NAN + || TclIsNaN(a) +#endif + ; +} /* *---------------------------------------------------------------------- @@ -514,6 +577,7 @@ LinkTraceProc( Tcl_Obj *valueObj; int valueInt; Tcl_WideInt valueWide; + Tcl_WideUInt valueUWide; double valueDouble; int objc; Tcl_Obj **objv; @@ -569,8 +633,7 @@ LinkTraceProc( changed = (LinkedVar(int) != linkPtr->lastValue.i); break; case TCL_LINK_DOUBLE: - /* FIXME: handle NaN */ - changed = (LinkedVar(double) != linkPtr->lastValue.d); + changed = !EqualDouble(LinkedVar(double), linkPtr->lastValue.d); break; case TCL_LINK_WIDE_INT: changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w); @@ -602,8 +665,7 @@ LinkTraceProc( break; #endif case TCL_LINK_FLOAT: - /* FIXME: handle NaN */ - changed = (LinkedVar(float) != linkPtr->lastValue.f); + changed = !EqualDouble(LinkedVar(float), linkPtr->lastValue.f); break; case TCL_LINK_STRING: case TCL_LINK_CHARS: @@ -942,50 +1004,46 @@ LinkTraceProc( case TCL_LINK_ULONG: if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { - if (GetWide(objv[i], &valueWide) - || !InRange(0, valueWide, ULONG_MAX)) { + 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) valueWide; + linkPtr->lastValue.ulPtr[i] = (unsigned long) valueUWide; } } else { - if (GetWide(valueObj, &valueWide) - || !InRange(0, valueWide, ULONG_MAX)) { + 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) valueWide; + (unsigned long) valueUWide; } break; #endif case TCL_LINK_WIDE_UINT: - /* - * FIXME: represent as a bignum. - */ if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { - if (GetWide(objv[i], &valueWide)) { + 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] = (Tcl_WideUInt) valueWide; + linkPtr->lastValue.uwPtr[i] = valueUWide; } } else { - if (GetWide(valueObj, &valueWide)) { + 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 = - (Tcl_WideUInt) valueWide; + LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = valueUWide; } break; @@ -993,9 +1051,8 @@ LinkTraceProc( if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { if (GetDouble(objv[i], &valueDouble) - && !InRange(FLT_MIN, valueDouble, FLT_MAX) - && !TclIsInfinite(valueDouble) - && !TclIsNaN(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"; @@ -1004,8 +1061,8 @@ LinkTraceProc( } } else { if (GetDouble(valueObj, &valueDouble) - && !InRange(FLT_MIN, valueDouble, FLT_MAX) - && !TclIsInfinite(valueDouble) && !TclIsNaN(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"; @@ -1210,9 +1267,6 @@ ObjValue( linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); case TCL_LINK_WIDE_UINT: - /* - * FIXME: represent as a bignum. - */ if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); diff --git a/tests/link.test b/tests/link.test index 97bd631..e04059f 100644 --- a/tests/link.test +++ b/tests/link.test @@ -708,8 +708,7 @@ test link-18.1 {linkarray unsigned long} -setup { testlinkarray remove ::my(var) unset -nocomplain my } -result {{can't set "::my(var)": variable must have unsigned * value} 120 {can't set "::my(var)": variable must have unsigned * value}} -test link-18.2 {linkarray unsigned long} -constraints knownBug -body { - # BUG: Implementation needs to use bignums on 64-bit platforms +test link-18.2 {linkarray unsigned long} -body { testlinkarray create ulong 1 ::my(var) set ::my(var) 120 catch {set ::my(var) -1} msg @@ -786,10 +785,7 @@ test link-20.1 {linkarray unsigned wide} -setup { testlinkarray remove ::my(var) unset -nocomplain my } -result {{can't set "::my(var)": variable must have unsigned wide int value} 120 {can't set "::my(var)": variable must have unsigned wide int value}} -test link-20.2 {linkarray unsigned wide} -constraints knownBug -setup { - set mylist [list] -} -body { - # BUG: Implementation needs to use bignums +test link-20.2 {linkarray unsigned wide} -body { testlinkarray create uwide 1 ::my(var) set ::my(var) 120 catch {set ::my(var) -1} msg -- cgit v0.12 From 52d83cb65d69a94c36ad6634d568bd97312219db Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 4 Apr 2019 23:08:05 +0000 Subject: Now with fewer memory leaks --- generic/tclLink.c | 39 +++++++++++++++++++++++++++------------ 1 file changed, 27 insertions(+), 12 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index 39ddbdd..616bdaf 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -468,32 +468,47 @@ GetUWide( int type; if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { - if (type == TCL_NUMBER_BIG) { + if (type == TCL_NUMBER_INT) { + *widePtr = *((const Tcl_WideInt *) clientData); + return (*widePtr < 0); + } else if (type == TCL_NUMBER_BIG) { mp_int num; - Tcl_WideUInt scratch, value = 0; + Tcl_WideUInt value = 0; + union { + Tcl_WideUInt value; + unsigned char bytes[sizeof(Tcl_WideUInt)]; + } scratch; unsigned long numBytes = sizeof(Tcl_WideUInt); - unsigned char *bytes = (unsigned char *) &scratch; + unsigned char *bytes = scratch.bytes; Tcl_GetBignumFromObj(NULL, objPtr, &num); - if (num.sign) { - return 1; - } - if (mp_to_unsigned_bin_n(&num, bytes, &numBytes) != MP_OKAY) { + if (num.sign || (MP_OKAY != mp_to_unsigned_bin_n(&num, 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. + */ + mp_clear(&num); return 1; } +#ifdef WORDS_BIGENDIAN while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } +#else /* !WORDS_BIGENDIAN */ + value = scratch.value; +#endif /* WORDS_BIGENDIAN */ *uwidePtr = value; + mp_clear(&num); return 0; - } else { - if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) == TCL_OK - && (*widePtr >= 0)) { - return 0; - } } } + /* + * Evil edge case fallback. + */ + return (GetInvalidWideFromObj(objPtr, widePtr) != TCL_OK); } -- cgit v0.12 From 52458f51bc8ece66942a74305efc875822b1d601 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 4 Apr 2019 23:47:38 +0000 Subject: Clean up and refactor a bit --- generic/tclLink.c | 255 ++++++++++++++++++++++++++++++------------------------ 1 file changed, 142 insertions(+), 113 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index 616bdaf..06a283f 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -9,6 +9,7 @@ * 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. @@ -98,10 +99,22 @@ static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, 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 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 @@ -440,6 +453,17 @@ Tcl_UpdateLinkedVar( } } +/* + *---------------------------------------------------------------------- + * + * 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, @@ -454,8 +478,15 @@ GetWide( Tcl_Obj *objPtr, Tcl_WideInt *widePtr) { - return (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK - && GetInvalidWideFromObj(objPtr, widePtr) != TCL_OK); + 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 @@ -465,7 +496,7 @@ GetUWide( { Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr; ClientData clientData; - int type; + int type, intValue; if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { if (type == TCL_NUMBER_INT) { @@ -509,7 +540,11 @@ GetUWide( * Evil edge case fallback. */ - return (GetInvalidWideFromObj(objPtr, widePtr) != TCL_OK); + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return 1; + } + *uwidePtr = intValue; + return 0; } static inline int @@ -527,7 +562,7 @@ GetDouble( *dblPtr = irPtr->doubleValue; return 0; } -#endif +#endif /* ACCEPT_NAN */ return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK; } } @@ -540,7 +575,7 @@ EqualDouble( return (a == b) #ifdef ACCEPT_NAN || (TclIsNaN(a) && TclIsNaN(b)) -#endif +#endif /* ACCEPT_NAN */ ; } @@ -551,9 +586,107 @@ IsSpecial( return TclIsInfinite(a) #ifdef ACCEPT_NAN || TclIsNaN(a) -#endif +#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; +} /* *---------------------------------------------------------------------- @@ -1333,110 +1466,6 @@ ObjValue( 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; -} /* *---------------------------------------------------------------------- -- cgit v0.12 From e0b6a53069be24ac23e8ec3d5390613041d28c44 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 5 Apr 2019 18:37:44 +0000 Subject: More efficient version (after feedback from KBK). Better test too. --- generic/tclInt.h | 25 +++++++++++++++++++++++++ generic/tclLink.c | 12 ++++++------ generic/tclObj.c | 29 +++++++++-------------------- tests/link.test | 3 ++- 4 files changed, 42 insertions(+), 27 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 9fc778b..89d7ff9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4514,6 +4514,31 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, /* *---------------------------------------------------------------- + * 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: diff --git a/generic/tclLink.c b/generic/tclLink.c index 06a283f..09ba2ed 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -503,7 +503,7 @@ GetUWide( *widePtr = *((const Tcl_WideInt *) clientData); return (*widePtr < 0); } else if (type == TCL_NUMBER_BIG) { - mp_int num; + mp_int *numPtr = clientData; Tcl_WideUInt value = 0; union { Tcl_WideUInt value; @@ -512,15 +512,13 @@ GetUWide( unsigned long numBytes = sizeof(Tcl_WideUInt); unsigned char *bytes = scratch.bytes; - Tcl_GetBignumFromObj(NULL, objPtr, &num); - if (num.sign || (MP_OKAY != mp_to_unsigned_bin_n(&num, bytes, - &numBytes))) { + 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. */ - mp_clear(&num); return 1; } #ifdef WORDS_BIGENDIAN @@ -528,10 +526,12 @@ GetUWide( value = (value << CHAR_BIT) | *bytes++; } #else /* !WORDS_BIGENDIAN */ + /* + * Little-endian can read the value directly. + */ value = scratch.value; #endif /* WORDS_BIGENDIAN */ *uwidePtr = value; - mp_clear(&num); return 0; } } diff --git a/generic/tclObj.c b/generic/tclObj.c index f233038..d329aba 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -191,17 +191,6 @@ static Tcl_ThreadDataKey pendingObjDataKey; | ((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: */ @@ -2517,7 +2506,7 @@ Tcl_GetDoubleFromObj( if (objPtr->typePtr == &tclBignumType) { mp_int big; - UNPACK_BIGNUM(objPtr, big); + TclUnpackBignum(objPtr, big); *dblPtr = TclBignumToDouble(&big); return TCL_OK; } @@ -3033,7 +3022,7 @@ Tcl_GetLongFromObj( 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++; @@ -3273,7 +3262,7 @@ Tcl_GetWideIntFromObj( 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++; @@ -3387,7 +3376,7 @@ FreeBignum( { 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); @@ -3420,7 +3409,7 @@ DupBignum( 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"); } @@ -3455,7 +3444,7 @@ UpdateStringOfBignum( 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"); } @@ -3594,10 +3583,10 @@ GetBignumFromObj( 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; @@ -3838,7 +3827,7 @@ TclGetNumberFromObj( 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; diff --git a/tests/link.test b/tests/link.test index e04059f..4c4cf99 100644 --- a/tests/link.test +++ b/tests/link.test @@ -781,10 +781,11 @@ test link-20.1 {linkarray unsigned wide} -setup { lappend mylist [set ::my(var) 120] catch {set ::my(var) 1e33} msg lappend mylist $msg + lappend mylist [set ::my(var) 0xbabed00dbabed00d] } -cleanup { testlinkarray remove ::my(var) unset -nocomplain my -} -result {{can't set "::my(var)": variable must have unsigned wide int value} 120 {can't set "::my(var)": variable must have unsigned wide int value}} +} -result {{can't set "::my(var)": variable must have unsigned wide int value} 120 {can't set "::my(var)": variable must have unsigned wide int value} 0xbabed00dbabed00d} test link-20.2 {linkarray unsigned wide} -body { testlinkarray create uwide 1 ::my(var) set ::my(var) 120 -- cgit v0.12 From 8e7402f6f2f955fdcb8a9a1035dbae99d5997b5c Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Apr 2019 13:54:04 +0000 Subject: extend comment --- generic/tclStringObj.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 4dd334d..38a8ad7 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3864,7 +3864,8 @@ TclStringReverse( * * TclStringReplace -- * - * Implements the inner engine of the [string replace] command. + * Implements the inner engine of the [string replace] and + * [string insert] commands. * * The result is a concatenation of a prefix from objPtr, characters * 0 through first-1, the insertPtr string value, and a suffix from -- cgit v0.12 From f1eba71130bf1b04e9cd0485f4583f13c94eb4ea Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Apr 2019 14:02:01 +0000 Subject: typo fix --- generic/tclStringObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 38a8ad7..6652f15 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3912,7 +3912,7 @@ TclStringReplace( /* * The caller very likely had to call Tcl_GetCharLength() or similar - * to be able to process index values. This means it is like that + * to be able to process index values. This means it is likely that * objPtr is either a proper "bytearray" or a "string" or else it has * a known and short string rep. */ -- cgit v0.12 From 1dbc626f0f6dadaa60c8e11a06ca90b5b0eb1c07 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 11 Apr 2019 21:39:50 +0000 Subject: Suggested fix for [60559fd4a6]: put selected tests in child interps --- tests/coroutine.test | 34 ++++++++++++++++++++++------------ 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/tests/coroutine.test b/tests/coroutine.test index 8217a92..3580f94 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -626,19 +626,31 @@ test coroutine-7.5 {return codes} { } set result } {0 1 2 3 4 5} -test coroutine-7.6 {Early yield crashes} { - proc foo args {} - trace add execution foo enter {catch yield} - coroutine demo foo - rename foo {} -} {} +test coroutine-7.6 {Early yield crashes} -setup { + set i [interp create] +} -body { + # Force into a child interpreter [bug 60559fd4a6] + $i eval { + proc foo args {} + trace add execution foo enter {catch yield} + coroutine demo foo + rename foo {} + return ok + } +} -cleanup { + interp delete $i +} -result ok test coroutine-7.7 {Bug 2486550} -setup { - interp hide {} yield + set i [interp create] + $i hide yield } -body { - coroutine demo interp invokehidden {} yield ok + # Force into a child interpreter [bug 60559fd4a6] + $i eval { + coroutine demo interp invokehidden {} yield ok + } } -cleanup { - demo - interp expose {} yield + $i eval demo + interp delete $i } -result ok test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup { namespace eval cotest {} @@ -780,8 +792,6 @@ test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { interp delete slave set result } -result {inject-executed} - - # cleanup unset lambda -- cgit v0.12 From e2dcb521341596da403d0b8796e07c431d933a39 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 14 Apr 2019 07:52:16 +0000 Subject: Removed TCL_LINK_ALLOC; it wasn't used. --- doc/LinkVar.3 | 14 ++++++++------ generic/tclLink.c | 3 +-- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/doc/LinkVar.3 b/doc/LinkVar.3 index a38610b..1e42858 100644 --- a/doc/LinkVar.3 +++ b/doc/LinkVar.3 @@ -34,6 +34,11 @@ Also used by \fBTcl_LinkVar\fR to return error messages. Name of global variable. .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 for \fBTcl_LinkVar\fR or type of array element for \fBTcl_LinkArray\fR. Must be one of \fBTCL_LINK_INT\fR, @@ -48,9 +53,7 @@ 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. \fBTCL_LINK_ALLOC\fR may also be OR'ed in -to tell Tcl to manage the storage for the array in the variable (that is, the -C variable is technically a pointer to an array, not the array itself). +\fBTCL_LINK_BYTES\fR may be used. .VE "TIP 312" .sp All the above for both functions may be @@ -77,9 +80,8 @@ contains an error message. .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 \fBTCL_LINK_ALLOC\fR bit), it writes the address that -it allocated to the Tcl interpreter result in addition to storing the -location of the array in the C variable pointed to by \fIaddr\fR. +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, diff --git a/generic/tclLink.c b/generic/tclLink.c index 09ba2ed..57735f8 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -235,8 +235,7 @@ Tcl_LinkArray( * will be allocated and returned as the * interpreter result. */ int type, /* Type of C variable: TCL_LINK_INT, etc. Also - * may have TCL_LINK_READ_ONLY and - * TCL_LINK_ALLOC OR'ed in. */ + * may have TCL_LINK_READ_ONLY OR'ed in. */ int size) /* Size of C variable array, >1 if array */ { Tcl_Obj *objPtr; -- cgit v0.12 From 564d3a1a7b42dcff5a8f6c5a5545e19cf58e3617 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 14 Apr 2019 15:14:50 +0000 Subject: Doc tweak --- doc/string.n | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/doc/string.n b/doc/string.n index 13b5969..72c7913 100644 --- a/doc/string.n +++ b/doc/string.n @@ -89,9 +89,9 @@ length of the string then this command returns an empty string. .RE .TP \fBstring insert \fIstring index insertString\fR -. +.VS "TIP 504" Returns a copy of \fIstring\fR with \fIinsertString\fR inserted at the -\fIindex\fR'th character. \fIindex\fR may be specified as described in the +\fIindex\fR'th character. The \fIindex\fR may be specified as described in the \fBSTRING INDICES\fR section. .RS .PP @@ -104,6 +104,7 @@ If \fIindex\fR is at or before the start of \fIstring\fR (e.g., \fIindex\fR is or after the end of \fIstring\fR (e.g., \fIindex\fR is \fBend\fR), \fIinsertString\fR is appended to \fIstring\fR. .RE +.VE "TIP 504" .TP \fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR . @@ -291,7 +292,9 @@ the special interpretation of the characters \fB*?[]\e\fR in . Returns a range of consecutive characters from \fIstring\fR, starting with the character whose index is \fIfirst\fR and ending with the -character whose index is \fIlast\fR. An index of 0 refers to the first +character whose index is \fIlast\fR (using the forms described in +\fBSTRING INDICES\fR). An index of \fB0\fR refers to the first +character of the string; an index of \fBend\fR refers to last character of the string. \fIfirst\fR and \fIlast\fR may be specified as for the \fBindex\fR method. If \fIfirst\fR is less than zero then it is treated as if it were zero, and if \fIlast\fR is greater than or @@ -301,13 +304,16 @@ string is returned. .TP \fBstring repeat \fIstring count\fR . -Returns \fIstring\fR repeated \fIcount\fR number of times. +Returns a string consisting of \fIstring\fR concatenated with itself +\fIcount\fR times. If \fIcount\fR is 0, the empty string will be +returned. .TP \fBstring replace \fIstring first last\fR ?\fInewstring\fR? . Removes a range of consecutive characters from \fIstring\fR, starting with the character whose index is \fIfirst\fR and ending with the -character whose index is \fIlast\fR. An index of 0 refers to the +character whose index is \fIlast\fR (using the forms described in +\fBSTRING INDICES\fR). An index of 0 refers to the first character of the string. \fIFirst\fR and \fIlast\fR may be specified as for the \fBindex\fR method. If \fInewstring\fR is specified, then it is placed in the removed character range. If -- cgit v0.12 From bcca980f06d421d332bb5bb34dac1a056681b86a Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 15 Apr 2019 19:57:54 +0000 Subject: Add [dict getdef] alias --- doc/dict.n | 5 ++++- generic/tclDictObj.c | 18 +++++++++--------- tests/dict.test | 46 +++++++++++++++++++++++++++++++++++++--------- 3 files changed, 50 insertions(+), 19 deletions(-) diff --git a/doc/dict.n b/doc/dict.n index 12c9b1a..3475415 100644 --- a/doc/dict.n +++ b/doc/dict.n @@ -120,6 +120,8 @@ It is an error to attempt to retrieve a value for a key that is not present in the dictionary. .RE .TP +\fBdict getdef \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR +.TP \fBdict getwithdefault \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR .VS "8.7, TIP342" This behaves the same as \fBdict get\fR (with at least one \fIkey\fR @@ -129,7 +131,8 @@ error because the \fIkey\fR (or one of the \fIkey\fRs on the key path) is absent, it returns the \fIdefault\fR argument instead. .RS .PP -Note that there must always be at least one \fIkey\fR provided. +Note that there must always be at least one \fIkey\fR provided, and that +\fBdict getdef\fR and \fBdict getwithdefault\fR are aliases for each other. .RE .VE "8.7, TIP342" .TP diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 75dcd09..fea4035 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -34,9 +34,8 @@ static int DictFilterCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictGetCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int DictGetWithDefaultCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); +static int DictGetDefCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); static int DictIncrCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictInfoCmd(ClientData dummy, Tcl_Interp *interp, @@ -92,7 +91,8 @@ static const EnsembleImplMap implementationMap[] = { {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, - {"getwithdefault", DictGetWithDefaultCmd, NULL, NULL, NULL, 0 }, + {"getdef", DictGetDefCmd, NULL, NULL, NULL, 0 }, + {"getwithdefault", DictGetDefCmd, NULL, NULL, NULL, 0 }, {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, @@ -1631,11 +1631,11 @@ DictGetCmd( /* *---------------------------------------------------------------------- * - * DictGetWithDefaultCmd -- + * DictGetDefCmd -- * - * This function implements the "dict getwithdefault" Tcl command. See - * the user documentation for details on what it does, and TIP#342 for - * the formal specification. + * This function implements the "dict getdef" and "dict getwithdefault" + * Tcl commands. See the user documentation for details on what it does, + * and TIP#342 for the formal specification. * * Results: * A standard Tcl result. @@ -1647,7 +1647,7 @@ DictGetCmd( */ static int -DictGetWithDefaultCmd( +DictGetDefCmd( ClientData dummy, Tcl_Interp *interp, int objc, diff --git a/tests/dict.test b/tests/dict.test index 50e4db7..6d74b96 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -2048,31 +2048,59 @@ test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]} }} } {} -test dict-26.1 {dict getwithdefault command} -body { +test dict-26.1 {dict getdef command} -body { + dict getdef {a b} a c +} -result b +test dict-26.2 {dict getdef command} -body { + dict getdef {a b} b c +} -result c +test dict-26.3 {dict getdef command} -body { + dict getdef {a {b c}} a b d +} -result c +test dict-26.4 {dict getdef command} -body { + dict getdef {a {b c}} a c d +} -result d +test dict-26.5 {dict getdef command} -body { + dict getdef {a {b c}} b c d +} -result d +test dict-26.6 {dict getdef command} -returnCodes error -body { + dict getdef {a {b c d}} a b d +} -result {missing value to go with key} +test dict-26.7 {dict getdef command} -returnCodes error -body { + dict getdef +} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} +test dict-26.8 {dict getdef command} -returnCodes error -body { + dict getdef {} +} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} +test dict-26.9 {dict getdef command} -returnCodes error -body { + dict getdef {} {} +} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} + +test dict-27.1 {dict getwithdefault command} -body { dict getwithdefault {a b} a c } -result b -test dict-26.2 {dict getwithdefault command} -body { +test dict-27.2 {dict getwithdefault command} -body { dict getwithdefault {a b} b c } -result c -test dict-26.3 {dict getwithdefault command} -body { +test dict-27.3 {dict getwithdefault command} -body { dict getwithdefault {a {b c}} a b d } -result c -test dict-26.4 {dict getwithdefault command} -body { +test dict-27.4 {dict getwithdefault command} -body { dict getwithdefault {a {b c}} a c d } -result d -test dict-26.5 {dict getwithdefault command} -body { +test dict-27.5 {dict getwithdefault command} -body { dict getwithdefault {a {b c}} b c d } -result d -test dict-26.6 {dict getwithdefault command} -returnCodes error -body { +test dict-27.6 {dict getwithdefault command} -returnCodes error -body { dict getwithdefault {a {b c d}} a b d } -result {missing value to go with key} -test dict-26.7 {dict getwithdefault command} -returnCodes error -body { +test dict-27.7 {dict getwithdefault command} -returnCodes error -body { dict getwithdefault } -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} -test dict-26.8 {dict getwithdefault command} -returnCodes error -body { +test dict-27.8 {dict getwithdefault command} -returnCodes error -body { dict getwithdefault {} } -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} -test dict-26.9 {dict getwithdefault command} -returnCodes error -body { +test dict-27.9 {dict getwithdefault command} -returnCodes error -body { dict getwithdefault {} {} } -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} -- cgit v0.12 From f720f4cad5dc71321f549bcdb10dbb0a312e52e4 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Apr 2019 14:25:59 +0000 Subject: Isolate tests of [info frame] results from testing environment. --- tests/info.test | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/tests/info.test b/tests/info.test index fbc65ba..fb2da75 100644 --- a/tests/info.test +++ b/tests/info.test @@ -773,16 +773,16 @@ test info-22.8 {info frame, basic trace} -constraints {!singleTestInterp} -match ## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0 -test info-23.0 {eval'd info frame} {!singleTestInterp} { - eval {info frame} -} 8 -test info-23.1 {eval'd info frame, semi-dynamic} {!singleTestInterp} { - eval info frame -} 8 -test info-23.2 {eval'd info frame, dynamic} {!singleTestInterp} { - set script {info frame} - eval $script -} 8 +test info-23.0 {eval'd info frame} -constraints {!singleTestInterp} -body { + list [i eval {info frame}] [i eval {eval {info frame}}] +} -setup {interp create i} -cleanup {interp delete i} -result {1 2} +test info-23.1 {eval'd info frame, semi-dynamic} -constraints {!singleTestInterp} -body { + i eval {eval info frame} +} -setup {interp create i} -cleanup {interp delete i} -result 2 +test info-23.2 {eval'd info frame, dynamic} -constraints {!singleTestInterp} -body { + i eval { set script {info frame} + eval $script} +} -setup {interp create i} -cleanup {interp delete i} -result 2 test info-23.3 {eval'd info frame, literal} -match glob -body { eval { info frame 0 -- cgit v0.12 From 05509bdd77f1324b1f0d7c823d04bea37fbcd460 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Apr 2019 14:34:42 +0000 Subject: Revise coroutines tests so they do not leave behind frame footprints that can interfere with other tests. --- tests/coroutine.test | 34 ++++++++++++++++++++++------------ 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/tests/coroutine.test b/tests/coroutine.test index 8a5494d..be2b624 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -626,19 +626,31 @@ test coroutine-7.5 {return codes} { } set result } {0 1 2 3 4 5} -test coroutine-7.6 {Early yield crashes} { - proc foo args {} - trace add execution foo enter {catch yield} - coroutine demo foo - rename foo {} -} {} +test coroutine-7.6 {Early yield crashes} -setup { + set i [interp create] +} -body { + # Force into a child interpreter [bug 60559fd4a6] + $i eval { + proc foo args {} + trace add execution foo enter {catch yield} + coroutine demo foo + rename foo {} + return ok + } +} -cleanup { + interp delete $i +} -result ok test coroutine-7.7 {Bug 2486550} -setup { - interp hide {} yield + set i [interp create] + $i hide yield } -body { - coroutine demo interp invokehidden {} yield ok + # Force into a child interpreter [bug 60559fd4a6] + $i eval { + coroutine demo interp invokehidden {} yield ok + } } -cleanup { - demo - interp expose {} yield + $i eval demo + interp delete $i } -result ok test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup { namespace eval cotest {} @@ -780,8 +792,6 @@ test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { interp delete slave set result } -result {inject-executed} - - # cleanup unset lambda -- cgit v0.12 From 12486f233fe3dee8ac48f4ec6c7c2bb1ea798c88 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Apr 2019 16:26:03 +0000 Subject: The [namespace delete ::httpTest] at the end of httpPipeline.test failed to also undo the custom [::http::Log] command it put in place. This dangling command was left broken and made much failure. Revised httpTest.tcl to use a trace to tidy up after itself. --- tests/httpTest.tcl | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl index 326b361..4345845 100644 --- a/tests/httpTest.tcl +++ b/tests/httpTest.tcl @@ -68,7 +68,11 @@ proc http::Log {args} { } return } - +# The http::Log routine above needs the variable ::httpTest::testOptions +# Set up to destroy it when that variable goes away. +trace add variable ::httpTest::testOptions unset {apply {args { + proc ::http::Log args {} +}}} # Called by http::Log (the "testing" version) to record logs for later analysis. -- cgit v0.12 From d227a324cdc79a735085101a912633df0541c4b9 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Apr 2019 16:32:53 +0000 Subject: Duplicate test names. --- tests/oo.test | 4 ++-- tests/string.test | 42 +++++++++++++++++++++--------------------- tests/utf.test | 6 +++--- 3 files changed, 26 insertions(+), 26 deletions(-) diff --git a/tests/oo.test b/tests/oo.test index b0c5570..c8f4b21 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2549,7 +2549,7 @@ test oo-16.17 {OO: object introspection: creationid #500} -body { test oo-16.18 {OO: object introspection: creationid #500} -body { info object creationid } -returnCodes error -result {wrong # args: should be "info object creationid objName"} -test oo-16.18 {OO: object introspection: creationid #500} -body { +test oo-16.18.1 {OO: object introspection: creationid #500} -body { info object creationid oo::object gorp } -returnCodes error -result {wrong # args: should be "info object creationid objName"} test oo-16.19 {OO: object introspection: creationid #500} -setup { @@ -4095,7 +4095,7 @@ test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { } -cleanup [SampleSlotCleanup { rename sampleSlot {} }] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}} -test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { +test oo-32.7 {TIP 516: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { list [info level] [sampleSlot -remove c a] \ diff --git a/tests/string.test b/tests/string.test index e937ab4..f077164 100644 --- a/tests/string.test +++ b/tests/string.test @@ -2415,75 +2415,75 @@ test string-31.25.$noComp {string insert, neither byte array nor Unicode} { run {tcl::string::insert [makeList a b c] 1 zzzzzz} } {azzzzzz b c} -test string-31.1.$noComp {string is dict} { +test string-32.1.$noComp {string is dict} { string is dict {a b c d} } 1 -test string-31.1a.$noComp {string is dict} { +test string-32.1a.$noComp {string is dict} { string is dict {a b c} } 0 -test string-31.2.$noComp {string is dict} { +test string-32.2.$noComp {string is dict} { string is dict "a \{b c" } 0 -test string-31.3.$noComp {string is dict} { +test string-32.3.$noComp {string is dict} { string is dict {a {b c}d e} } 0 -test string-31.4.$noComp {string is dict} { +test string-32.4.$noComp {string is dict} { string is dict {} } 1 -test string-31.5.$noComp {string is dict} { +test string-32.5.$noComp {string is dict} { string is dict -strict {a b c d} } 1 -test string-31.5a.$noComp {string is dict} { +test string-32.5a.$noComp {string is dict} { string is dict -strict {a b c} } 0 -test string-31.6.$noComp {string is dict} { +test string-32.6.$noComp {string is dict} { string is dict -strict "a \{b c" } 0 -test string-31.7.$noComp {string is dict} { +test string-32.7.$noComp {string is dict} { string is dict -strict {a {b c}d e} } 0 -test string-31.8.$noComp {string is dict} { +test string-32.8.$noComp {string is dict} { string is dict -strict {} } 1 -test string-31.9.$noComp {string is dict} { +test string-32.9.$noComp {string is dict} { set x {} list [string is dict -failindex x {a b c d}] $x } {1 {}} -test string-31.9a.$noComp {string is dict} { +test string-32.9a.$noComp {string is dict} { set x {} list [string is dict -failindex x {a b c}] $x } {0 -1} -test string-31.10.$noComp {string is dict} { +test string-32.10.$noComp {string is dict} { set x {} list [string is dict -failindex x "a \{b c d"] $x } {0 2} -test string-31.10a.$noComp {string is dict} { +test string-32.10a.$noComp {string is dict} { set x {} list [string is dict -failindex x "a \{b c"] $x } {0 2} -test string-31.11.$noComp {string is dict} { +test string-32.11.$noComp {string is dict} { set x {} list [string is dict -failindex x {a b {b c}d e}] $x } {0 4} -test string-31.12.$noComp {string is dict} { +test string-32.12.$noComp {string is dict} { set x {} list [string is dict -failindex x {}] $x } {1 {}} -test string-31.13.$noComp {string is dict} { +test string-32.13.$noComp {string is dict} { set x {} list [string is dict -failindex x { {b c}d e}] $x } {0 2} -test string-31.14.$noComp {string is dict} { +test string-32.14.$noComp {string is dict} { set x {} list [string is dict -failindex x "\uabcd {b c}d e"] $x } {0 2} -test string-31.15.$noComp {string is dict, valid dict} { +test string-32.15.$noComp {string is dict, valid dict} { string is dict {a b c d e f} } 1 -test string-31.16.$noComp {string is dict, invalid dict} { +test string-32.16.$noComp {string is dict, invalid dict} { string is dict a } 0 -test string-31.17.$noComp {string is dict, valid dict packed in invalid dict} { +test string-32.17.$noComp {string is dict, valid dict packed in invalid dict} { string is dict {{a b c d e f g h}} } 0 diff --git a/tests/utf.test b/tests/utf.test index 72b8d97..dc1a435 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -161,7 +161,7 @@ test utf-8.4 {Tcl_UniCharAtIndex: index > 0} { test utf-8.5 {Tcl_UniCharAtIndex: high surrogate} { string index \ud842 0 } "\ud842" -test utf-8.5 {Tcl_UniCharAtIndex: low surrogate} { +test utf-8.6 {Tcl_UniCharAtIndex: low surrogate} { string index \udc42 0 } "\udc42" @@ -192,7 +192,7 @@ test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring { test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} testbytestring { expr {"\U1e2165" eq "[testbytestring \xf0\x9e\x88\x96]5"} } 1 -test utf-10.6 {Tcl_UtfBackslash: stops after 6 hex chars} testbytestring { +test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} testbytestring { expr {"\U10e2165" eq "[testbytestring \xf4\x8e\x88\x96]5"} } 1 proc bsCheck {char num} { @@ -203,7 +203,7 @@ proc bsCheck {char num} { } $num incr errNum } -set errNum 6 +set errNum 8 bsCheck \b 8 bsCheck \e 101 bsCheck \f 12 -- cgit v0.12 From dadad672afce1ed05c7d18c54545400be87bcefc Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Apr 2019 16:56:55 +0000 Subject: test file hygiene --- tests/process.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/process.test b/tests/process.test index 4c4bc99..229d33c 100644 --- a/tests/process.test +++ b/tests/process.test @@ -332,6 +332,9 @@ test process-7.3 {child killed} -constraints {win} -body { tcl::process autopurge 1 } +removeFile $path(exit) +removeFile $path(sleep) + rename wait_for_file {} rename signal_exit {} ::tcltest::cleanupTests -- cgit v0.12 From 80d050ece42aa1defecb23381684d6dc2445fc41 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Apr 2019 17:45:55 +0000 Subject: Do not access allocated memory before initializing it. --- generic/tclLink.c | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/generic/tclLink.c b/generic/tclLink.c index 57735f8..8096c25 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -345,6 +345,17 @@ Tcl_LinkArray( } /* + * Initialize allocated space. + */ + + if (linkPtr->flags & LINK_ALLOC_ADDR) { + memset(linkPtr->addr, 0, linkPtr->bytes); + } + if (linkPtr->flags & LINK_ALLOC_LAST) { + memset(linkPtr->lastValue.aryPtr, 0, linkPtr->bytes); + } + + /* * Set common structure values. */ -- cgit v0.12 From 522f29c7ccb2ac30aa107ce07f227c73eab3f944 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Apr 2019 19:23:56 +0000 Subject: Replace memcpy() calls with memmove() to avoid undefined behavior when source and destination overlap. --- generic/tclUtf.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 53a0fec..86d1913 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1139,7 +1139,7 @@ Tcl_UtfToUpper( */ if ((len < TclUtfCount(upChar)) || ((upChar & 0xF800) == 0xD800)) { - memcpy(dst, src, len); + memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(upChar, dst); @@ -1201,7 +1201,7 @@ Tcl_UtfToLower( */ if ((len < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { - memcpy(dst, src, len); + memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(lowChar, dst); @@ -1260,7 +1260,7 @@ Tcl_UtfToTitle( titleChar = Tcl_UniCharToTitle(titleChar); if ((len < TclUtfCount(titleChar)) || ((titleChar & 0xF800) == 0xD800)) { - memcpy(dst, src, len); + memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(titleChar, dst); @@ -1283,7 +1283,7 @@ Tcl_UtfToTitle( } if ((len < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { - memcpy(dst, src, len); + memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(lowChar, dst); -- cgit v0.12 From 9cf9c0a5e5c1bc1e2cf81abce0c91a9acd632977 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 18 Apr 2019 08:31:11 +0000 Subject: Style corrections and warning elimination --- generic/tclBasic.c | 4 +- generic/tclCmdIL.c | 2 +- generic/tclCmdMZ.c | 14 +- generic/tclExecute.c | 2 +- generic/tclListObj.c | 2 +- generic/tclPkg.c | 318 ++++++++++++++++++++++++++++++-------------- generic/tclTest.c | 10 +- generic/tclTomMathStubLib.c | 4 +- 8 files changed, 239 insertions(+), 117 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e377951..84c87d0 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4925,7 +4925,7 @@ TEOV_Error( int objc = PTR2INT(data[0]); Tcl_Obj **objv = data[1]; - if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)){ + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { /* * If there was an error, a command string will be needed for the * error log: get it out of the itemPtr. The details depend on the @@ -5134,7 +5134,7 @@ TEOV_RunLeaveTraces( const char *command = TclGetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { - if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 441090c..dd7136c 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -4318,7 +4318,7 @@ Tcl_LsortObjCmd( elementArray = ckalloc(length * sizeof(SortElement)); - for (i=0; i < length; i++){ + for (i=0; i < length; i++) { idx = groupSize * i + groupOffset; if (indexc) { /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 7532de9..cb96cda 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2010,7 +2010,7 @@ StringMapCmd( */ if (!TclHasStringRep(objv[objc-2]) - && TclHasIntRep(objv[objc-2], &tclDictType)){ + && TclHasIntRep(objv[objc-2], &tclDictType)) { int i, done; Tcl_DictSearch search; @@ -2424,15 +2424,16 @@ StringRplcCmd( end = length - 1; if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){ + TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) { return TCL_ERROR; } /* - * The following test screens out most empty substrings as - * candidates for replacement. When they are detected, no - * replacement is done, and the result is the original string, + * The following test screens out most empty substrings as candidates for + * replacement. When they are detected, no replacement is done, and the + * result is the original string. */ + if ((last < 0) || /* Range ends before start of string */ (first > end) || /* Range begins after end of string */ (last < first)) { /* Range begins after it starts */ @@ -2442,6 +2443,7 @@ StringRplcCmd( * have (first <= end < 0 <= last) and an empty string is permitted * to be replaced. */ + Tcl_SetObjResult(interp, objv[1]); } else { Tcl_Obj *resultPtr; @@ -3623,7 +3625,7 @@ TclNRSwitchObjCmd( Tcl_Obj **listv; blist = objv[0]; - if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){ + if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d5dc9e1..2415959 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8348,7 +8348,7 @@ ExecuteExtendedBinaryMathOp( * Reduce small powers of 2 to shifts. */ - if ((Tcl_WideUInt)w2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ + if ((Tcl_WideUInt) w2 < CHAR_BIT * sizeof(Tcl_WideInt) - 1) { WIDE_RESULT(signum * (((Tcl_WideInt) 1) << (int) w2)); } goto overflowExpon; diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 0180920..ad64971 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1105,7 +1105,7 @@ Tcl_ListObjReplace( Tcl_Obj **oldPtrs = elemPtrs; int newMax; - if (needGrow){ + if (needGrow) { newMax = 2 * numRequired; } else { newMax = listRepPtr->maxElemCount; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 95524a7..ed5c57a 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -38,16 +38,18 @@ typedef struct PkgAvail { } PkgAvail; typedef struct PkgName { - struct PkgName *nextPtr; /* Next in list of package names being initialized. */ + struct PkgName *nextPtr; /* Next in list of package names being + * initialized. */ char name[1]; } PkgName; typedef struct PkgFiles { - PkgName *names; /* Package names being initialized. Must be first field*/ - Tcl_HashTable table; /* Table which contains files for each package */ + PkgName *names; /* Package names being initialized. Must be + * first field. */ + Tcl_HashTable table; /* Table which contains files for each + * package. */ } PkgFiles; - /* * For each package that is known in any way to an interpreter, there is one * record of the following type. These records are stored in the @@ -63,7 +65,7 @@ typedef struct Package { } Package; typedef struct Require { - void * clientDataPtr; + void *clientDataPtr; const char *name; Package *pkgPtr; char *versionToProvide; @@ -221,8 +223,10 @@ Tcl_PkgProvideEx( *---------------------------------------------------------------------- */ -static void PkgFilesCleanupProc(ClientData clientData, - Tcl_Interp *interp) +static void +PkgFilesCleanupProc( + ClientData clientData, + Tcl_Interp *interp) { PkgFiles *pkgFiles = (PkgFiles *) clientData; Tcl_HashSearch search; @@ -230,12 +234,14 @@ static void PkgFilesCleanupProc(ClientData clientData, while (pkgFiles->names) { PkgName *name = pkgFiles->names; + pkgFiles->names = name->nextPtr; ckfree(name); } entry = Tcl_FirstHashEntry(&pkgFiles->table, &search); while (entry) { Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry); + Tcl_DecrRefCount(obj); entry = Tcl_NextHashEntry(&search); } @@ -244,10 +250,16 @@ static void PkgFilesCleanupProc(ClientData clientData, return; } -void *TclInitPkgFiles(Tcl_Interp *interp) +void * +TclInitPkgFiles( + Tcl_Interp *interp) { - /* If assocdata "tclPkgFiles" doesn't exist yet, create it */ + /* + * If assocdata "tclPkgFiles" doesn't exist yet, create it. + */ + PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (!pkgFiles) { pkgFiles = ckalloc(sizeof(PkgFiles)); pkgFiles->names = NULL; @@ -257,9 +269,14 @@ void *TclInitPkgFiles(Tcl_Interp *interp) return pkgFiles; } -void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName) +void +TclPkgFileSeen( + Tcl_Interp *interp, + const char *fileName) { - PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgFiles *pkgFiles = (PkgFiles *) + Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (pkgFiles && pkgFiles->names) { const char *name = pkgFiles->names->name; Tcl_HashTable *table = &pkgFiles->table; @@ -347,12 +364,12 @@ Tcl_PkgRequireEx( * * Second, how does this work? If we reach this point, then the global * variable tclEmptyStringRep has the value NULL. Compare that with - * the definition of tclEmptyStringRep near the top of this file. - * It clearly should not have the value NULL; it - * should point to the char tclEmptyString. If we see it having the - * value NULL, then somehow we are seeing a Tcl library that isn't - * completely initialized, and that's an indicator for the error - * condition described above. (Further explanation is welcome.) + * the definition of tclEmptyStringRep near the top of this file. It + * clearly should not have the value NULL; it should point to the char + * tclEmptyString. If we see it having the value NULL, then somehow we + * are seeing a Tcl library that isn't completely initialized, and + * that's an indicator for the error condition described above. + * (Further explanation is welcome.) * * Third, so what do we do about it? This situation indicates the * package we just loaded wasn't properly compiled to be stub-enabled, @@ -416,9 +433,11 @@ Tcl_PkgRequireProc( void *clientDataPtr) { RequireProcArgs args; + args.name = name; args.clientDataPtr = clientDataPtr; - return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv); + return Tcl_NRCallObjProc(interp, + TclNRPkgRequireProc, (void *) &args, reqc, reqv); } static int @@ -426,20 +445,28 @@ TclNRPkgRequireProc( ClientData clientData, Tcl_Interp *interp, int reqc, - Tcl_Obj *const reqv[]) { + Tcl_Obj *const reqv[]) +{ RequireProcArgs *args = clientData; - Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr); + + Tcl_NRAddCallback(interp, + PkgRequireCore, (void *) args->name, INT2PTR(reqc), (void *) reqv, + args->clientDataPtr); return TCL_OK; } static int -PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result) +PkgRequireCore( + ClientData data[], + Tcl_Interp *interp, + int result) { const char *name = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj *const *reqv = data[2]; int code = CheckAllRequirements(interp, reqc, reqv); Require *reqPtr; + if (code != TCL_OK) { return code; } @@ -449,56 +476,86 @@ PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result) reqPtr->name = name; reqPtr->pkgPtr = FindPackage(interp, name); if (reqPtr->pkgPtr->version == NULL) { - Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1); + Tcl_NRAddCallback(interp, + SelectPackage, reqPtr, INT2PTR(reqc), (void *) reqv, + PkgRequireCoreStep1); } else { - Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NRAddCallback(interp, + PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *) reqv,NULL); } return TCL_OK; } static int -PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreStep1( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Tcl_DString command; char *script; Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name /* Name of desired package. */; - if (reqPtr->pkgPtr->version == NULL) { - /* - * The package is not in the database. If there is a "package unknown" - * command, invoke it. - */ - script = ((Interp *) interp)->packageUnknown; - if (script == NULL) { - Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - } else { - Tcl_DStringInit(&command); - Tcl_DStringAppend(&command, script, -1); - Tcl_DStringAppendElement(&command, name); - AddRequirementsToDString(&command, reqc, reqv); - - Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - Tcl_NREvalObj(interp, - Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)), - TCL_EVAL_GLOBAL - ); - Tcl_DStringFree(&command); - } - return TCL_OK; - } else { - Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + /* + * If we've got the package in the DB already, go on to actually loading + * it. + */ + + if (reqPtr->pkgPtr->version != NULL) { + Tcl_NRAddCallback(interp, + PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + return TCL_OK; } + + /* + * The package is not in the database. If there is a "package unknown" + * command, invoke it. + */ + + script = ((Interp *) interp)->packageUnknown; + if (script == NULL) { + /* + * No package unknown script. Move on to finalizing. + */ + + Tcl_NRAddCallback(interp, + PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + return TCL_OK; + } + + /* + * Invoke the "package unknown" script synchronously. + */ + + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + AddRequirementsToDString(&command, reqc, reqv); + + Tcl_NRAddCallback(interp, + PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *) reqv, NULL); + Tcl_NREvalObj(interp, + Tcl_NewStringObj(Tcl_DStringValue(&command), + Tcl_DStringLength(&command)), + TCL_EVAL_GLOBAL); + Tcl_DStringFree(&command); return TCL_OK; } static int -PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreStep2( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; - const char *name = reqPtr->name /* Name of desired package. */; + const char *name = reqPtr->name; /* Name of desired package. */ + if ((result != TCL_OK) && (result != TCL_ERROR)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad return code: %d", result)); @@ -511,20 +568,31 @@ PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { return result; } Tcl_ResetResult(interp); - /* pkgPtr may now be invalid, so refresh it. */ + + /* + * pkgPtr may now be invalid, so refresh it. + */ + reqPtr->pkgPtr = FindPackage(interp, name); - Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal); + Tcl_NRAddCallback(interp, + SelectPackage, reqPtr, INT2PTR(reqc), (void *) reqv, + PkgRequireCoreFinal); return TCL_OK; } static int -PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreFinal( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]), satisfies; Tcl_Obj **const reqv = data[2]; char *pkgVersionI; void *clientDataPtr = reqPtr->clientDataPtr; - const char *name = reqPtr->name /* Name of desired package. */; + const char *name = reqPtr->name; /* Name of desired package. */ + if (reqPtr->pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); @@ -565,14 +633,21 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { } static int -PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreCleanup( + ClientData data[], + Tcl_Interp *interp, + int result) +{ ckfree(data[0]); return result; } - static int -SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { +SelectPackage( + ClientData data[], + Tcl_Interp *interp, + int result) +{ PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ @@ -600,10 +675,10 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { } /* - * The package isn't yet present. Search the list of available - * versions and invoke the script for the best available version. We - * are actually locating the best, and the best stable version. One of - * them is then chosen based on the selection mode. + * The package isn't yet present. Search the list of available versions + * and invoke the script for the best available version. We are actually + * locating the best, and the best stable version. One of them is then + * chosen based on the selection mode. */ bestPtr = NULL; @@ -616,15 +691,19 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { if (CheckVersionAndConvert(interp, availPtr->version, &availVersion, &availStable) != TCL_OK) { /* - * The provided version number has invalid syntax. This - * should not happen. This should have been caught by the - * 'package ifneeded' registering the package. + * The provided version number has invalid syntax. This should not + * happen. This should have been caught by the 'package ifneeded' + * registering the package. */ continue; } - /* Check satisfaction of requirements before considering the current version further. */ + /* + * Check satisfaction of requirements before considering the current + * version further. + */ + if (reqc > 0) { satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); if (!satisfies) { @@ -646,13 +725,16 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { * The version of the package sought is better than the * currently selected version. */ + ckfree(bestVersion); bestVersion = NULL; goto newbest; } } else { newbest: - /* We have found a version which is better than our max. */ + /* + * We have found a version which is better than our max. + */ bestPtr = availPtr; CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); @@ -673,18 +755,24 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { if (res > 0) { /* - * This stable version of the package sought is better - * than the currently selected stable version. + * This stable version of the package sought is better than + * the currently selected stable version. */ + ckfree(bestStableVersion); bestStableVersion = NULL; goto newstable; } } else { newstable: - /* We have found a stable version which is better than our max stable. */ + /* + * We have found a stable version which is better than our max + * stable. + */ + bestStablePtr = availPtr; - CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); + CheckVersionAndConvert(interp, bestStablePtr->version, + &bestStableVersion, NULL); } ckfree(availVersion); @@ -706,9 +794,9 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { } /* - * Now choose a version among the two best. For 'latest' we simply - * take (actually keep) the best. For 'stable' we take the best - * stable, if there is any, or the best if there is nothing stable. + * Now choose a version among the two best. For 'latest' we simply take + * (actually keep) the best. For 'stable' we take the best stable, if + * there is any, or the best if there is nothing stable. */ if ((iPtr->packagePrefer == PKG_PREFER_STABLE) @@ -717,13 +805,14 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { } if (bestPtr == NULL) { - Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NRAddCallback(interp, + data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); } else { /* * We found an ifneeded script for the package. Be careful while * executing it: this could cause reentrancy, so (a) protect the - * script itself from deletion and (b) don't assume that bestPtr - * will still exist when the script completes. + * script itself from deletion and (b) don't assume that bestPtr will + * still exist when the script completes. */ char *versionToProvide = bestPtr->version; @@ -734,7 +823,11 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { pkgPtr->clientData = versionToProvide; pkgFiles = TclInitPkgFiles(interp); - /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ + + /* + * Push "ifneeded" package name in "tclPkgFiles" assocdata. + */ + pkgName = ckalloc(sizeof(PkgName) + strlen(name)); pkgName->nextPtr = pkgFiles->names; strcpy(pkgName->name, name); @@ -743,21 +836,31 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { TclPkgFileSeen(interp, bestPtr->pkgIndex); } reqPtr->versionToProvide = versionToProvide; - Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]); - Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL); + Tcl_NRAddCallback(interp, + SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, + data[3]); + Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), + TCL_EVAL_GLOBAL); } return TCL_OK; } static int -SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { +SelectPackageFinal( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name; char *versionToProvide = reqPtr->versionToProvide; - /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/ + /* + * Pop the "ifneeded" package name from "tclPkgFiles" assocdata + */ + PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); PkgName *pkgName = pkgFiles->names; pkgFiles->names = pkgName->nextPtr; @@ -822,14 +925,13 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { if (result != TCL_OK) { /* - * Take a non-TCL_OK code from the script as an indication the - * package wasn't loaded properly, so the package system - * should not remember an improper load. + * Take a non-TCL_OK code from the script as an indication the package + * wasn't loaded properly, so the package system should not remember + * an improper load. * - * This is consistent with our returning NULL. If we're not - * willing to tell our caller we got a particular version, we - * shouldn't store that version for telling future callers - * either. + * This is consistent with our returning NULL. If we're not willing to + * tell our caller we got a particular version, we shouldn't store + * that version for telling future callers either. */ if (reqPtr->pkgPtr->version != NULL) { @@ -840,7 +942,8 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { return result; } - Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NRAddCallback(interp, + data[3], reqPtr, INT2PTR(reqc), (void *) reqv, NULL); return TCL_OK; } @@ -1006,7 +1109,8 @@ TclNRPackageObjCmd( } pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); if (pkgFiles) { - Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2])); + Tcl_HashEntry *entry = + Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2])); if (entry) { Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry)); } @@ -1015,7 +1119,8 @@ TclNRPackageObjCmd( } case PKG_FORGET: { const char *keyString; - PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgFiles *pkgFiles = (PkgFiles *) + Tcl_GetAssocData(interp, "tclPkgFiles", NULL); for (i = 2; i < objc; i++) { keyString = TclGetString(objv[i]); @@ -1088,7 +1193,7 @@ TclNRPackageObjCmd( res = CompareVersions(avi, argv3i, NULL); ckfree(avi); - if (res == 0){ + if (res == 0) { if (objc == 4) { ckfree(argv3i); Tcl_SetObjResult(interp, @@ -1256,12 +1361,16 @@ TclNRPackageObjCmd( Tcl_ListObjAppendElement(interp, objvListPtr, ov); Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); - Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL); - Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL); + Tcl_NRAddCallback(interp, + TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL); + Tcl_NRAddCallback(interp, + PkgRequireCore, (void *) argv3, INT2PTR(newobjc), + newObjvPtr, NULL); return TCL_OK; } else { int i, newobjc = objc-3; Tcl_Obj *const *newobjv = objv + 3; + if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { return TCL_ERROR; } @@ -1269,17 +1378,20 @@ TclNRPackageObjCmd( Tcl_IncrRefCount(objvListPtr); Tcl_IncrRefCount(objv[2]); for (i = 0; i < newobjc; i++) { - /* * Tcl_Obj structures may have come from another interpreter, * so duplicate them. */ - Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); + Tcl_ListObjAppendElement(interp, objvListPtr, + Tcl_DuplicateObj(newobjv[i])); } Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); - Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL); - Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL); + Tcl_NRAddCallback(interp, + TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL); + Tcl_NRAddCallback(interp, + PkgRequireCore, (void *) argv2, INT2PTR(newobjc), + newObjvPtr, NULL); return TCL_OK; } break; @@ -1422,9 +1534,13 @@ TclNRPackageObjCmd( } static int -TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) { - TclDecrRefCount((Tcl_Obj *)data[0]); - TclDecrRefCount((Tcl_Obj *)data[1]); +TclNRPackageObjCmdCleanup( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + TclDecrRefCount((Tcl_Obj *) data[0]); + TclDecrRefCount((Tcl_Obj *) data[1]); return result; } diff --git a/generic/tclTest.c b/generic/tclTest.c index f075500..f301ebc 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -3323,8 +3323,12 @@ TestlinkarrayCmd( TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS, TCL_LINK_BINARY }; - int optionIndex, typeIndex, readonly, i, addr, size, length; + int optionIndex, typeIndex, readonly, i, size, length; char *name, *arg; + long addr; /* Wrong on Windows, but that's MS's fault for + * not supporting correctly. They + * can suffer the warnings; the rest of us + * shouldn't have to! */ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option args"); @@ -3382,7 +3386,7 @@ TestlinkarrayCmd( */ if (i < objc) { - if (Tcl_GetIntFromObj(interp, objv[i], &addr) == TCL_ERROR) { + if (Tcl_GetLongFromObj(interp, objv[i], &addr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "wrong address value", -1)); return TCL_ERROR; @@ -3390,7 +3394,7 @@ TestlinkarrayCmd( } else { addr = 0; } - return Tcl_LinkArray(interp, name, (char *) addr, + return Tcl_LinkArray(interp, name, (void *) addr, LinkTypes[typeIndex] | readonly, size); } return TCL_OK; diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c index 324f2a3..715904c 100644 --- a/generic/tclTomMathStubLib.c +++ b/generic/tclTomMathStubLib.c @@ -55,9 +55,9 @@ TclTomMathInitializeStubs( } if (stubsPtr == NULL) { errMsg = "missing stub table pointer"; - } else if(stubsPtr->tclBN_epoch() != epoch) { + } else if (stubsPtr->tclBN_epoch() != epoch) { errMsg = "epoch number mismatch"; - } else if(stubsPtr->tclBN_revision() != revision) { + } else if (stubsPtr->tclBN_revision() != revision) { errMsg = "requires a later revision"; } else { tclTomMathStubsPtr = stubsPtr; -- cgit v0.12 From 8b9a3558a42cba96fe30f272517260aef43ec7f8 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 18 Apr 2019 22:57:12 +0000 Subject: Compilation for [dict getwithdefault]. --- generic/tclAssembly.c | 10 ++++- generic/tclCompCmds.c | 32 +++++++++++++++ generic/tclCompile.c | 8 ++++ generic/tclCompile.h | 4 +- generic/tclDictObj.c | 13 +++--- generic/tclExecute.c | 108 ++++++++++++++++++++++++++++++++------------------ generic/tclInt.h | 3 ++ tests/dict.test | 49 +++++++++++++++++++++++ 8 files changed, 179 insertions(+), 48 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 5db2676..47f7100 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -145,6 +145,8 @@ typedef enum TalInstType { * 1 */ ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1 * operands, produces 1, N > 0 */ + ASSEM_DICT_GET_DEF, /* 'dict getwithdefault' - consumes N+2 + * operands, produces 1, N > 0 */ ASSEM_DICT_SET, /* specifies key count and LVT index, consumes * N+1 operands, produces 1, N > 0 */ ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes @@ -362,6 +364,7 @@ static const TalInstDesc TalInstructionTable[] = { {"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1}, {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1}, {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, + {"dictGetDef", ASSEM_DICT_GET_DEF, INST_DICT_GET_DEF, INT_MIN,1}, {"dictIncrImm", ASSEM_SINT4_LVT4, INST_DICT_INCR_IMM, 1, 1}, {"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1}, @@ -619,10 +622,14 @@ BBUpdateStackReqs( if (consumed == INT_MIN) { /* - * The instruction is variadic; it consumes 'count' operands. + * The instruction is variadic; it consumes 'count' operands, or + * 'count+1' for ASSEM_DICT_GET_DEF. */ consumed = count; + if (TalInstructionTable[tblIdx].instType == ASSEM_DICT_GET_DEF) { + consumed++; + } } if (produced < 0) { /* @@ -1396,6 +1403,7 @@ AssembleOneLine( break; case ASSEM_DICT_GET: + case ASSEM_DICT_GET_DEF: if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c472b8c..4844dd8 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1177,6 +1177,38 @@ TclCompileDictGetCmd( } int +TclCompileDictGetWithDefaultCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + int i; + DefineLineInformation; /* TIP #280 */ + + /* + * There must be at least three arguments after the command. + */ + + /* TODO: Consider support for compiling expanded args. */ + if (parsePtr->numWords < 4) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + + for (i=1 ; inumWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4(INST_DICT_GET_DEF, parsePtr->numWords-3, envPtr); + TclAdjustStackDepth(-2, envPtr); + return TCL_OK; +} + +int TclCompileDictExistsCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c0e8c62..c53d3ad 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -659,6 +659,14 @@ InstructionDesc const tclInstructionTable[] = { * 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds. * Stack: ... => ... time */ + {"dictGetDef", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* The top word is the default, the next op4 words (min 1) are a key + * path into the dictionary just below the keys on the stack, and all + * those values are replaced by the value read out of that key-path + * (like [dict get]) except if there is no such key, when instead the + * default is pushed instead. + * Stack: ... dict key1 ... keyN default => ... value */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index cf11e0e..117fa46 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -840,8 +840,10 @@ typedef struct ByteCode { #define INST_CLOCK_READ 189 +#define INST_DICT_GET_DEF 190 + /* The last opcode */ -#define LAST_INST_OPCODE 189 +#define LAST_INST_OPCODE 190 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index fea4035..f3b0981 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -91,8 +91,9 @@ static const EnsembleImplMap implementationMap[] = { {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, - {"getdef", DictGetDefCmd, NULL, NULL, NULL, 0 }, - {"getwithdefault", DictGetDefCmd, NULL, NULL, NULL, 0 }, + {"getdef", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, NULL,NULL,0}, + {"getwithdefault", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, + NULL, NULL, 0 }, {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, @@ -2085,11 +2086,9 @@ DictExistsCmd( return TCL_ERROR; } - dictPtr = TclTraceDictPath(interp, objv[1], objc-3, objv+2, - DICT_PATH_EXISTS); - if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT - || Tcl_DictObjGet(interp, dictPtr, objv[objc-1], - &valuePtr) != TCL_OK) { + dictPtr = TclTraceDictPath(NULL, objv[1], objc-3, objv+2,DICT_PATH_EXISTS); + if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT || + Tcl_DictObjGet(NULL, dictPtr, objv[objc-1], &valuePtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); } else { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL)); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2415959..ed4fdd7 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6769,55 +6769,23 @@ TEBCresume( TRACE_APPEND(("OK\n")); NEXT_INST_F(1, 1, 0); - case INST_DICT_GET: case INST_DICT_EXISTS: { - register Tcl_Interp *interp2 = interp; register int found; opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = OBJ_AT_DEPTH(opnd); - if (*pc == INST_DICT_EXISTS) { - interp2 = NULL; - } if (opnd > 1) { - dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); - if (dictPtr == NULL) { - if (*pc == INST_DICT_EXISTS) { - found = 0; - goto afterDictExists; - } - TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%.30s\": ", - O2S(OBJ_AT_DEPTH(opnd))), - Tcl_GetObjResult(interp)); - goto gotError; + dictPtr = TclTraceDictPath(NULL, dictPtr, opnd-1, + &OBJ_AT_DEPTH(opnd-1), DICT_PATH_EXISTS); + if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT) { + found = 0; + goto afterDictExists; } } - if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS, + if (Tcl_DictObjGet(NULL, dictPtr, OBJ_AT_TOS, &objResultPtr) == TCL_OK) { - if (*pc == INST_DICT_EXISTS) { - found = (objResultPtr ? 1 : 0); - goto afterDictExists; - } - if (!objResultPtr) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "key \"%s\" not known in dictionary", - TclGetString(OBJ_AT_TOS))); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), NULL); - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - } else if (*pc != INST_DICT_EXISTS) { - TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", - O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; + found = (objResultPtr ? 1 : 0); } else { found = 0; } @@ -6833,6 +6801,68 @@ TEBCresume( JUMP_PEEPHOLE_V(found, 5, opnd+1); } + case INST_DICT_GET: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + dictPtr = OBJ_AT_DEPTH(opnd); + if (opnd > 1) { + dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, + &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); + if (dictPtr == NULL) { + TRACE_WITH_OBJ(( + "ERROR tracing dictionary path into \"%.30s\": ", + O2S(OBJ_AT_DEPTH(opnd))), + Tcl_GetObjResult(interp)); + goto gotError; + } + } + if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, + &objResultPtr) != TCL_OK) { + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + if (!objResultPtr) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(OBJ_AT_TOS))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", + TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + case INST_DICT_GET_DEF: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + dictPtr = OBJ_AT_DEPTH(opnd+1); + if (opnd > 1) { + dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, + &OBJ_AT_DEPTH(opnd), DICT_PATH_EXISTS); + if (dictPtr == NULL) { + TRACE_WITH_OBJ(( + "ERROR tracing dictionary path into \"%.30s\": ", + O2S(OBJ_AT_DEPTH(opnd+1))), + Tcl_GetObjResult(interp)); + goto gotError; + } else if (dictPtr == DICT_PATH_NON_EXISTENT) { + goto dictGetDefUseDefault; + } + } + if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, + &objResultPtr) != TCL_OK) { + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } else if (!objResultPtr) { + dictGetDefUseDefault: + objResultPtr = OBJ_AT_TOS; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+2, 1); case INST_DICT_SET: case INST_DICT_UNSET: diff --git a/generic/tclInt.h b/generic/tclInt.h index 772ff26..3db1264 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3648,6 +3648,9 @@ MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictGetWithDefaultCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/tests/dict.test b/tests/dict.test index 6d74b96..62590e7 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -2048,6 +2048,7 @@ test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]} }} } {} +set dict dict; # Used to force interpretation, not compilation test dict-26.1 {dict getdef command} -body { dict getdef {a b} a c } -result b @@ -2075,6 +2076,30 @@ test dict-26.8 {dict getdef command} -returnCodes error -body { test dict-26.9 {dict getdef command} -returnCodes error -body { dict getdef {} {} } -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} +test dict-26.10 {dict getdef command} -returnCodes error -body { + dict getdef {a b c} d e +} -result {missing value to go with key} +test dict-26.11 {dict getdef command} -body { + $dict getdef {a b} a c +} -result b +test dict-26.12 {dict getdef command} -body { + $dict getdef {a b} b c +} -result c +test dict-26.13 {dict getdef command} -body { + $dict getdef {a {b c}} a b d +} -result c +test dict-26.14 {dict getdef command} -body { + $dict getdef {a {b c}} a c d +} -result d +test dict-26.15 {dict getdef command} -body { + $dict getdef {a {b c}} b c d +} -result d +test dict-26.16 {dict getdef command} -returnCodes error -body { + $dict getdef {a {b c d}} a b d +} -result {missing value to go with key} +test dict-26.17 {dict getdef command} -returnCodes error -body { + $dict getdef {a b c} d e +} -result {missing value to go with key} test dict-27.1 {dict getwithdefault command} -body { dict getwithdefault {a b} a c @@ -2103,6 +2128,30 @@ test dict-27.8 {dict getwithdefault command} -returnCodes error -body { test dict-27.9 {dict getwithdefault command} -returnCodes error -body { dict getwithdefault {} {} } -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} +test dict-26.10 {dict getdef command} -returnCodes error -body { + dict getwithdefault {a b c} d e +} -result {missing value to go with key} +test dict-27.11 {dict getwithdefault command} -body { + $dict getwithdefault {a b} a c +} -result b +test dict-27.12 {dict getwithdefault command} -body { + $dict getwithdefault {a b} b c +} -result c +test dict-27.13 {dict getwithdefault command} -body { + $dict getwithdefault {a {b c}} a b d +} -result c +test dict-27.14 {dict getwithdefault command} -body { + $dict getwithdefault {a {b c}} a c d +} -result d +test dict-27.15 {dict getwithdefault command} -body { + $dict getwithdefault {a {b c}} b c d +} -result d +test dict-27.16 {dict getwithdefault command} -returnCodes error -body { + $dict getwithdefault {a {b c d}} a b d +} -result {missing value to go with key} +test dict-26.17 {dict getdef command} -returnCodes error -body { + $dict getwithdefault {a b c} d e +} -result {missing value to go with key} # cleanup ::tcltest::cleanupTests -- cgit v0.12