Fix a few critical errors and allow int32 as a type

more gentle evaluation behaviour, similar to a cycle now (also avoids extra overhead to set result to interp, etc.);
todo: rewrite optimization of INST_DONE using last-instruction pointer or optimization flags for compile of iteration (if sebres's perf-branch gets merged).

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 <tcl.h>\fR
@@ -17,27 +17,52 @@ 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.
+.sp
+.VS "TIP 312"
+In \fBTcl_LinkArray\fR, may be NULL to tell Tcl to create the storage
+for the array in the variable.
+.VE "TIP 312"
 .AP int type in
-Type of C variable.  Must be one of \fBTCL_LINK_INT\fR,
+Type of C variable for \fBTcl_LinkVar\fR or type of array element for
+\fBTcl_LinkArray\fR.  Must be one of \fBTCL_LINK_INT\fR,
 \fBTCL_LINK_UINT\fR, \fBTCL_LINK_CHAR\fR, \fBTCL_LINK_UCHAR\fR,
 \fBTCL_LINK_SHORT\fR, \fBTCL_LINK_USHORT\fR, \fBTCL_LINK_LONG\fR,
 \fBTCL_LINK_ULONG\fR, \fBTCL_LINK_WIDE_INT\fR,
-\fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR,
-\fBTCL_LINK_DOUBLE\fR, \fBTCL_LINK_BOOLEAN\fR, or
-\fBTCL_LINK_STRING\fR, optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR
-to make Tcl variable read-only.
+\fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR, \fBTCL_LINK_DOUBLE\fR,
+\fBTCL_LINK_BOOLEAN\fR, or one of the extra ones listed below.
+.sp
+In \fBTcl_LinkVar\fR, the additional linked type \fBTCL_LINK_STRING\fR may be
+used.
+.sp
+.VS "TIP 312"
+In \fBTcl_LinkArray\fR, the additional linked types \fBTCL_LINK_CHARS\fR and
+\fBTCL_LINK_BYTES\fR may be used.
+.VE "TIP 312"
+.sp
+All the above for both functions may be
+optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR to make the Tcl
+variable read-only.
+.AP int size in
+.VS "TIP 312"
+The number of elements in the C array. Must be greater than zero.
+.VE "TIP 312"
 .BE
 .SH DESCRIPTION
 .PP
@@ -52,12 +77,21 @@ while setting up the link (e.g. because \fIvarName\fR is the
 name of array) then \fBTCL_ERROR\fR is returned and the interpreter's result
 contains an error message.
 .PP
+.VS "TIP 312"
+\fBTcl_LinkArray\fR is similar, but for arrays of fixed size (given by
+the \fIsize\fR argument). When asked to allocate the backing C array
+storage (via the \fIaddr\fR argument being NULL), it writes the
+address that it allocated to the Tcl interpreter result.
+.VE "TIP 312"
+.PP
 The \fItype\fR argument specifies the type of the C variable,
+or the type of the elements of the C array,
 and must have one of the following values, optionally OR'ed with
 \fBTCL_LINK_READ_ONLY\fR:
 .TP
 \fBTCL_LINK_INT\fR
-The C variable is of type \fBint\fR.
+.
+The C variable, or each element of the C array, is of type \fBint\fR.
 Any value written into the Tcl variable must have a proper integer
 form acceptable to \fBTcl_GetIntFromObj\fR;  attempts to write
 non-integer values into \fIvarName\fR will be rejected with
@@ -66,7 +100,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 +111,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 +143,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 +169,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 +180,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 +190,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 +201,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 +211,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 +222,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 +234,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 +248,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 +262,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 +272,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

doc/TraceVar.3

@@ -331,11 +331,11 @@ trace procedures will always be invoked.
 .SH "RESTRICTIONS"
 .PP
 A trace procedure can be called at any time, even when there
-is a partially formed result in the interpreter's result area.  If
+are partially formed results stored in the interpreter.  If
 the trace procedure does anything that could damage this result (such
-as calling \fBTcl_Eval\fR) then it must save the original values of
-the interpreter's \fBresult\fR and \fBfreeProc\fR fields and restore
-them before it returns.
+as calling \fBTcl_Eval\fR) then it must use the \fBTcl_SaveInterpState\fR
+and related routines to save and restore the original state of
+the interpreter before it returns.
 .SH "UNDEFINED VARIABLES"
 .PP
 It is legal to set a trace on an undefined variable.

doc/coroutine.n

@@ -14,10 +14,13 @@ coroutine, yield, yieldto \- Create and produce values from coroutines
 .nf
 \fBcoroutine \fIname command\fR ?\fIarg...\fR?
 \fByield\fR ?\fIvalue\fR?
-.VS TIP396
 \fByieldto\fR \fIcommand\fR ?\fIarg...\fR?
 \fIname\fR ?\fIvalue...\fR?
-.VE TIP396
+.sp
+.VS "8.7, TIP383"
+\fBcoroinject \fIcoroName command\fR ?\fIarg...\fR?
+\fBcoroprobe \fIcoroName command\fR ?\fIarg...\fR?
+.VE "8.7, TIP383"
 .fi
 .BE
 .SH DESCRIPTION
@@ -39,7 +42,6 @@ the context to be suspended. If the coroutine context never yields and instead
 returns conventionally, the result of the \fBcoroutine\fR command will be the
 result of the evaluation of the context.
 .PP
-.VS TIP396
 The coroutine may also suspend its execution by use of the \fByieldto\fR
 command, which instead of returning, cedes execution to some command called
 \fIcommand\fR (resolved in the context of the coroutine) and to which \fIany
@@ -58,11 +60,10 @@ with multiple arguments is by using \fByieldto\fR and the \fBreturn\fR
 command, like this:
 .PP
 .CS
-proc yieldm {value} {
-    \fByieldto\fR return -level 0 $value
+proc yieldMultiple {value} {
+    tailcall \fByieldto\fR string cat $value
 }
 .CE
-.VE TIP396
 .PP
 The coroutine can also be deleted by destroying the command \fIname\fR, and
 the name of the current coroutine can be retrieved by using
@@ -75,6 +76,51 @@ At the point when \fIcommand\fR is called, the current namespace will be the
 global namespace and there will be no stack frames above it (in the sense of
 \fBupvar\fR and \fBuplevel\fR). However, which command to call will be
 determined in the namespace that the \fBcoroutine\fR command was called from.
+.PP
+.VS "8.7, TIP383"
+A suspended coroutine (i.e., one that has \fByield\fRed or \fByieldto\fR-d)
+may have its state inspected (or modified) at that point by using
+\fBcoroprobe\fR to run a command at the point where the coroutine is at. The
+command takes the name of the coroutine to run the command in, \fIcoroName\fR,
+and the name of a command (any any arguments it requires) to immediately run
+at that point. The result of that command is the result of the \fBcoroprobe\fR
+command, and the gross state of the coroutine remains the same afterwards
+(i.e., the coroutine is still expecting the results of a \fByield\fR or
+\fByieldto\fR as before) though variables may have been changed.
+.PP
+Similarly, the \fBcoroinject\fR command may be used to place a command to be
+run inside a suspended coroutine (when it is resumed) to process arguments,
+with quite a bit of similarity to \fBcoroprobe\fR. However, with
+\fBcoroinject\fR there are several key differences:
+.VE "8.7, TIP383"
+.IP \(bu
+.VS "8.7, TIP383"
+The coroutine is not immediately resumed after the injection has been done.  A
+consequence of this is that multiple injections may be done before the
+coroutine is resumed. There injected commands are performed in \fIreverse
+order of definition\fR (that is, they are internally stored on a stack).
+.VE "8.7, TIP383"
+.IP \(bu
+.VS "8.7, TIP383"
+An additional two arguments are appended to the list of arguments to be run
+(that is, the \fIcommand\fR and its \fIargs\fR are extended by two elements).
+The first is the name of the command that suspended the coroutine (\fByield\fR
+or \fByieldto\fR), and the second is the argument (or list of arguments, in
+the case of \fByieldto\fR) that is the current resumption value.
+.VE "8.7, TIP383"
+.IP \(bu
+.VS "8.7, TIP383"
+The result of the injected command is used as the result of the \fByield\fR or
+\fByieldto\fR that caused the coroutine to become suspended. Where there are
+multiple injected commands, the result of one becomes the resumption value
+processed by the next.
+.PP
+The injection is a one-off. It is not retained once it has been executed. It
+may \fByield\fR or \fByieldto\fR as part of its execution.
+.PP
+Note that running coroutines may be neither probed nor injected; the
+operations may only be applied to 
+.VE "8.7, TIP383"
 .SH EXAMPLES
 .PP
 This example shows a coroutine that will produce an infinite sequence of
@@ -138,7 +184,6 @@ for {set i 1} {$i <= 20} {incr i} {
 }
 .CE
 .PP
-.VS TIP396
 This example shows how a value can be passed around a group of three
 coroutines that yield to each other:
 .PP
@@ -150,14 +195,57 @@ proc juggler {name target {value ""}} {
     while {$value ne ""} {
         puts "$name : $value"
         set value [string range $value 0 end-1]
-        lassign [\fByieldto\fR $target $value] value
+        lassign [\fByieldto\fR \fI$target\fR $value] value
     }
 }
 \fBcoroutine\fR j1 juggler Larry [
     \fBcoroutine\fR j2 juggler Curly [
         \fBcoroutine\fR j3 juggler Moe j1]] "Nyuck!Nyuck!Nyuck!"
 .CE
-.VE TIP396
+.PP
+.VS "8.7, TIP383"
+This example shows a simple coroutine that collects non-empty values and
+returns a list of them when not given an argument. It also shows how we can
+look inside the coroutine to find out what it is doing, and how we can modify
+the input on a one-off basis.
+.PP
+.CS
+proc collectorImpl {} {
+    set me [info coroutine]
+    set accumulator {}
+    for {set val [\fByield\fR $me]} {$val ne ""} {set val [\fByield\fR]} {
+        lappend accumulator $val
+    }
+    return $accumulator
+}
+
+\fBcoroutine\fR collect collectorImpl
+\fIcollect\fR 123
+\fIcollect\fR "abc def"
+\fIcollect\fR 456
+
+puts [\fBcoroprobe \fIcollect\fR set accumulator]
+# ==> 123 {abc def} 456
+
+\fIcollect\fR "pqr"
+
+\fBcoroinject \fIcollect\fR apply {{type value} {
+    puts "Received '$value' at a $type in [info coroutine]"
+    return [string toupper $value]
+}}
+
+\fIcollect\fR rst
+# ==> Received 'rst' at a yield in ::collect
+\fIcollect\fR xyz
+
+puts [\fIcollect\fR]
+# ==> 123 {abc def} 456 pqr RST xyz
+.CE
+.PP
+This example shows a simple coroutine that collects non-empty values and
+returns a list of them when not given an argument. It also shows how we can
+look inside the coroutine to find out what it is doing.
+.VE "8.7, TIP383"
 .SS "DETAILED SEMANTICS"
 .PP
 This example demonstrates that coroutines start from the global namespace, and

doc/dict.n

@@ -120,6 +120,22 @@ 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
+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, and that
+\fBdict getdef\fR and \fBdict getwithdefault\fR are aliases for each other.
+.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

doc/file.n

@@ -433,6 +433,36 @@ If \fIname\fR contains no separators then returns \fIname\fR.  So,
 \fBfile tail a/b\fR, \fBfile tail a/b/\fR and \fBfile tail b\fR all
 return \fBb\fR.
 .TP
+\fBfile tempdir\fR ?\fItemplate\fR?
+.VS "8.7, TIP 431"
+Creates a temporary directory (guaranteed to be newly created and writable by
+the current script) and returns its name. If \fItemplate\fR is given, it
+specifies one of or both of the existing directory (on a filesystem controlled
+by the operating system) to contain the temporary directory, and the base part
+of the directory name; it is considered to have the location of the directory
+if there is a directory separator in the name, and the base part is everything
+after the last directory separator (if non-empty).  The default containing
+directory is determined by system-specific operations, and the default base
+name prefix is
+.QW \fBtcl\fR .
+.RS
+.PP
+The following output is typical and illustrative; the actual output will vary
+between platforms:
+.PP
+.CS
+% \fBfile tempdir\fR
+/var/tmp/tcl_u0kuy5
+ % \fBfile tempdir\fR /tmp/myapp
+/tmp/myapp_8o7r9L
+% \fBfile tempdir\fR /tmp/
+/tmp/tcl_1mOJHD
+% \fBfile tempdir\fR myapp
+/var/tmp/myapp_0ihS0n
+.CE
+.RE
+.VE "8.7, TIP 431"
+.TP
 \fBfile tempfile\fR ?\fInameVar\fR? ?\fItemplate\fR?
 '\" TIP #210
 .VS 8.6

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

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:

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

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,75 @@ 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 terminal, 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 capabilities 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
+.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
 .
 (Windows only). This option is used to set the maximum time between
@@ -275,7 +345,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 +386,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 +429,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 +478,55 @@ 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 options:
+.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
+.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 options exist on Unix, but are on the serial channel
+type.
+.VE "8.7, TIP 160"
+.SH "EXAMPLES"
 .PP
 Open a command pipeline and catch any errors:
 .PP
@@ -419,6 +537,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)

doc/pragma.n

@@ -0,0 +1,121 @@
+'\"
+'\" Copyright (c) 2018 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 pragma n 8.7 Tcl "Tcl Built-In Commands"
+.so man.macros
+.BS
+'\" Note:  do not modify the .SH NAME line immediately below!
+.SH NAME
+tcl::pragma \- directives to assist efficient execution
+.SH SYNOPSIS
+.nf
+\fBtcl::pragma noalias\fR ?\fIvariableSet ...\fR?
+\fBtcl::pragma type \fItypeName\fR ?\fIvalue ...\fR?
+.fi
+.SH DESCRIPTION
+The \fBtcl::pragma\fR command provides directives that can aid efficient
+execution and compilation strategies for Tcl scripts, while also providing
+meaningful execution models for those directives. It produces no output on
+successful execution, and an error if a problem is detected. It supports two
+subcommands:
+.TP
+\fBtcl::pragma noalias\fR ?\fIvariableSet ...\fR?
+.
+This subcommand takes an arbitrary number of variable sets, \fIvariableSet\fR,
+(lists of variable names), and checks to see if they alias each other.
+Variable names within a variable set may resolve to the same variable (after
+following links such as those created by \fBupvar\fR and \fBglobal\fR, and
+allowing for any current namespace qualification, TclOO variable resolution,
+etc.), but it is an error if a variable mentioned in one variable set resolves
+to the same variable as a variable mentioned in another set. Only existing
+variables can be checked this way.
+.RS
+.PP
+When the local variables in a procedure all have simple names (this is the
+overwhelmingly common case), they can be asserted to all not alias each other
+with:
+.PP
+.CS
+\fBtcl::pragma noalias\fR {*}[info locals]
+.CE
+.RE
+.TP
+\fBtcl::pragma type \fItypeName\fR ?\fIvalue ...\fR?
+.
+This subcommand takes a value type, \fItypeName\fR, and throws an error if any
+of the arbitrary number of \fIvalue\fRs are not of that type. Supported
+\fItypeName\fRs are:
+.RS
+.TP
+\fBboolean\fR
+.
+This indicates the type of values accepted by \fBTcl_GetBooleanFromObj\fR().
+.TP
+\fBdict\fR
+.
+This indicates the type of values accepted by \fBTcl_DictObjSize\fR().
+.TP
+\fBdouble\fR
+.
+This indicates the type of values accepted by \fBTcl_GetDoubleFromObj\fR().
+.TP
+\fBint32\fR
+.
+This indicates the type of values accepted by \fBTcl_GetIntFromObj\fR().
+.TP
+\fBint64\fR
+.
+This indicates the type of values accepted by \fBTcl_GetWideIntFromObj\fR().
+.TP
+\fBinteger\fR
+.
+This indicates the type of any value accepted as an integer, without length
+restriction. This is the type of values accepted by integer-accepting
+\fBexpr\fR operators, such as the \fB&\fR operator or the left side of the
+\fB<<\fR operator.
+.TP
+\fBlist\fR
+.
+This indicates the type of values accepted by \fBTcl_ListObjLength\fR().
+.TP
+\fBnumber\fR
+.
+This indicates the type of any value accepted as a number, without length
+restriction. This is the type of values accepted by \fBexpr\fR operators
+such as \fB+\fR or \fB*\fR.
+.RE
+.SH EXAMPLES
+.PP
+This shows how a procedure could declare that it only operates on integers:
+.PP
+.CS
+proc addThreeIntegers {a b c} {
+    \fBtcl::pragma type\fR integer $a $b $c
+    return [expr {$a + $b + $c}]
+}
+.CE
+.PP
+This shows how a procedure could declare that two variables passed in by
+name/\fBupvar\fR must be distinct from each other:
+.PP
+.CS
+proc swap {v1Name v2Name} {
+    upvar 1 $v1Name v1 $v2Name v2
+    \fBtcl::pragma noalias\fR v1 v2
+    set tmp $v2
+    set v2 $v1
+    set v1 $tmp
+    return
+}
+.CE
+.SH "SEE ALSO"
+dict(n), global(n), list(n), string(n), upvar(n)
+.SH KEYWORDS
+compilation, variables, types
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:

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

doc/timerate.n

@@ -9,16 +9,26 @@
 .BS
 '\" Note:  do not modify the .SH NAME line immediately below!
 .SH NAME
-timerate \- Time-related execution resp. performance measurement of a script
+timerate \- Calibrated performance measurements of script execution time
 .SH SYNOPSIS
-\fBtimerate \fIscript\fR \fI?time ?max-count??\fR
+\fBtimerate \fIscript\fR ?\fItime\fR? ?\fImax-count\fR?
 .sp
-\fBtimerate \fI?-direct?\fR \fI?-overhead double?\fR \fIscript\fR \fI?time ?max-count??\fR
+\fBtimerate \fR?\fB\-direct\fR? ?\fB\-overhead\fI double\fR? \fIscript\fR ?\fItime\fR? ?\fImax-count\fR?
 .sp
-\fBtimerate \fI?-calibrate?\fR \fI?-direct?\fR \fIscript\fR \fI?time ?max-count??\fR
+\fBtimerate \fR?\fB\-calibrate\fR? ?\fB\-direct\fR? \fIscript\fR ?\fItime\fR? ?\fImax-count\fR?
 .BE
 .SH DESCRIPTION
 .PP
+The \fBtimerate\fR command does calibrated performance measurement of a Tcl
+command or script, \fIscript\fR. The \fIscript\fR should be written so that it
+can be executed multiple times during the performance measurement process.
+Time is measured in elapsed time using the finest timer resolution as possible,
+not CPU time; if \fIscript\fR interacts with the OS, the cost of that
+interaction is included.
+This command may be used to provide information as to how well a script or
+Tcl command is performing, and can help determine bottlenecks and fine-tune
+application performance.
+.PP
 The first and second form will evaluate \fIscript\fR until the interval
 \fItime\fR given in milliseconds elapses, or for 1000 milliseconds (1 second)
 if \fItime\fR is not specified.
@@ -28,47 +38,48 @@ by the maximal number of iterations to evaluate the script.
 If \fImax-count\fR is specified, the evalution will stop either this count of
 iterations is reached or the time is exceeded.
 .sp
-It will then return a canonical tcl-list of the form
+It will then return a canonical tcl-list of the form:
 .PP
 .CS
-\fB0.095977 \(mcs/# 52095836 # 10419167 #/sec 5000.000 nett-ms\fR
+\fB0.095977 \(mcs/# 52095836 # 10419167 #/sec 5000.000 net-ms\fR
 .CE
 .PP
 which indicates:
-.IP \(bu
+.IP \(bu 3
 the average amount of time required per iteration, in microseconds ([\fBlindex\fR $result 0])
-.IP \(bu
+.IP \(bu 3
 the count how many times it was executed ([\fBlindex\fR $result 2])
-.IP \(bu
+.IP \(bu 3
 the estimated rate per second ([\fBlindex\fR $result 4])
-.IP \(bu
+.IP \(bu 3
 the estimated real execution time without measurement overhead ([\fBlindex\fR $result 6])
 .PP
-Time is measured in elapsed time using the finest timer resolution as possible,
-not CPU time.
-This command may be used to provide information as to how well the script or a
-tcl-command is performing and can help determine bottlenecks and fine-tune
-application performance.
+The following options may be supplied to the \fBtimerate\fR command:
 .TP
-\fI-calibrate\fR
+\fB\-calibrate\fR
 .
-To measure very fast scripts as exact as posible the calibration process
+To measure very fast scripts as exactly as possible, a calibration process
 may be required.
-
-The \fI-calibrate\fR option is used to calibrate timerate, calculating the
-estimated overhead of the given script as the default overhead for future
-invocations of the \fBtimerate\fR command. If the \fItime\fR parameter is not
-specified, the calibrate procedure runs for up to 10 seconds.
+The \fB\-calibrate\fR option is used to calibrate \fBtimerate\fR itself,
+calculating the estimated overhead of the given script as the default overhead
+for future invocations of the \fBtimerate\fR command. If the \fItime\fR
+parameter is not specified, the calibrate procedure runs for up to 10 seconds.
+.RS
+.PP
+Note that calibration is not thread safe in the current implementation.
+.RE
 .TP
-\fI-overhead double\fR
+\fB\-overhead \fIdouble\fR
 .
-The \fI-overhead\fR parameter supplies an estimate (in microseconds) of the
+The \fB\-overhead\fR parameter supplies an estimate (in microseconds) of the
 measurement overhead of each iteration of the tested script. This quantity
-will be subtracted from the measured time prior to reporting results.
+will be subtracted from the measured time prior to reporting results. This can
+be useful for removing the cost of interpreter state reset commands from the
+script being measured.
 .TP
-\fI-direct\fR
+\fB\-direct\fR
 .
-The \fI-direct\fR option causes direct execution of the supplied script,
+The \fB-direct\fR option causes direct execution of the supplied script,
 without compilation, in a manner similar to the \fBtime\fR command. It can be
 used to measure the cost of \fBTcl_EvalObjEx\fR, of the invocation of canonical
 lists, and of the uncompiled versions of bytecoded commands.
@@ -76,31 +87,33 @@ lists, and of the uncompiled versions of bytecoded commands.
 As opposed to the \fBtime\fR commmand, which runs the tested script for a fixed
 number of iterations, the timerate command runs it for a fixed time.
 Additionally, the compiled variant of the script will be used during the entire
-measurement, as if the script were part of a compiled procedure, if the \fI-direct\fR
+measurement, as if the script were part of a compiled procedure, if the \fB\-direct\fR
 option is not specified. The fixed time period and possibility of compilation allow
 for more precise results and prevent very long execution times by slow scripts, making
 it practical for measuring scripts with highly uncertain execution times.
-
-.SH EXAMPLE
+.SH EXAMPLES
 Estimate how fast it takes for a simple Tcl \fBfor\fR loop (including
-operations on variable \fIi\fR) to count to a ten:
+operations on variable \fIi\fR) to count to ten:
 .PP
 .CS
-# calibrate:
-timerate -calibrate {}
-# measure:
-timerate { for {set i 0} {$i<10} {incr i} {} } 5000
+\fI# calibrate\fR
+\fBtimerate\fR -calibrate {}
+
+\fI# measure\fR
+\fBtimerate\fR { for {set i 0} {$i<10} {incr i} {} } 5000
 .CE
 .PP
 Estimate how fast it takes for a simple Tcl \fBfor\fR loop, ignoring the
-overhead for to perform ten iterations, ignoring the overhead of the management
-of the variable that controls the loop:
+overhead of the management of the variable that controls the loop:
 .PP
 .CS
-# calibrate for overhead of variable operations:
-set i 0; timerate -calibrate {expr {$i<10}; incr i} 1000
-# measure:
-timerate { for {set i 0} {$i<10} {incr i} {} } 5000
+\fI# calibrate for overhead of variable operations\fR
+set i 0; \fBtimerate\fR -calibrate {expr {$i<10}; incr i} 1000
+
+\fI# measure\fR
+\fBtimerate\fR {
+    for {set i 0} {$i<10} {incr i} {}
+} 5000
 .CE
 .PP
 Estimate the speed of calculating the hour of the day using \fBclock format\fR only,
@@ -108,14 +121,18 @@ ignoring overhead of the portion of the script that prepares the time for it to
 calculate:
 .PP
 .CS
-# calibrate:
-timerate -calibrate {}
-# estimate overhead:
+\fI# calibrate\fR
+\fBtimerate\fR -calibrate {}
+
+\fI# estimate overhead\fR
 set tm 0
-set ovh [lindex [timerate { incr tm [expr {24*60*60}] }] 0]
-# measure using esimated overhead:
+set ovh [lindex [\fBtimerate\fR {
+    incr tm [expr {24*60*60}]
+}] 0]
+
+\fI# measure using estimated overhead\fR
 set tm 0
-timerate -overhead $ovh {
+\fBtimerate\fR -overhead $ovh {
     clock format $tm -format %H
     incr tm [expr {24*60*60}]; # overhead for this is ignored
 } 5000
@@ -123,7 +140,7 @@ timerate -overhead $ovh {
 .SH "SEE ALSO"
 time(n)
 .SH KEYWORDS
-script, timerate, time
+performance measurement, script, time
 .\" Local Variables:
 .\" mode: nroff
 .\" End:

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)
 }
 
@@ -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 ----- #
 
 ##############################################################################

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
 
 /*

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;

generic/tclBasic.c

@@ -171,8 +171,13 @@ static Tcl_NRPostProc	TEOV_RunLeaveTraces;
 static Tcl_NRPostProc	EvalObjvCore;
 static Tcl_NRPostProc	Dispatch;
 
-static Tcl_ObjCmdProc NRCoroInjectObjCmd;
+static Tcl_ObjCmdProc NRInjectObjCmd;
 static Tcl_NRPostProc NRPostInvoke;
+static Tcl_ObjCmdProc CoroTypeObjCmd;
+static Tcl_ObjCmdProc TclNRCoroInjectObjCmd;
+static Tcl_ObjCmdProc TclNRCoroProbeObjCmd;
+static Tcl_NRPostProc InjectHandler;
+static Tcl_NRPostProc InjectHandlerPostCall;
 
 MODULE_SCOPE const TclStubs tclStubs;
 
@@ -242,6 +247,8 @@ static const CmdInfo builtInCmds[] = {
     {"catch",		Tcl_CatchObjCmd,	TclCompileCatchCmd,	TclNRCatchObjCmd,	CMD_IS_SAFE},
     {"concat",		Tcl_ConcatObjCmd,	TclCompileConcatCmd,	NULL,	CMD_IS_SAFE},
     {"continue",	Tcl_ContinueObjCmd,	TclCompileContinueCmd,	NULL,	CMD_IS_SAFE},
+    {"coroinject",	NULL,			NULL,                   TclNRCoroInjectObjCmd,	CMD_IS_SAFE},
+    {"coroprobe",	NULL,			NULL,                   TclNRCoroProbeObjCmd,	CMD_IS_SAFE},
     {"coroutine",	NULL,			NULL,			TclNRCoroutineObjCmd,	CMD_IS_SAFE},
     {"error",		Tcl_ErrorObjCmd,	TclCompileErrorCmd,	NULL,	CMD_IS_SAFE},
     {"eval",		Tcl_EvalObjCmd,		NULL,			TclNREvalObjCmd,	CMD_IS_SAFE},
@@ -262,6 +269,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},
@@ -364,6 +372,7 @@ static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = {
     {"file", "size"},
     {"file", "stat"},
     {"file", "tail"},
+    {"file", "tempdir"},
     {"file", "tempfile"},
     {"file", "type"},
     {"file", "volumes"},
@@ -932,6 +941,7 @@ Tcl_CreateInterp(void)
     TclInitInfoCmd(interp);
     TclInitNamespaceCmd(interp);
     TclInitStringCmd(interp);
+    TclInitPragmaCmd(interp);
     TclInitPrefixCmd(interp);
     TclInitProcessCmd(interp);
 
@@ -972,8 +982,11 @@ Tcl_CreateInterp(void)
             TclNRAssembleObjCmd, NULL, NULL);
     cmdPtr->compileProc = &TclCompileAssembleCmd;
 
+    /* Coroutine monkeybusiness */
     Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
-	    NRCoroInjectObjCmd, NULL, NULL);
+	    NRInjectObjCmd, NULL, NULL);
+    Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype",
+            CoroTypeObjCmd, NULL, NULL);
 
     /* Export unsupported commands */
     nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
@@ -2376,14 +2389,16 @@ Tcl_CreateCommand(
 	    break;
 	}
 
-	/* An existing command conflicts. Try to delete it.. */
+	/*
+         * An existing command conflicts. Try to delete it...
+         */
+
 	cmdPtr = Tcl_GetHashValue(hPtr);
 
 	/*
-	 * Be careful to preserve
-	 * any existing import links so we can restore them down below. That
-	 * way, you can redefine a command and its import status will remain
-	 * intact.
+	 * Be careful to preserve any existing import links so we can restore
+	 * them down below. That way, you can redefine a command and its
+	 * import status will remain intact.
 	 */
 
 	cmdPtr->refCount++;
@@ -2403,16 +2418,15 @@ Tcl_CreateCommand(
 
     if (!isNew) {
 	/*
-	 * If the deletion callback recreated the command, just throw away
-	 * the new command (if we try to delete it again, we could get
-	 * stuck in an infinite loop).
+	 * If the deletion callback recreated the command, just throw away the
+	 * new command (if we try to delete it again, we could get stuck in an
+	 * infinite loop).
 	 */
 
 	ckfree(Tcl_GetHashValue(hPtr));
     }
 
     if (!deleted) {
-
 	/*
 	 * Command resolvers (per-interp, per-namespace) might have resolved
 	 * to a command for the given namespace scope with this command not
@@ -2595,17 +2609,17 @@ TclCreateObjCommandInNs(
 	}
 
 	/*
-         * An existing command conflicts. Try to delete it.
+         * An existing command conflicts. Try to delete it...
          */
 
 	cmdPtr = Tcl_GetHashValue(hPtr);
 
 	/*
-	 * [***] This is wrong. See Tcl Bug a16752c252. However, this buggy
-	 * behavior is kept under particular circumstances to accommodate
-	 * deployed binaries of the "tclcompiler" program
-	 *     http://sourceforge.net/projects/tclpro/
-         * that crash if the bug is fixed.
+	 * [***] This is wrong.  See Tcl Bug a16752c252.
+	 * However, this buggy behavior is kept under particular circumstances
+	 * to accommodate deployed binaries of the "tclcompiler" program
+	 * <http://sourceforge.net/projects/tclpro/> that crash if the bug is
+	 * fixed.
 	 */
 
 	if (cmdPtr->objProc == TclInvokeStringCommand
@@ -4605,15 +4619,22 @@ EvalObjvCore(
     reresolve:
     assert(cmdPtr == NULL);
     if (preCmdPtr) {
-	/* Caller gave it to us */
+	/*
+         * Caller gave it to us.
+         */
+
 	if (!(preCmdPtr->flags & CMD_IS_DELETED)) {
-	    /* So long as it exists, use it. */
+	    /*
+             * So long as it exists, use it.
+             */
+
 	    cmdPtr = preCmdPtr;
 	} else if (flags & TCL_EVAL_NORESOLVE) {
 	    /*
-	     * When it's been deleted, and we're told not to attempt
-	     * resolving it ourselves, all we can do is raise an error.
+	     * When it's been deleted, and we're told not to attempt resolving
+	     * it ourselves, all we can do is raise an error.
 	     */
+
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		    "attempt to invoke a deleted command"));
 	    Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL);
@@ -4629,14 +4650,12 @@ EvalObjvCore(
 
     if (enterTracesDone || iPtr->tracePtr
 	    || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
-
 	Tcl_Obj *commandPtr = TclGetSourceFromFrame(
 		flags & TCL_EVAL_SOURCE_IN_FRAME ?  iPtr->cmdFramePtr : NULL,
 		objc, objv);
+
 	Tcl_IncrRefCount(commandPtr);
-
 	if (!enterTracesDone) {
-
 	    int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr,
 		    objc, objv);
 
@@ -4644,10 +4663,10 @@ EvalObjvCore(
 	     * Send any exception from enter traces back as an exception
 	     * raised by the traced command.
 	     * TODO: Is this a bug?  Letting an execution trace BREAK or
-	     * CONTINUE or RETURN in the place of the traced command?
-	     * Would either converting all exceptions to TCL_ERROR, or
-	     * just swallowing them be better?  (Swallowing them has the
-	     * problem of permanently hiding program errors.)
+	     * CONTINUE or RETURN in the place of the traced command?  Would
+	     * either converting all exceptions to TCL_ERROR, or just
+	     * swallowing them be better?  (Swallowing them has the problem of
+	     * permanently hiding program errors.)
 	     */
 
 	    if (code != TCL_OK) {
@@ -4656,9 +4675,8 @@ EvalObjvCore(
 	    }
 
 	    /*
-	     * If the enter traces made the resolved cmdPtr unusable, go
-	     * back and resolve again, but next time don't run enter
-	     * traces again.
+	     * If the enter traces made the resolved cmdPtr unusable, go back
+	     * and resolve again, but next time don't run enter traces again.
 	     */
 
 	    if (cmdPtr == NULL) {
@@ -4669,9 +4687,9 @@ EvalObjvCore(
 	}
 
 	/*
-	 * Schedule leave traces.  Raise the refCount on the resolved
-	 * cmdPtr, so that when it passes to the leave traces we know
-	 * it's still valid.
+	 * Schedule leave traces.  Raise the refCount on the resolved cmdPtr,
+	 * so that when it passes to the leave traces we know it's still
+	 * valid.
 	 */
 
 	cmdPtr->refCount++;
@@ -4741,8 +4759,6 @@ TclNRRunCallbacks(
 #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
     Interp *iPtr = (Interp *) interp;
 #endif /* !defined(TCL_NO_DEPRECATED) */
-    NRE_callback *callbackPtr;
-    Tcl_NRPostProc *procPtr;
 
     /*
      * If the interpreter has a non-empty string result, the result object is
@@ -4760,11 +4776,14 @@ TclNRRunCallbacks(
     }
 #endif /* !defined(TCL_NO_DEPRECATED) */
 
-    /* This is the trampoline. */
+    /*
+     * This is the trampoline.
+     */
 
     while (TOP_CB(interp) != rootPtr) {
-	callbackPtr = TOP_CB(interp);
-	procPtr = callbackPtr->procPtr;
+        NRE_callback *callbackPtr = TOP_CB(interp);
+        Tcl_NRPostProc *procPtr = callbackPtr->procPtr;
+
 	TOP_CB(interp) = callbackPtr->nextPtr;
 	result = procPtr(callbackPtr->data, interp, result);
 	TCLNR_FREE(interp, callbackPtr);
@@ -4924,7 +4943,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
@@ -5133,7 +5152,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);
 	}
@@ -6972,14 +6991,17 @@ TclNRInvoke(
     }
     cmdPtr = Tcl_GetHashValue(hPtr);
 
-    /* Avoid the exception-handling brain damage when numLevels == 0 . */
+    /*
+     * Avoid the exception-handling brain damage when numLevels == 0
+     */
+
     iPtr->numLevels++;
     Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL);
 
     /*
      * Normal command resolution of objv[0] isn't going to find cmdPtr.
-     * That's the whole point of **hidden** commands.  So tell the
-     * Eval core machinery not to even try (and risk finding something wrong).
+     * That's the whole point of **hidden** commands.  So tell the Eval core
+     * machinery not to even try (and risk finding something wrong).
      */
 
     return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr);
@@ -8373,13 +8395,21 @@ TclDTraceInfo(
 	Tcl_DictObjGet(NULL, info, *k++, &val);
 	args[i] = val ? TclGetString(val) : NULL;
     }
-    /* no "proc" -> use "lambda" */
+
+    /*
+     * no "proc" -> use "lambda"
+     */
+
     if (!args[2]) {
 	Tcl_DictObjGet(NULL, info, *k, &val);
 	args[2] = val ? TclGetString(val) : NULL;
     }
     k++;
-    /* no "class" -> use "object" */
+
+    /*
+     * no "class" -> use "object"
+     */
+
     if (!args[5]) {
 	Tcl_DictObjGet(NULL, info, *k, &val);
 	args[5] = val ? TclGetString(val) : NULL;
@@ -8733,8 +8763,10 @@ TclNRTailcallObjCmd(
         Tcl_Obj *listPtr, *nsObjPtr;
         Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
 
-        /* The tailcall data is in a Tcl list: the first element is the
-         * namespace, the rest the command to be tailcalled. */
+        /*
+         * The tailcall data is in a Tcl list: the first element is the
+         * namespace, the rest the command to be tailcalled.
+         */
 
         nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
         listPtr = Tcl_NewListObj(objc, objv);
@@ -9185,7 +9217,335 @@ TclNREvalList(
 /*
  *----------------------------------------------------------------------
  *
- * NRCoroInjectObjCmd --
+ * CoroTypeObjCmd --
+ *
+ *      Implementation of [::tcl::unsupported::corotype] command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CoroTypeObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Command *cmdPtr;
+    CoroutineData *corPtr;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "coroName");
+	return TCL_ERROR;
+    }
+
+    /*
+     * Look up the coroutine.
+     */
+
+    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
+    if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
+        Tcl_SetObjResult(interp, Tcl_NewStringObj(
+                "can only get coroutine type of a coroutine", -1));
+        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
+                TclGetString(objv[1]), NULL);
+        return TCL_ERROR;
+    }
+
+    /*
+     * An active coroutine is "active". Can't tell what it might do in the
+     * future.
+     */
+
+    corPtr = cmdPtr->objClientData;
+    if (!COR_IS_SUSPENDED(corPtr)) {
+        Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1));
+        return TCL_OK;
+    }
+
+    /*
+     * Inactive coroutines are classified by the (effective) command used to
+     * suspend them, which matters when you're injecting a probe.
+     */
+
+    switch (corPtr->nargs) {
+    case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL:
+        Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1));
+        return TCL_OK;
+    case COROUTINE_ARGUMENTS_ARBITRARY:
+        Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1));
+        return TCL_OK;
+    default:
+        Tcl_SetObjResult(interp, Tcl_NewStringObj(
+                "unknown coroutine type", -1));
+        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", NULL);
+        return TCL_ERROR;
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNRCoroInjectObjCmd, TclNRCoroProbeObjCmd --
+ *
+ *      Implementation of [coroinject] and [coroprobe] commands.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline CoroutineData *
+GetCoroutineFromObj(
+    Tcl_Interp *interp,
+    Tcl_Obj *objPtr,
+    const char *errMsg)
+{
+    /*
+     * How to get a coroutine from its handle.
+     */
+
+    Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);
+
+    if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
+        Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
+        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
+                TclGetString(objPtr), NULL);
+        return NULL;
+    }
+    return cmdPtr->objClientData;
+}
+
+static int
+TclNRCoroInjectObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    CoroutineData *corPtr;
+    ExecEnv *savedEEPtr = iPtr->execEnvPtr;
+
+    /*
+     * Usage more or less like tailcall:
+     *   coroinject coroName cmd ?arg1 arg2 ...?
+     */
+
+    if (objc < 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
+	return TCL_ERROR;
+    }
+
+    corPtr = GetCoroutineFromObj(interp, objv[1],
+            "can only inject a command into a coroutine");
+    if (!corPtr) {
+        return TCL_ERROR;
+    }
+    if (!COR_IS_SUSPENDED(corPtr)) {
+        Tcl_SetObjResult(interp, Tcl_NewStringObj(
+                "can only inject a command into a suspended coroutine", -1));
+        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
+        return TCL_ERROR;
+    }
+
+    /*
+     * Add the callback to the coro's execEnv, so that it is the first thing
+     * to happen when the coro is resumed.
+     */
+
+    iPtr->execEnvPtr = corPtr->eePtr;
+    TclNRAddCallback(interp, InjectHandler, corPtr,
+            Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), NULL);
+    iPtr->execEnvPtr = savedEEPtr;
+
+    return TCL_OK;
+}
+
+static int
+TclNRCoroProbeObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    CoroutineData *corPtr;
+    ExecEnv *savedEEPtr = iPtr->execEnvPtr;
+    int numLevels, unused;
+    int *stackLevel = &unused;
+
+    /*
+     * Usage more or less like tailcall:
+     *   coroprobe coroName cmd ?arg1 arg2 ...?
+     */
+
+    if (objc < 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
+	return TCL_ERROR;
+    }
+
+    corPtr = GetCoroutineFromObj(interp, objv[1],
+            "can only inject a probe command into a coroutine");
+    if (!corPtr) {
+        return TCL_ERROR;
+    }
+    if (!COR_IS_SUSPENDED(corPtr)) {
+        Tcl_SetObjResult(interp, Tcl_NewStringObj(
+                "can only inject a probe command into a suspended coroutine",
+                -1));
+        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
+        return TCL_ERROR;
+    }
+
+    /*
+     * Add the callback to the coro's execEnv, so that it is the first thing
+     * to happen when the coro is resumed.
+     */
+
+    iPtr->execEnvPtr = corPtr->eePtr;
+    TclNRAddCallback(interp, InjectHandler, corPtr,
+            Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), corPtr);
+    iPtr->execEnvPtr = savedEEPtr;
+
+    /*
+     * Now we immediately transfer control to the coroutine to run our probe.
+     * TRICKY STUFF copied from the [yield] implementation.
+     *
+     * Push the callback to restore the caller's context on yield back.
+     */
+
+    TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr,
+            NULL, NULL, NULL);
+
+    /*
+     * Record the stackLevel at which the resume is happening, then swap
+     * the interp's environment to make it suitable to run this coroutine.
+     */
+
+    corPtr->stackLevel = stackLevel;
+    numLevels = corPtr->auxNumLevels;
+    corPtr->auxNumLevels = iPtr->numLevels;
+
+    /*
+     * Do the actual stack swap.
+     */
+
+    SAVE_CONTEXT(corPtr->caller);
+    corPtr->callerEEPtr = iPtr->execEnvPtr;
+    RESTORE_CONTEXT(corPtr->running);
+    iPtr->execEnvPtr = corPtr->eePtr;
+    iPtr->numLevels += numLevels;
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InjectHandler, InjectHandlerPostProc --
+ *
+ *      Part of the implementation of [coroinject] and [coroprobe]. These are
+ *      run inside the context of the coroutine being injected/probed into.
+ *
+ *      InjectHandler runs a script (possibly adding arguments) in the context
+ *      of the coroutine. The script is specified as a one-shot list (with
+ *      reference count equal to 1) in data[1]. This function also arranges
+ *      for InjectHandlerPostProc to be the part that runs after the script
+ *      completes.
+ *
+ *      InjectHandlerPostProc cleans up after InjectHandler (deleting the
+ *      list) and, for the [coroprobe] command *only*, yields back to the
+ *      caller context (i.e., where [coroprobe] was run).
+ *s
+ *----------------------------------------------------------------------
+ */
+
+static int
+InjectHandler(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    CoroutineData *corPtr = data[0];
+    Tcl_Obj *listPtr = data[1];
+    int nargs = PTR2INT(data[2]);
+    ClientData isProbe = data[3];
+    int objc;
+    Tcl_Obj **objv;
+
+    if (!isProbe) {
+        /*
+         * If this is [coroinject], add the extra arguments now.
+         */
+
+        if (nargs == COROUTINE_ARGUMENTS_SINGLE_OPTIONAL) {
+            Tcl_ListObjAppendElement(NULL, listPtr,
+                    Tcl_NewStringObj("yield", -1));
+        } else if (nargs == COROUTINE_ARGUMENTS_ARBITRARY) {
+            Tcl_ListObjAppendElement(NULL, listPtr,
+                    Tcl_NewStringObj("yieldto", -1));
+        } else {
+            /*
+             * I don't think this is reachable...
+             */
+
+            Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewIntObj(nargs));
+        }
+        Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp));
+    }
+
+    /*
+     * Call the user's script; we're in the right place.
+     */
+
+    Tcl_IncrRefCount(listPtr);
+    TclMarkTailcall(interp);
+    TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr,
+            INT2PTR(nargs), isProbe);
+    TclListObjGetElements(NULL, listPtr, &objc, &objv);
+    return TclNREvalObjv(interp, objc, objv, 0, NULL);
+}
+
+static int
+InjectHandlerPostCall(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    CoroutineData *corPtr = data[0];
+    Tcl_Obj *listPtr = data[1];
+    int nargs = PTR2INT(data[2]);
+    ClientData isProbe = data[3];
+    int numLevels;
+
+    /*
+     * Delete the command words for what we just executed.
+     */
+
+    Tcl_DecrRefCount(listPtr);
+
+    /*
+     * If we were doing a probe, splice ourselves back out of the stack
+     * cleanly here. General injection should instead just look after itself.
+     *
+     * Code from guts of [yield] implementation.
+     */
+
+    if (isProbe) {
+        if (result == TCL_ERROR) {
+            Tcl_AddErrorInfo(interp,
+                    "\n    (injected coroutine probe command)");
+        }
+        corPtr->nargs = nargs;
+        corPtr->stackLevel = NULL;
+        numLevels = iPtr->numLevels;
+        iPtr->numLevels = corPtr->auxNumLevels;
+        corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
+        iPtr->execEnvPtr = corPtr->callerEEPtr;
+    }
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NRInjectObjCmd --
  *
  *      Implementation of [::tcl::unsupported::inject] command.
  *
@@ -9193,13 +9553,12 @@ TclNREvalList(
  */
 
 static int
-NRCoroInjectObjCmd(
+NRInjectObjCmd(
     ClientData clientData,
     Tcl_Interp *interp,
     int objc,
     Tcl_Obj *const objv[])
 {
-    Command *cmdPtr;
     CoroutineData *corPtr;
     ExecEnv *savedEEPtr = iPtr->execEnvPtr;
 
@@ -9213,16 +9572,11 @@ NRCoroInjectObjCmd(
 	return TCL_ERROR;
     }
 
-    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
-    if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
-        Tcl_SetObjResult(interp, Tcl_NewStringObj(
-                "can only inject a command into a coroutine", -1));
-        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
-                TclGetString(objv[1]), NULL);
+    corPtr = GetCoroutineFromObj(interp, objv[1],
+            "can only inject a command into a coroutine");
+    if (!corPtr) {
         return TCL_ERROR;
     }
-
-    corPtr = cmdPtr->objClientData;
     if (!COR_IS_SUSPENDED(corPtr)) {
         Tcl_SetObjResult(interp, Tcl_NewStringObj(
                 "can only inject a command into a suspended coroutine", -1));
@@ -9415,9 +9769,12 @@ TclNRCoroutineObjCmd(
     TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
 	    NULL, NULL, NULL);
 
-    /* ensure that the command is looked up in the correct namespace */
+    /*
+     * Ensure that the command is looked up in the correct namespace.
+     */
+
     iPtr->lookupNsPtr = lookupNsPtr;
-    Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);
+    Tcl_NREvalObj(interp, Tcl_NewListObj(objc - 2, objv + 2), 0);
     iPtr->numLevels--;
 
     SAVE_CONTEXT(corPtr->running);

generic/tclBinary.c

@@ -771,7 +771,10 @@ TclAppendBytesToByteArray(
 		"TclAppendBytesToByteArray");
     }
     if (len == 0) {
-	/* Append zero bytes is a no-op. */
+	/*
+	 * Append zero bytes is a no-op.
+	 */
+
 	return;
     }
 

generic/tclCmdAH.c

@@ -1093,6 +1093,7 @@ TclInitFileCmd(
 	{"stat",	FileAttrStatCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 1},
 	{"system",	PathFilesystemCmd,	TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
 	{"tail",	PathTailCmd,		TclCompileBasic1ArgCmd, NULL, NULL, 1},
+	{"tempdir",	TclFileTempDirCmd,	TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
 	{"tempfile",	TclFileTemporaryCmd,	TclCompileBasic0To2ArgCmd, NULL, NULL, 1},
 	{"type",	FileAttrTypeCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 1},
 	{"volumes",	FilesystemVolumesCmd,	TclCompileBasic0ArgCmd, NULL, NULL, 1},

generic/tclCmdIL.c

@@ -56,7 +56,7 @@ typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t);
  * The following structure is used to pass this information.
  */
 
-typedef struct SortInfo {
+typedef struct {
     int isIncreasing;		/* Nonzero means sort in increasing order. */
     int sortMode;		/* The sort mode. One of SORTMODE_* values
 				 * defined below. */
@@ -566,7 +566,7 @@ InfoBodyCmd(
      * the object do not invalidate the internal rep.
      */
 
-    bytes = Tcl_GetStringFromObj(procPtr->bodyPtr, &numBytes);
+    bytes = TclGetStringFromObj(procPtr->bodyPtr, &numBytes);
     Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes));
     return TCL_OK;
 }
@@ -1047,7 +1047,7 @@ InfoErrorStackCmd(
 
     target = interp;
     if (objc == 2) {
-	target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
+	target = Tcl_GetSlave(interp, TclGetString(objv[1]));
 	if (target == NULL) {
 	    return TCL_ERROR;
 	}
@@ -2155,7 +2155,7 @@ InfoCmdTypeCmd(
 	Tcl_WrongNumArgs(interp, 1, objv, "commandName");
 	return TCL_ERROR;
     }
-    command = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL,
+    command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL,
 	    TCL_LEAVE_ERR_MSG);
     if (command == NULL) {
 	return TCL_ERROR;
@@ -2231,7 +2231,7 @@ Tcl_JoinObjCmd(
     joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
     Tcl_IncrRefCount(joinObjPtr);
 
-    (void) Tcl_GetStringFromObj(joinObjPtr, &length);
+    (void) TclGetStringFromObj(joinObjPtr, &length);
     if (length == 0) {
 	resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
     } else {
@@ -2584,7 +2584,7 @@ Tcl_LpopObjCmd(
 				/* Argument objects. */
 {
     int listLen, result;
-    Tcl_Obj *elemPtr;
+    Tcl_Obj *elemPtr, *stored;
     Tcl_Obj *listPtr, **elemPtrs;
 
     if (objc < 2) {
@@ -2622,6 +2622,7 @@ Tcl_LpopObjCmd(
 
     /*
      * Second, remove the element.
+     * TclLsetFlat adds a ref count which is handled.
      */
 
     if (objc == 2) {
@@ -2632,6 +2633,7 @@ Tcl_LpopObjCmd(
 	if (result != TCL_OK) {
 	    return result;
 	}
+	Tcl_IncrRefCount(listPtr);
     } else {
 	listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL);
 
@@ -2640,8 +2642,9 @@ Tcl_LpopObjCmd(
 	}
     }
 
-    listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
-    if (listPtr == NULL) {
+    stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
+    Tcl_DecrRefCount(listPtr);
+    if (stored == NULL) {
 	return TCL_ERROR;
     }
 
@@ -2701,6 +2704,140 @@ Tcl_LrangeObjCmd(
     return TCL_OK;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+LremoveIndexCompare(
+    const void *el1Ptr,
+    const void *el2Ptr)
+{
+    int idx1 = *((const int *) el1Ptr);
+    int idx2 = *((const int *) 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;
+    int listLen, *idxv, prevIdx, first, num;
+    Tcl_Obj *listObj;
+
+    /*
+     * Parse the arguments.
+     */
+
+    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(int));
+    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(int), LremoveIndexCompare);
+    }
+
+    /*
+     * 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++) {
+	int idx = idxv[i];
+
+	/*
+	 * Repeated index and sanity check.
+	 */
+
+	if (idx == prevIdx) {
+	    continue;
+	}
+	prevIdx = idx;
+	if (idx < 0 || idx >= listLen) {
+	    continue;
+	}
+
+	/*
+	 * Coalesce adjacent removes to reduce the number of copies.
+	 */
+
+	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);
+    return TCL_OK;
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -2864,7 +3001,7 @@ Tcl_LreplaceObjCmd(
 	return result;
     }
 
-    if (first < 0) {
+    if (first == TCL_INDEX_NONE) {
 	first = 0;
     }
     if (first > listLen) {
@@ -3243,10 +3380,10 @@ Tcl_LsearchObjCmd(
 			TCL_INDEX_NONE, &encoded) != TCL_OK) {
 		    result = TCL_ERROR;
 		}
-		if (encoded == TCL_INDEX_NONE) {
+		if (encoded == (int)TCL_INDEX_NONE) {
 		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 			    "index \"%s\" cannot select an element "
-			    "from any list", Tcl_GetString(indices[j])));
+			    "from any list", TclGetString(indices[j])));
 		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
 			    "OUTOFRANGE", NULL);
 		    result = TCL_ERROR;
@@ -3376,8 +3513,8 @@ Tcl_LsearchObjCmd(
 	if (result != TCL_OK) {
 	    goto done;
 	}
-	if (start < 0) {
-	    start = 0;
+	if (start == TCL_INDEX_NONE) {
+	    start = TCL_INDEX_START;
 	}
 
 	/*
@@ -3960,10 +4097,10 @@ Tcl_LsortObjCmd(
 		int result = TclIndexEncode(interp, indexv[j],
 			TCL_INDEX_NONE, TCL_INDEX_NONE, &encoded);
 
-		if ((result == TCL_OK) && (encoded == TCL_INDEX_NONE)) {
+		if ((result == TCL_OK) && (encoded == (int)TCL_INDEX_NONE)) {
 		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 			    "index \"%s\" cannot select an element "
-			    "from any list", Tcl_GetString(indexv[j])));
+			    "from any list", TclGetString(indexv[j])));
 		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
 			    "OUTOFRANGE", NULL);
 		    result = TCL_ERROR;
@@ -4182,7 +4319,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) {
 	    /*
@@ -4720,7 +4857,7 @@ SelectObjFromSublist(
 	    return NULL;
 	}
 	if (currentObj == NULL) {
-	    if (index == TCL_INDEX_NONE) {
+	    if (index == (int)TCL_INDEX_NONE) {
 		index = TCL_INDEX_END - infoPtr->indexv[i];
 		Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
 			"element end-%d missing from sublist \"%s\"",

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;
 	}
 
@@ -4133,11 +4135,12 @@ Tcl_TimeObjCmd(
  *
  *	This object-based procedure is invoked to process the "timerate" Tcl
  *	command.
+ *
  *	This is similar to command "time", except the execution limited by
  *	given time (in milliseconds) instead of repetition count.
  *
  * Example:
- *	timerate {after 5} 1000 ; # equivalent for `time {after 5} [expr 1000/5]`
+ *	timerate {after 5} 1000; # equivalent to: time {after 5} [expr 1000/5]
  *
  * Results:
  *	A standard Tcl object result.
@@ -4155,39 +4158,41 @@ Tcl_TimeRateObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
-    static double measureOverhead = 0; /* global measure-overhead */
+    static double measureOverhead = 0;
+				/* global measure-overhead */
     double overhead = -1;	/* given measure-overhead */
     register Tcl_Obj *objPtr;
     register int result, i;
     Tcl_Obj *calibrate = NULL, *direct = NULL;
     Tcl_WideUInt count = 0;	/* Holds repetition count */
-    Tcl_WideInt  maxms  = WIDE_MIN;
+    Tcl_WideInt maxms = WIDE_MIN;
 				/* Maximal running time (in milliseconds) */
     Tcl_WideUInt maxcnt = WIDE_MAX;
 				/* Maximal count of iterations. */
     Tcl_WideUInt threshold = 1;	/* Current threshold for check time (faster
 				 * repeat count without time check) */
-    Tcl_WideUInt maxIterTm = 1;	/* Max time of some iteration as max threshold
-				 * additionally avoid divide to zero (never < 1) */
+    Tcl_WideUInt maxIterTm = 1;	/* Max time of some iteration as max
+				 * threshold, additionally avoiding divide to
+				 * zero (i.e., never < 1) */
     unsigned short factor = 50;	/* Factor (4..50) limiting threshold to avoid
 				 * growth of execution time. */
     register Tcl_WideInt start, middle, stop;
 #ifndef TCL_WIDE_CLICKS
     Tcl_Time now;
-#endif
-
+#endif /* !TCL_WIDE_CLICKS */
     static const char *const options[] = {
 	"-direct",	"-overhead",	"-calibrate",	"--",	NULL
     };
     enum options {
 	TMRT_EV_DIRECT,	TMRT_OVERHEAD,	TMRT_CALIBRATE,	TMRT_LAST
     };
-
     NRE_callback *rootPtr;
-    ByteCode	 *codePtr = NULL;
+    ByteCode *codePtr = NULL;
+    int codeOptimized = 0;
 
     for (i = 1; i < objc - 1; i++) {
-    	int index;
+	int index;
+
 	if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT,
 		&index) != TCL_OK) {
 	    break;
@@ -4214,9 +4219,11 @@ Tcl_TimeRateObjCmd(
 	}
     }
 
-    if (i >= objc || i < objc-3) {
-usage:
-	Tcl_WrongNumArgs(interp, 1, objv, "?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??");
+    if (i >= objc || i < objc - 3) {
+    usage:
+	Tcl_WrongNumArgs(interp, 1, objv,
+		"?-direct? ?-calibrate? ?-overhead double? "
+		"command ?time ?max-count??");
 	return TCL_ERROR;
     }
     objPtr = objv[i++];
@@ -4227,6 +4234,7 @@ usage:
 	}
 	if (i < objc) {	/* max-count*/
 	    Tcl_WideInt v;
+
 	    result = Tcl_GetWideIntFromObj(interp, objv[i], &v);
 	    if (result != TCL_OK) {
 		return result;
@@ -4235,10 +4243,15 @@ usage:
 	}
     }
 
-    /* if calibrate */
+    /*
+     * If we are doing calibration.
+     */
+
     if (calibrate) {
+	/*
+	 * If no time specified for the calibration.
+	 */
 
-	/* if no time specified for the calibration */
 	if (maxms == WIDE_MIN) {
 	    Tcl_Obj *clobjv[6];
 	    Tcl_WideInt maxCalTime = 5000;
@@ -4247,18 +4260,24 @@ usage:
 	    clobjv[0] = objv[0];
 	    i = 1;
 	    if (direct) {
-	    	clobjv[i++] = direct;
+		clobjv[i++] = direct;
 	    }
 	    clobjv[i++] = objPtr;
 
-	    /* reset last measurement overhead */
-	    measureOverhead = (double)0;
+	    /*
+	     * Reset last measurement overhead.
+	     */
+
+	    measureOverhead = (double) 0;
+
+	    /*
+	     * Self-call with 100 milliseconds to warm-up, before entering the
+	     * calibration cycle.
+	     */
 
-	    /* self-call with 100 milliseconds to warm-up,
-	     * before entering the calibration cycle */
 	    TclNewIntObj(clobjv[i], 100);
 	    Tcl_IncrRefCount(clobjv[i]);
-	    result = Tcl_TimeRateObjCmd(dummy, interp, i+1, clobjv);
+	    result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv);
 	    Tcl_DecrRefCount(clobjv[i]);
 	    if (result != TCL_OK) {
 		return result;
@@ -4268,241 +4287,385 @@ usage:
 	    clobjv[i++] = calibrate;
 	    clobjv[i++] = objPtr;
 
-	    /* set last measurement overhead to max */
-	    measureOverhead = (double)UWIDE_MAX;
+	    /*
+	     * Set last measurement overhead to max.
+	     */
+
+	    measureOverhead = (double) UWIDE_MAX;
+
+	    /*
+	     * Run the calibration cycle until it is more precise.
+	     */
 
-	    /* calibration cycle until it'll be preciser */
 	    maxms = -1000;
 	    do {
 		lastMeasureOverhead = measureOverhead;
-		TclNewIntObj(clobjv[i], (int)maxms);
+		TclNewIntObj(clobjv[i], (int) maxms);
 		Tcl_IncrRefCount(clobjv[i]);
-		result = Tcl_TimeRateObjCmd(dummy, interp, i+1, clobjv);
+		result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv);
 		Tcl_DecrRefCount(clobjv[i]);
 		if (result != TCL_OK) {
 		    return result;
 		}
 		maxCalTime += maxms;
-		/* increase maxms for preciser calibration */
-		maxms -= (-maxms / 4);
-		/* as long as new value more as 0.05% better */
-	    } while ( (measureOverhead >= lastMeasureOverhead
+
+		/*
+		 * Increase maxms for more precise calibration.
+		 */
+
+		maxms -= -maxms / 4;
+
+		/*
+		 * As long as new value more as 0.05% better
+		 */
+	    } while ((measureOverhead >= lastMeasureOverhead
 		    || measureOverhead / lastMeasureOverhead <= 0.9995)
-		    && maxCalTime > 0
-	    );
+		    && maxCalTime > 0);
 
 	    return result;
 	}
 	if (maxms == 0) {
-	    /* reset last measurement overhead */
+	    /*
+	     * Reset last measurement overhead
+	     */
+
 	    measureOverhead = 0;
 	    Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
 	    return TCL_OK;
 	}
 
-	/* if time is negative - make current overhead more precise */
+	/*
+	 * If time is negative, make current overhead more precise.
+	 */
+
 	if (maxms > 0) {
-	    /* set last measurement overhead to max */
-	    measureOverhead = (double)UWIDE_MAX;
+	    /*
+	     * Set last measurement overhead to max.
+	     */
+
+	    measureOverhead = (double) UWIDE_MAX;
 	} else {
 	    maxms = -maxms;
 	}
-
     }
 
     if (maxms == WIDE_MIN) {
-    	maxms = 1000;
+	maxms = 1000;
     }
     if (overhead == -1) {
 	overhead = measureOverhead;
     }
 
-    /* be sure that resetting of result will not smudge the further measurement */
+    /*
+     * Ensure that resetting of result will not smudge the further
+     * measurement.
+     */
+
     Tcl_ResetResult(interp);
 
-    /* compile object */
+    /*
+     * Compile object if needed.
+     */
+
     if (!direct) {
 	if (TclInterpReady(interp) != TCL_OK) {
 	    return TCL_ERROR;
 	}
 	codePtr = TclCompileObj(interp, objPtr, NULL, 0);
 	TclPreserveByteCode(codePtr);
+	/*
+	 * Replace last compiled done instruction with continue: it's a part of
+	 * iteration, this way evaluation will be more similar to a cycle (also
+	 * avoids extra overhead to set result to interp, etc.)
+	 */
+	if (codePtr->codeStart[codePtr->numCodeBytes-1] == INST_DONE) {
+	    codePtr->codeStart[codePtr->numCodeBytes-1] = INST_CONTINUE;
+	    codeOptimized = 1;
+	}
     }
 
-    /* get start and stop time */
+    /*
+     * Get start and stop time.
+     */
+
 #ifdef TCL_WIDE_CLICKS
     start = middle = TclpGetWideClicks();
-    /* time to stop execution (in wide clicks) */
+
+    /*
+     * Time to stop execution (in wide clicks).
+     */
+
     stop = start + (maxms * 1000 / TclpWideClickInMicrosec());
 #else
     Tcl_GetTime(&now);
-    start = now.sec; start *= 1000000; start += now.usec;
+    start = now.sec;
+    start *= 1000000;
+    start += now.usec;
     middle = start;
-    /* time to stop execution (in microsecs) */
+
+    /*
+     * Time to stop execution (in microsecs).
+     */
+
     stop = start + maxms * 1000;
-#endif
+#endif /* TCL_WIDE_CLICKS */
 
-    /* start measurement */
-    if (maxcnt > 0)
-    while (1) {
-    	/* eval single iteration */
-    	count++;
+    /*
+     * Start measurement.
+     */
 
-	if (!direct) {
-	    /* precompiled */
-	    rootPtr = TOP_CB(interp);
-	    result = TclNRExecuteByteCode(interp, codePtr);
-	    result = TclNRRunCallbacks(interp, result, rootPtr);
-	} else {
-	    /* eval */
-	    result = TclEvalObjEx(interp, objPtr, 0, NULL, 0);
-	}
-	if (result != TCL_OK) {
-	    /* allow break from measurement cycle (used for conditional stop) */
-	    if (result != TCL_BREAK) {
-		goto done;
+    if (maxcnt > 0) {
+	while (1) {
+	    /*
+	     * Evaluate a single iteration.
+	     */
+
+	    count++;
+	    if (!direct) {		/* precompiled */
+		rootPtr = TOP_CB(interp);
+		result = TclNRExecuteByteCode(interp, codePtr);
+		result = TclNRRunCallbacks(interp, result, rootPtr);
+	    } else {			/* eval */
+		result = TclEvalObjEx(interp, objPtr, 0, NULL, 0);
 	    }
-	    /* force stop immediately */
-	    threshold = 1;
-	    maxcnt = 0;
-	    result = TCL_OK;
-	}
+	    /*
+	     * Allow break and continue from measurement cycle (used for
+	     * conditional stop and flow control of iterations).
+	     */
 
-	/* don't check time up to threshold */
-	if (--threshold > 0) continue;
-
-	/* check stop time reached, estimate new threshold */
-    #ifdef TCL_WIDE_CLICKS
-	middle = TclpGetWideClicks();
-    #else
-	Tcl_GetTime(&now);
-	middle = now.sec; middle *= 1000000; middle += now.usec;
-    #endif
-	if (middle >= stop || count >= maxcnt) {
-	    break;
-	}
-
-	/* don't calculate threshold by few iterations, because sometimes first
-	 * iteration(s) can be too fast or slow (cached, delayed clean up, etc) */
-	if (count < 10) {
-	   threshold = 1; continue;
-	}
-
-	/* average iteration time in microsecs */
-	threshold = (middle - start) / count;
-	if (threshold > maxIterTm) {
-	    maxIterTm = threshold;
-	    /* interations seems to be longer */
-	    if (threshold > (maxIterTm * 2)) {
-		if ((factor *= 2) > 50) factor = 50;
-	    } else {
-		if (factor < 50) factor++;
+	    switch (result) {
+		case TCL_OK:
+		    break;
+		case TCL_BREAK:
+		    /*
+		     * Force stop immediately.
+		     */
+		    threshold = 1;
+		    maxcnt = 0;
+		case TCL_CONTINUE:
+		    result = TCL_OK;
+		    break;
+		default:
+		    goto done;
 	    }
-	} else if (factor > 4) {
-	    /* interations seems to be shorter */
-	    if (threshold < (maxIterTm / 2)) {
-		if ((factor /= 2) < 4) factor = 4;
-	    } else {
-		factor--;
+
+	    /*
+	     * Don't check time up to threshold.
+	     */
+
+	    if (--threshold > 0) {
+		continue;
+	    }
+
+	    /*
+	     * Check stop time reached, estimate new threshold.
+	     */
+
+#ifdef TCL_WIDE_CLICKS
+	    middle = TclpGetWideClicks();
+#else
+	    Tcl_GetTime(&now);
+	    middle = now.sec;
+	    middle *= 1000000;
+	    middle += now.usec;
+#endif /* TCL_WIDE_CLICKS */
+
+	    if (middle >= stop || count >= maxcnt) {
+		break;
+	    }
+
+	    /*
+	     * Don't calculate threshold by few iterations, because sometimes
+	     * first iteration(s) can be too fast or slow (cached, delayed
+	     * clean up, etc).
+	     */
+
+	    if (count < 10) {
+		threshold = 1;
+		continue;
+	    }
+
+	    /*
+	     * Average iteration time in microsecs.
+	     */
+
+	    threshold = (middle - start) / count;
+	    if (threshold > maxIterTm) {
+		maxIterTm = threshold;
+
+		/*
+		 * Iterations seem to be longer.
+		 */
+
+		if (threshold > maxIterTm * 2) {
+		    factor *= 2;
+		    if (factor > 50) {
+			factor = 50;
+		    }
+		} else {
+		    if (factor < 50) {
+			factor++;
+		    }
+		}
+	    } else if (factor > 4) {
+		/*
+		 * Iterations seem to be shorter.
+		 */
+
+		if (threshold < (maxIterTm / 2)) {
+		    factor /= 2;
+		    if (factor < 4) {
+			factor = 4;
+		    }
+		} else {
+		    factor--;
+		}
+	    }
+
+	    /*
+	     * As relation between remaining time and time since last check,
+	     * maximal some % of time (by factor), so avoid growing of the
+	     * execution time if iterations are not consistent, e.g. was
+	     * continuously on time).
+	     */
+
+	    threshold = ((stop - middle) / maxIterTm) / factor + 1;
+	    if (threshold > 100000) {	/* fix for too large threshold */
+		threshold = 100000;
+	    }
+
+	    /*
+	     * Consider max-count
+	     */
+
+	    if (threshold > maxcnt - count) {
+		threshold = maxcnt - count;
 	    }
-	}
-	/* as relation between remaining time and time since last check,
-	 * maximal some % of time (by factor), so avoid growing of the execution time
-	 * if iterations are not consistent, e. g. wax continuously on time) */
-	threshold = ((stop - middle) / maxIterTm) / factor + 1;
-	if (threshold > 100000) {	    /* fix for too large threshold */
-	    threshold = 100000;
-	}
-	/* consider max-count */
-	if (threshold > maxcnt - count) {
-	    threshold = maxcnt - count;
 	}
     }
 
     {
 	Tcl_Obj *objarr[8], **objs = objarr;
-	Tcl_WideInt val;
-	const char *fmt;
+	Tcl_WideUInt usec, val;
+	int digits;
 
-	middle -= start;		     /* execution time in microsecs */
+	/*
+	 * Absolute execution time in microseconds or in wide clicks.
+	 */
+	usec = (Tcl_WideUInt)(middle - start);
 
-    #ifdef TCL_WIDE_CLICKS
-	/* convert execution time in wide clicks to microsecs */
-	middle *= TclpWideClickInMicrosec();
-    #endif
+#ifdef TCL_WIDE_CLICKS
+	/*
+	 * convert execution time (in wide clicks) to microsecs.
+	 */
 
-	if (!count) { /* no iterations - avoid divide by zero */
+	usec *= TclpWideClickInMicrosec();
+#endif /* TCL_WIDE_CLICKS */
+
+	if (!count) {		/* no iterations - avoid divide by zero */
 	    objs[0] = objs[2] = objs[4] = Tcl_NewWideIntObj(0);
 	    goto retRes;
 	}
 
-	/* if not calibrate */
+	/*
+	 * If not calibrating...
+	 */
+
 	if (!calibrate) {
-	    /* minimize influence of measurement overhead */
+	    /*
+	     * Minimize influence of measurement overhead.
+	     */
+
 	    if (overhead > 0) {
-		/* estimate the time of overhead (microsecs) */
+		/*
+		 * Estimate the time of overhead (microsecs).
+		 */
+
 		Tcl_WideUInt curOverhead = overhead * count;
-		if (middle > (Tcl_WideInt)curOverhead) {
-		    middle -= curOverhead;
+
+		if (usec > curOverhead) {
+		    usec -= curOverhead;
 		} else {
-		    middle = 0;
+		    usec = 0;
 		}
 	    }
 	} else {
-	    /* calibration - obtaining new measurement overhead */
-	    if (measureOverhead > (double)middle / count) {
-		measureOverhead = (double)middle / count;
+	    /*
+	     * Calibration: obtaining new measurement overhead.
+	     */
+
+	    if (measureOverhead > ((double) usec) / count) {
+		measureOverhead = ((double) usec) / count;
 	    }
 	    objs[0] = Tcl_NewDoubleObj(measureOverhead);
 	    TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */
 	    objs += 2;
 	}
 
-	val = middle / count;		     /* microsecs per iteration */
+	val = usec / count;		/* microsecs per iteration */
 	if (val >= 1000000) {
 	    objs[0] = Tcl_NewWideIntObj(val);
 	} else {
-	    if (val < 10)    { fmt = "%.6f"; } else
-	    if (val < 100)   { fmt = "%.4f"; } else
-	    if (val < 1000)  { fmt = "%.3f"; } else
-	    if (val < 10000) { fmt = "%.2f"; } else
-			     { fmt = "%.1f"; };
-	    objs[0] = Tcl_ObjPrintf(fmt, ((double)middle)/count);
+	    if (val < 10) {
+		digits = 6;
+	    } else if (val < 100) {
+		digits = 4;
+	    } else if (val < 1000) {
+		digits = 3;
+	    } else if (val < 10000) {
+		digits = 2;
+	    } else {
+		digits = 1;
+	    }
+	    objs[0] = Tcl_ObjPrintf("%.*f", digits, ((double) usec)/count);
 	}
 
 	objs[2] = Tcl_NewWideIntObj(count); /* iterations */
 
-	/* calculate speed as rate (count) per sec */
-	if (!middle) middle++; /* +1 ms, just to avoid divide by zero */
+	/*
+	 * Calculate speed as rate (count) per sec
+	 */
+
+	if (!usec) {
+	    usec++;			/* Avoid divide by zero. */
+	}
 	if (count < (WIDE_MAX / 1000000)) {
-	    val = (count * 1000000) / middle;
+	    val = (count * 1000000) / usec;
 	    if (val < 100000) {
-		if (val < 100)	{ fmt = "%.3f"; } else
-		if (val < 1000) { fmt = "%.2f"; } else
-				{ fmt = "%.1f"; };
-		objs[4] = Tcl_ObjPrintf(fmt, ((double)(count * 1000000)) / middle);
+		if (val < 100) {
+		    digits = 3;
+		} else if (val < 1000) {
+		    digits = 2;
+		} else {
+		    digits = 1;
+		}
+		objs[4] = Tcl_ObjPrintf("%.*f",
+			digits, ((double) (count * 1000000)) / usec);
 	    } else {
 		objs[4] = Tcl_NewWideIntObj(val);
 	    }
 	} else {
-	    objs[4] = Tcl_NewWideIntObj((count / middle) * 1000000);
+	    objs[4] = Tcl_NewWideIntObj((count / usec) * 1000000);
 	}
 
     retRes:
-	/* estimated net execution time (in millisecs) */
+	/*
+	 * Estimated net execution time (in millisecs).
+	 */
+
 	if (!calibrate) {
-	    if (middle >= 1) {
-		objs[6] = Tcl_ObjPrintf("%.3f", (double)middle / 1000);
+	    if (usec >= 1) {
+		objs[6] = Tcl_ObjPrintf("%.3f", (double)usec / 1000);
 	    } else {
 		objs[6] = Tcl_NewWideIntObj(0);
 	    }
-	    TclNewLiteralStringObj(objs[7], "nett-ms");
+	    TclNewLiteralStringObj(objs[7], "net-ms");
 	}
 
 	/*
-	* Construct the result as a list because many programs have always parsed
-	* as such (extracting the first element, typically).
-	*/
+	 * Construct the result as a list because many programs have always
+	 * parsed as such (extracting the first element, typically).
+	 */
 
 	TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#"); /* mics/# */
 	TclNewLiteralStringObj(objs[3], "#");
@@ -4510,12 +4673,15 @@ usage:
 	Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr));
     }
 
-done:
-
+  done:
     if (codePtr != NULL) {
+	if ( codeOptimized
+	  && codePtr->codeStart[codePtr->numCodeBytes-1] == INST_CONTINUE
+	) {
+	    codePtr->codeStart[codePtr->numCodeBytes-1] = INST_DONE;
+	}
 	TclReleaseByteCode(codePtr);
     }
-
     return result;
 }
 
@@ -5208,6 +5374,147 @@ TclListLines(
     }
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitPragmaCmd --
+ *
+ *	This function creates the 'tcl::pragma' Tcl command.
+ *	Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ *	Returns a standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+TclInitPragmaCmd(
+    Tcl_Interp *interp)
+{
+    static const EnsembleImplMap pragmaImplMap[] = {
+	{"noalias", TclPragmaNoAliasCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
+	{"type",    TclPragmaTypeCmd,	 TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
+	{NULL, NULL, NULL, NULL, NULL, 0}
+    };
+    Tcl_Command prefixCmd;
+
+    prefixCmd = TclMakeEnsemble(interp, "::tcl::pragma", pragmaImplMap);
+    Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0),
+	    "prefix", 0);
+    return prefixCmd;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPragmaTypeCmd --
+ *
+ *	This function implements the 'tcl::pragma type' Tcl command.
+ *	Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ *	Returns a standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+TclPragmaTypeCmd(
+    ClientData clientData,	/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    enum PragmaTypes {
+	BOOL_TYPE, DICT_TYPE, DOUBLE_TYPE, INT32_TYPE, INT64_TYPE,
+	INTEGER_TYPE, LIST_TYPE, NUMBER_TYPE
+    };
+    static const char *types[] = {
+	"boolean", "dict", "double", "int32", "int64", "integer", "list",
+	"number", NULL
+    };
+    int idx, i;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "typeName ?value...?");
+	return TCL_ERROR;
+    }
+    if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0,
+	    &idx) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Check that the type constraint actually holds for all remaining values.
+     */
+
+    for (i=2 ; i<objc ; i++) {
+	Tcl_Obj *valuePtr = objv[i];
+	double dval;
+	int bval, len, i32val;
+	Tcl_WideInt i64val;
+	ClientData cdval;
+
+	switch ((enum PragmaTypes) idx) {
+	case BOOL_TYPE:
+	    if (Tcl_GetBooleanFromObj(interp, valuePtr, &bval) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    break;
+	case DICT_TYPE:
+	    if (Tcl_DictObjSize(interp, valuePtr, &len) != TCL_OK) {
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"expected dict value but got \"%s\"",
+			Tcl_GetString(valuePtr)));
+		return TCL_ERROR;
+	    }
+	    break;
+	case DOUBLE_TYPE:
+	    if (Tcl_GetDoubleFromObj(interp, valuePtr, &dval) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    break;
+	case INT32_TYPE:
+	    if (Tcl_GetIntFromObj(interp, valuePtr, &i32val) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    break;
+	case INT64_TYPE:
+	    if (Tcl_GetWideIntFromObj(interp, valuePtr, &i64val) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    break;
+	case LIST_TYPE:
+	    if (Tcl_ListObjLength(interp, valuePtr, &len) != TCL_OK) {
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"expected list value but got \"%s\"",
+			Tcl_GetString(valuePtr)));
+		return TCL_ERROR;
+	    }
+	    break;
+	case INTEGER_TYPE:
+	    if (TclGetWideBitsFromObj(interp, valuePtr, &i64val) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    break;
+	case NUMBER_TYPE:
+	    if (TclGetNumberFromObj(interp, valuePtr, &cdval, &bval) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    break;
+	}
+    }
+    return TCL_OK;
+}
+
 /*
  * Local Variables:
  * mode: c

generic/tclCompCmds.c

@@ -1176,6 +1176,38 @@ TclCompileDictGetCmd(
     return TCL_OK;
 }
 
+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 ; i<parsePtr->numWords ; 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. */

generic/tclCompCmdsGR.c

@@ -433,7 +433,7 @@ TclCompileIfCmd(
 		jumpFalseDist += 3;
 		TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
 	    } else {
-		Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode);
+		Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", opCode);
 	    }
 	}
     }
@@ -606,7 +606,7 @@ TclCompileInfoCommandsCmd(
     if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
 	goto notCompilable;
     }
-    bytes = Tcl_GetString(objPtr);
+    bytes = TclGetString(objPtr);
 
     /*
      * We require that the argument start with "::" and not have any of "*\[?"
@@ -1038,7 +1038,7 @@ TclCompileLassignCmd(
      */
 
     TclEmitInstInt4(		INST_LIST_RANGE_IMM, idx,	envPtr);
-    TclEmitInt4(			TCL_INDEX_END,		envPtr);
+    TclEmitInt4(			(int)TCL_INDEX_END,		envPtr);
 
     return TCL_OK;
 }
@@ -1243,7 +1243,7 @@ TclCompileListCmd(
 
     if (concat && numWords == 2) {
 	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,	envPtr);
-	TclEmitInt4(			TCL_INDEX_END,	envPtr);
+	TclEmitInt4(			(int)TCL_INDEX_END,	envPtr);
     }
     return TCL_OK;
 }
@@ -1319,7 +1319,7 @@ TclCompileLrangeCmd(
 
     tokenPtr = TokenAfter(listTokenPtr);
     if ((TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE,
-	    &idx1) != TCL_OK) || (idx1 == TCL_INDEX_NONE)) {
+	    &idx1) != TCL_OK) || (idx1 == (int)TCL_INDEX_NONE)) {
 	return TCL_ERROR;
     }
     /*
@@ -1408,7 +1408,7 @@ TclCompileLinsertCmd(
     CompileWord(envPtr, listTokenPtr, interp, 1);
     if (parsePtr->numWords == 3) {
 	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);
-	TclEmitInt4(			TCL_INDEX_END,		envPtr);
+	TclEmitInt4(			(int)TCL_INDEX_END,		envPtr);
 	return TCL_OK;
     }
 
@@ -1418,10 +1418,10 @@ TclCompileLinsertCmd(
     }
     TclEmitInstInt4(		INST_LIST, i - 3,		envPtr);
 
-    if (idx == TCL_INDEX_START) {
+    if (idx == (int)TCL_INDEX_START) {
 	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
 	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
-    } else if (idx == TCL_INDEX_END) {
+    } else if (idx == (int)TCL_INDEX_END) {
 	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
     } else {
 	/*
@@ -1436,7 +1436,7 @@ TclCompileLinsertCmd(
 	 * differ in their interpretation of the "end" index.
 	 */
 
-	if (idx < TCL_INDEX_END) {
+	if (idx < (int)TCL_INDEX_END) {
 	    idx++;
 	}
 	TclEmitInstInt4(	INST_OVER, 1,			envPtr);
@@ -1444,7 +1444,7 @@ TclCompileLinsertCmd(
 	TclEmitInt4(			idx - 1,		envPtr);
 	TclEmitInstInt4(	INST_REVERSE, 3,		envPtr);
 	TclEmitInstInt4(	INST_LIST_RANGE_IMM, idx,	envPtr);
-	TclEmitInt4(			TCL_INDEX_END,		envPtr);
+	TclEmitInt4(			(int)TCL_INDEX_END,		envPtr);
 	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
 	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
     }
@@ -1505,14 +1505,14 @@ TclCompileLreplaceCmd(
      * we must defer to direct evaluation.
      */
 
-    if (idx1 == TCL_INDEX_NONE) {
-	suffixStart = TCL_INDEX_NONE;
-    } else if (idx2 == TCL_INDEX_NONE) {
+    if (idx1 == (int)TCL_INDEX_NONE) {
+	suffixStart = (int)TCL_INDEX_NONE;
+    } else if (idx2 == (int)TCL_INDEX_NONE) {
 	suffixStart = idx1;
-    } else if (idx2 == TCL_INDEX_END) {
-	suffixStart = TCL_INDEX_NONE;
-    } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END))
-	    || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) {
+    } else if (idx2 == (int)TCL_INDEX_END) {
+	suffixStart = (int)TCL_INDEX_NONE;
+    } else if (((idx2 < (int)TCL_INDEX_END) && (idx1 <= (int)TCL_INDEX_END))
+	    || ((idx2 >= (int)TCL_INDEX_START) && (idx1 >= (int)TCL_INDEX_START))) {
 	suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1;
     } else {
 	return TCL_ERROR;
@@ -1546,11 +1546,11 @@ TclCompileLreplaceCmd(
 	 * and canonicalization side effects.
 	 */
 	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);
-	TclEmitInt4(			TCL_INDEX_END,		envPtr);
+	TclEmitInt4(			(int)TCL_INDEX_END,		envPtr);
 	return TCL_OK;
     }
 
-    if (idx1 != TCL_INDEX_START) {
+    if (idx1 != (int)TCL_INDEX_START) {
 	/* Prefix may not be empty; generate bytecode to push it */
 	if (emptyPrefix) {
 	    TclEmitOpcode(	INST_DUP,			envPtr);
@@ -1570,7 +1570,7 @@ TclCompileLreplaceCmd(
 	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
     }
 
-    if (suffixStart == TCL_INDEX_NONE) {
+    if (suffixStart == (int)TCL_INDEX_NONE) {
 	TclEmitOpcode(		INST_POP,			envPtr);
 	if (emptyPrefix) {
 	    PushStringLiteral(envPtr, "");
@@ -1578,7 +1578,7 @@ TclCompileLreplaceCmd(
     } else {
 	/* Suffix may not be empty; generate bytecode to push it */
 	TclEmitInstInt4(	INST_LIST_RANGE_IMM, suffixStart, envPtr);
-	TclEmitInt4(			TCL_INDEX_END,		envPtr);
+	TclEmitInt4(			(int)TCL_INDEX_END,		envPtr);
 	if (!emptyPrefix) {
 	    TclEmitOpcode(	INST_LIST_CONCAT,		envPtr);
 	}
@@ -2295,8 +2295,8 @@ TclCompileRegsubCmd(
     if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
 	goto done;
     }
-    if (Tcl_GetString(patternObj)[0] == '-') {
-	if (strcmp(Tcl_GetString(patternObj), "--") != 0
+    if (TclGetString(patternObj)[0] == '-') {
+	if (strcmp(TclGetString(patternObj), "--") != 0
 		|| parsePtr->numWords == 5) {
 	    goto done;
 	}
@@ -2361,7 +2361,7 @@ TclCompileRegsubCmd(
 	bytes++;
     }
   isSimpleGlob:
-    for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) {
+    for (bytes = TclGetString(replacementObj); *bytes; bytes++) {
 	switch (*bytes) {
 	case '\\': case '&':
 	    goto done;

generic/tclCompCmdsSZ.c

@@ -482,16 +482,16 @@ TclCompileStringInsertCmd(
     tokenPtr = TokenAfter(tokenPtr);
     CompileWord(envPtr, tokenPtr, interp, 3);
 
-    if (idx == TCL_INDEX_START) {
+    if (idx == (int)TCL_INDEX_START) {
 	/* Prepend the insertion string */
 	OP4(	REVERSE, 2);
 	OP1(	STR_CONCAT1, 2);
-    } else  if (idx == TCL_INDEX_END) {
+    } else  if (idx == (int)TCL_INDEX_END) {
 	/* Append the insertion string */
 	OP1(	STR_CONCAT1, 2);
     } else {
 	/* Prefix + insertion + suffix */
-	if (idx < TCL_INDEX_END) {
+	if (idx < (int)TCL_INDEX_END) {
 	    /* See comments in compiler for [linsert]. */
 	    idx++;
 	}
@@ -821,7 +821,7 @@ TclCompileStringMatchCmd(
 	}
 	str = tokenPtr[1].start;
 	length = tokenPtr[1].size;
-	if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) {
+	if ((length <= 1) || strncmp(str, "-nocase", length)) {
 	    /*
 	     * Fail at run time, not in compilation.
 	     */
@@ -1012,7 +1012,7 @@ TclCompileStringRangeCmd(
      * the string the same as the start of the string.
      */
 
-    if (idx1 == TCL_INDEX_NONE) {
+    if (idx1 == (int)TCL_INDEX_NONE) {
 	/* [string range $s end+1 $last] must be empty string */
 	OP(		POP);
 	PUSH(		"");
@@ -1027,7 +1027,7 @@ TclCompileStringRangeCmd(
      * Token parsed as an index expression. We treat all indices after
      * the string the same as the end of the string.
      */
-    if (idx2 == TCL_INDEX_NONE) {
+    if (idx2 == (int)TCL_INDEX_NONE) {
 	/* [string range $s $first -1] must be empty string */
 	OP(		POP);
 	PUSH(		"");
@@ -1105,8 +1105,8 @@ TclCompileStringReplaceCmd(
      * compile direct to bytecode implementing the no-op.
      */
 
-    if ((last == TCL_INDEX_NONE)		/* Know (last < 0) */
-	    || (first == TCL_INDEX_NONE)	/* Know (first > end) */
+    if ((last == (int)TCL_INDEX_NONE)		/* Know (last < 0) */
+	    || (first == (int)TCL_INDEX_NONE)	/* Know (first > end) */
 
 	/*
 	 * Tricky to determine when runtime (last < first) can be
@@ -1117,7 +1117,7 @@ TclCompileStringReplaceCmd(
 	 *	(last <= TCL_INDEX END) && (last < first) => ACCEPT
 	 *	else => cannot tell REJECT
 	 */
-	    || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END)
+	    || ((first <= (int)TCL_INDEX_END) && (last <= (int)TCL_INDEX_END)
 		&& (last < first))		/* Know (last < first) */
 	/*
 	 * (first == TCL_INDEX_NONE) &&
@@ -1128,7 +1128,7 @@ TclCompileStringReplaceCmd(
 	 *	(last <= TCL_INDEX_END) => cannot tell REJECT
 	 *	else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT
 	 */
-	    || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START)
+	    || ((first >= (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)
 		&& (last < first))) {		/* Know (last < first) */
 	if (parsePtr->numWords == 5) {
 	    tokenPtr = TokenAfter(tokenPtr);
@@ -1179,7 +1179,7 @@ TclCompileStringReplaceCmd(
      * getting a guarantee that first <= last.
      */
 
-    if ((first == TCL_INDEX_START) && (last >= TCL_INDEX_START)) {
+    if ((first == (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)) {
 	/* empty prefix */
 	tokenPtr = TokenAfter(tokenPtr);
 	CompileWord(envPtr, tokenPtr, interp, 4);
@@ -1187,13 +1187,13 @@ TclCompileStringReplaceCmd(
 	if (last == INT_MAX) {
 	    OP(		POP);		/* Pop  original */
 	} else {
-	    OP44(	STR_RANGE_IMM, last + 1, TCL_INDEX_END);
+	    OP44(	STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
 	    OP1(	STR_CONCAT1, 2);
 	}
 	return TCL_OK;
     }
 
-    if ((last == TCL_INDEX_NONE) && (first <= TCL_INDEX_END)) {
+    if ((last == (int)TCL_INDEX_NONE) && (first <= (int)TCL_INDEX_END)) {
 	OP44(		STR_RANGE_IMM, 0, first-1);
 	tokenPtr = TokenAfter(tokenPtr);
 	CompileWord(envPtr, tokenPtr, interp, 4);
@@ -1210,19 +1210,19 @@ TclCompileStringReplaceCmd(
 	 * are harmless when they are replaced by another empty string.
 	 */
 
-	if (first == TCL_INDEX_START) {
+	if (first == (int)TCL_INDEX_START) {
 	    /* empty prefix - build suffix only */
 
-	    if (last == TCL_INDEX_END) {
+	    if (last == (int)TCL_INDEX_END) {
 		/* empty suffix too => empty result */
 		OP(	POP);		/* Pop  original */
 		PUSH	(	"");
 		return TCL_OK;
 	    }
-	    OP44(	STR_RANGE_IMM, last + 1, TCL_INDEX_END);
+	    OP44(	STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
 	    return TCL_OK;
 	} else {
-	    if (last == TCL_INDEX_END) {
+	    if (last == (int)TCL_INDEX_END) {
 		/* empty suffix - build prefix only */
 		OP44(	STR_RANGE_IMM, 0, first-1);
 		return TCL_OK;
@@ -1230,7 +1230,7 @@ TclCompileStringReplaceCmd(
 	    OP(		DUP);
 	    OP44(	STR_RANGE_IMM, 0, first-1);
 	    OP4(	REVERSE, 2);
-	    OP44(	STR_RANGE_IMM, last + 1, TCL_INDEX_END);
+	    OP44(	STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
 	    OP1(	STR_CONCAT1, 2);
 	    return TCL_OK;
 	}

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}}
 };
 

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

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);
@@ -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;
@@ -2119,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 */
@@ -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) */
 
@@ -3979,6 +3986,8 @@ extern const TclStubs *tclStubsPtr;
 #define Tcl_AddObjErrorInfo(interp, message, length) \
 	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length))
 #ifdef TCL_NO_DEPRECATED
+#undef Tcl_GetStringResult
+#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp))
 #undef Tcl_Eval
 #define Tcl_Eval(interp, objPtr) \
 	Tcl_EvalEx(interp, objPtr, -1, 0)

generic/tclDictObj.c

@@ -34,6 +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		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,
@@ -89,6 +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,	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 },
@@ -1624,6 +1629,71 @@ DictGetCmd(
     return TCL_OK;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictGetDefCmd --
+ *
+ *	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.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictGetDefCmd(
+    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 default");
+	return TCL_ERROR;
+    }
+
+    /*
+     * Give the bits of arguments names for clarity.
+     */
+
+    dictPtr = objv[1];
+    keyPath = &objv[2];
+    numKeys = objc - 4;		/* Number of keys in keyPath; there's always
+				 * one extra key afterwards too. */
+    keyPtr = objv[objc - 2];
+    defaultPtr = objv[objc - 1];
+
+    /*
+     * Implement the getting-with-default operation.
+     */
+
+    dictPtr = TclTraceDictPath(interp, dictPtr, numKeys, keyPath,
+	    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) {
+	Tcl_SetObjResult(interp, defaultPtr);
+    } else {
+	Tcl_SetObjResult(interp, valuePtr);
+    }
+    return TCL_OK;
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -2016,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));

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;
-	    }
-	}
-	if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS,
-		&objResultPtr) == TCL_OK) {
-	    if (*pc == INST_DICT_EXISTS) {
-		found = (objResultPtr ? 1 : 0);
+	    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 (!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;
+	}
+	if (Tcl_DictObjGet(NULL, dictPtr, OBJ_AT_TOS,
+		&objResultPtr) == TCL_OK) {
+	    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:
@@ -8348,7 +8378,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;

generic/tclFCmd.c

@@ -1345,7 +1345,7 @@ TclFileReadLinkCmd(
 /*
  *---------------------------------------------------------------------------
  *
- * TclFileTemporaryCmd
+ * TclFileTemporaryCmd --
  *
  *	This function implements the "tempfile" subcommand of the "file"
  *	command.
@@ -1504,6 +1504,151 @@ TclFileTemporaryCmd(
     return TCL_OK;
 }
 
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclFileTempDirCmd --
+ *
+ *	This function implements the "tempdir" subcommand of the "file"
+ *	command.
+ *
+ * Results:
+ *	Returns a standard Tcl result.
+ *
+ * Side effects:
+ *	Creates a temporary directory.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclFileTempDirCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Tcl_Obj *dirNameObj;	/* Object that will contain the directory
+				 * name. */
+    Tcl_Obj *baseDirObj = NULL, *nameBaseObj = NULL;
+				/* Pieces of template. Each piece is NULL if
+				 * it is omitted. The platform temporary file
+				 * engine might ignore some pieces. */
+
+    if (objc < 1 || objc > 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "?template?");
+	return TCL_ERROR;
+    }
+
+    if (objc > 1) {
+	int length;
+	Tcl_Obj *templateObj = objv[1];
+	const char *string = TclGetStringFromObj(templateObj, &length);
+	const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS);
+
+	/*
+	 * Treat an empty string as if it wasn't there.
+	 */
+
+	if (length == 0) {
+	    goto makeTemporary;
+	}
+
+	/*
+	 * The template only gives a directory if there is a directory
+	 * separator in it, and only gives a base name if there's at least one
+	 * character after the last directory separator.
+	 */
+
+	if (strchr(string, '/') == NULL
+		&& (!onWindows || strchr(string, '\\') == NULL)) {
+	    /*
+	     * No directory separator, so just assume we have a file name.
+	     * This is a bit wrong on Windows where we could have problems
+	     * with disk name prefixes... but those are much less common in
+	     * naked form so we just pass through and let the OS figure it out
+	     * instead.
+	     */
+
+	    nameBaseObj = templateObj;
+	    Tcl_IncrRefCount(nameBaseObj);
+	} else if (string[length-1] != '/'
+		&& (!onWindows || string[length-1] != '\\')) {
+	    /*
+	     * If the template has a non-terminal directory separator, split
+	     * into dirname and tail.
+	     */
+
+	    baseDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME);
+	    nameBaseObj = TclPathPart(interp, templateObj, TCL_PATH_TAIL);
+	} else {
+	    /*
+	     * Otherwise, there must be a terminal directory separator, so
+	     * just the directory is given.
+	     */
+
+	    baseDirObj = templateObj;
+	    Tcl_IncrRefCount(baseDirObj);
+	}
+
+	/*
+	 * Only allow creation of temporary directories in the native
+	 * filesystem since they are frequently used for integration with
+	 * external tools or system libraries.
+	 */
+
+	if (baseDirObj != NULL && Tcl_FSGetFileSystemForPath(baseDirObj)
+		!= &tclNativeFilesystem) {
+	    TclDecrRefCount(baseDirObj);
+	    baseDirObj = NULL;
+	}
+    }
+
+    /*
+     * Convert empty parts of the template into unspecified parts.
+     */
+
+    if (baseDirObj && !TclGetString(baseDirObj)[0]) {
+	TclDecrRefCount(baseDirObj);
+	baseDirObj = NULL;
+    }
+    if (nameBaseObj && !TclGetString(nameBaseObj)[0]) {
+	TclDecrRefCount(nameBaseObj);
+	nameBaseObj = NULL;
+    }
+
+    /*
+     * Create and open the temporary file.
+     */
+
+  makeTemporary:
+    dirNameObj = TclpCreateTemporaryDirectory(baseDirObj, nameBaseObj);
+
+    /*
+     * If we created pieces of template, get rid of them now.
+     */
+
+    if (baseDirObj) {
+	TclDecrRefCount(baseDirObj);
+    }
+    if (nameBaseObj) {
+	TclDecrRefCount(nameBaseObj);
+    }
+
+    /*
+     * Deal with results.
+     */
+
+    if (dirNameObj == NULL) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"can't create temporary directory: %s",
+		Tcl_PosixError(interp)));
+	return TCL_ERROR;
+    }
+    Tcl_SetObjResult(interp, dirNameObj);
+    return TCL_OK;
+}
+
 /*
  * Local Variables:
  * mode: c

generic/tclHash.c

@@ -311,7 +311,10 @@ CreateHashEntry(
 	    if (hash != PTR2UINT(hPtr->hash)) {
 		continue;
 	    }
-	    if (((void *) key == hPtr) || compareKeysProc((void *) key, hPtr)) {
+	    /* if keys pointers or values are equal */
+	    if ((key == hPtr->key.oneWordValue)
+		|| compareKeysProc((void *) key, hPtr)
+	    ) {
 		if (newPtr) {
 		    *newPtr = 0;
 		}

generic/tclIO.c

@@ -3462,6 +3462,11 @@ Tcl_Close(
 
     Tcl_ClearChannelHandlers(chan);
 
+    /*
+     * Cancel any outstanding timer.
+     */
+    Tcl_DeleteTimerHandler(statePtr->timer);
+
     /*
      * Invoke the registered close callbacks and delete their records.
      */
@@ -4447,6 +4452,8 @@ Write(
 	}
     }
 
+    UpdateInterest(chanPtr);
+
     return total;
 }
 
@@ -8475,9 +8482,9 @@ UpdateInterest(
 	     *
 	     * - Tcl drops READABLE here, because it has data in its own
 	     *	 buffers waiting to be read by the extension.
-	     * - A READABLE event is syntesized via timer.
+	     * - A READABLE event is synthesized via timer.
 	     * - The OS still reports the EXCEPTION condition on the file.
-	     * - And the extension gets the EXCPTION event first, and handles
+	     * - And the extension gets the EXCEPTION event first, and handles
 	     *	 this as EOF.
 	     *
 	     * End result ==> Premature end of reading from a file.
@@ -8503,6 +8510,16 @@ UpdateInterest(
 	    }
 	}
     }
+
+    if (!statePtr->timer
+	&& mask & TCL_WRITABLE
+	&& GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
+
+	statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+	    ChannelTimerProc,chanPtr);
+    }
+
+
     ChanWatch(chanPtr, mask);
 }
 
@@ -8531,6 +8548,21 @@ ChannelTimerProc(
     ChannelState *statePtr = chanPtr->state;
 				/* State info for channel */
 
+    Tcl_Preserve(statePtr);
+    statePtr->timer = NULL;
+    if (statePtr->interestMask & TCL_WRITABLE
+	&& GotFlag(statePtr, CHANNEL_NONBLOCKING)
+	&& !GotFlag(statePtr, BG_FLUSH_SCHEDULED)
+	) {
+	/*
+	 * Restart the timer in case a channel handler reenters the event loop
+	 * before UpdateInterest gets called by Tcl_NotifyChannel.
+	 */
+	statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+                ChannelTimerProc,chanPtr);
+	Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE);
+    }
+
     if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
 	    && (statePtr->interestMask & TCL_READABLE)
 	    && (statePtr->inQueueHead != NULL)
@@ -8542,13 +8574,11 @@ ChannelTimerProc(
 
 	statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
                 ChannelTimerProc,chanPtr);
-	Tcl_Preserve(statePtr);
 	Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
-	Tcl_Release(statePtr);
     } else {
-	statePtr->timer = NULL;
 	UpdateInterest(chanPtr);
     }
+    Tcl_Release(statePtr);
 }
 
 /*

generic/tclIORChan.c

@@ -54,6 +54,8 @@ static int		ReflectGetOption(ClientData clientData,
 static int		ReflectSetOption(ClientData clientData,
 			    Tcl_Interp *interp, const char *optionName,
 			    const char *newValue);
+static void     TimerRunRead(ClientData clientData);
+static void     TimerRunWrite(ClientData clientData);
 
 /*
  * The C layer channel type/driver definition used by the reflection. This is
@@ -112,6 +114,17 @@ typedef struct {
     int dead;			/* Boolean signal that some operations
 				 * should no longer be attempted. */
 
+    Tcl_TimerToken readTimer;   /*
+				   A token for the timer that is scheduled in
+				   order to call Tcl_NotifyChannel when the
+				   channel is readable
+			        */
+    Tcl_TimerToken writeTimer;  /*
+				   A token for the timer that is scheduled in
+				   order to call Tcl_NotifyChannel when the
+				   channel is writable
+			        */
+
     /*
      * Note regarding the usage of timers.
      *
@@ -121,11 +134,9 @@ typedef struct {
      *
      * See 'rechan', 'memchan', etc.
      *
-     * Here this is _not_ required. Interest in events is posted to the Tcl
-     * level via 'watch'. And posting of events is possible from the Tcl level
-     * as well, via 'chan postevent'. This means that the generation of all
-     * events, fake or not, timer based or not, is completely in the hands of
-     * the Tcl level. Therefore no timer here.
+     * A timer is used here as well in order to ensure at least on pass through
+     * the event loop when a channel becomes ready. See issues 67a5eabbd3d1 and
+     * ef28eb1f1516.
      */
 } ReflectedChannel;
 
@@ -920,7 +931,18 @@ TclChanPostEventObjCmd(
 #if TCL_THREADS
     if (rcPtr->owner == rcPtr->thread) {
 #endif
-        Tcl_NotifyChannel(chan, events);
+	if (events & TCL_READABLE) {
+	    if (rcPtr->readTimer == NULL) {
+		rcPtr->readTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+			TimerRunRead, rcPtr);
+	    }
+	}
+	if (events & TCL_WRITABLE) {
+	    if (rcPtr->writeTimer == NULL) {
+		rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+			TimerRunWrite, rcPtr);
+	    }
+	}
 #if TCL_THREADS
     } else {
         ReflectEvent *ev = ckalloc(sizeof(ReflectEvent));
@@ -968,6 +990,24 @@ TclChanPostEventObjCmd(
 #undef EVENT
 }
 
+static void
+TimerRunRead(
+    ClientData clientData)
+{
+    ReflectedChannel *rcPtr = clientData;
+    rcPtr->readTimer = NULL;
+    Tcl_NotifyChannel(rcPtr->chan, TCL_READABLE);
+}
+
+static void
+TimerRunWrite(
+    ClientData clientData)
+{
+    ReflectedChannel *rcPtr = clientData;
+    rcPtr->writeTimer = NULL;
+    Tcl_NotifyChannel(rcPtr->chan, TCL_WRITABLE);
+}
+
 /*
  * Channel error message marshalling utilities.
  */
@@ -1161,6 +1201,12 @@ ReflectClose(
 	    ckfree(tctPtr);
 	    ((Channel *)rcPtr->chan)->typePtr = NULL;
 	}
+	if (rcPtr->readTimer != NULL) {
+	    Tcl_DeleteTimerHandler(rcPtr->readTimer);
+	}
+	if (rcPtr->writeTimer != NULL) {
+	    Tcl_DeleteTimerHandler(rcPtr->writeTimer);
+	}
         Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
 	return EOK;
     }
@@ -1230,6 +1276,12 @@ ReflectClose(
 	ckfree(tctPtr);
 	((Channel *)rcPtr->chan)->typePtr = NULL;
     }
+    if (rcPtr->readTimer != NULL) {
+	Tcl_DeleteTimerHandler(rcPtr->readTimer);
+    }
+    if (rcPtr->writeTimer != NULL) {
+	Tcl_DeleteTimerHandler(rcPtr->writeTimer);
+    }
     Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
     return (result == TCL_OK) ? EOK : EINVAL;
 }
@@ -2131,6 +2183,8 @@ NewReflectedChannel(
     rcPtr->chan = NULL;
     rcPtr->interp = interp;
     rcPtr->dead = 0;
+    rcPtr->readTimer = 0;
+    rcPtr->writeTimer = 0;
 #if TCL_THREADS
     rcPtr->thread = Tcl_GetCurrentThread();
 #endif

generic/tclInt.decls

@@ -1028,6 +1028,12 @@ declare 257 {
     void TclStaticPackage(Tcl_Interp *interp, const char *pkgName,
 	    Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
 }
+
+# TIP 431: temporary directory creation function
+declare 258 {
+    Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
+	    Tcl_Obj *basenameObj)
+}
 
 ##############################################################################
 

generic/tclInt.h

@@ -2967,6 +2967,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileTempDirCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd;
 MODULE_SCOPE void	TclCreateLateExitHandler(Tcl_ExitProc *proc,
 			    ClientData clientData);
@@ -3105,6 +3106,7 @@ MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
 MODULE_SCOPE Tcl_Obj *  TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options);
 MODULE_SCOPE int	TclNokia770Doubles(void);
 MODULE_SCOPE void	TclNsDecrRefCount(Namespace *nsPtr);
+MODULE_SCOPE int	TclNamespaceDeleted(Namespace *nsPtr);
 MODULE_SCOPE void	TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
 			    Tcl_Obj *part2Ptr, const char *operation,
 			    const char *reason, int index);
@@ -3471,6 +3473,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[]);
@@ -3502,6 +3507,9 @@ MODULE_SCOPE int	Tcl_PackageObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tcl_PidObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitPragmaCmd(Tcl_Interp *interp);
+MODULE_SCOPE Tcl_ObjCmdProc TclPragmaNoAliasCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclPragmaTypeCmd;
 MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp);
 MODULE_SCOPE int	Tcl_PutsObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
@@ -3645,6 +3653,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);
@@ -4515,6 +4526,31 @@ MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
 
 #define TclHasStringRep(objPtr) ((objPtr)->bytes != NULL)
 
+/*
+ *----------------------------------------------------------------
+ * Macro used by the Tcl core to get the bignum out of the bignum
+ * representation of a Tcl_Obj.
+ * The ANSI C "prototype" for this macro is:
+ *
+ * MODULE_SCOPE void	TclUnpackBignum(Tcl_Obj *objPtr, mp_int bignum);
+ *----------------------------------------------------------------
+ */
+
+#define TclUnpackBignum(objPtr, bignum) \
+    do {								\
+	register Tcl_Obj *bignumObj = (objPtr);				\
+	register int bignumPayload =					\
+		PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2);	\
+	if (bignumPayload == -1) {					\
+	    (bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \
+	} else {							\
+	    (bignum).dp = bignumObj->internalRep.twoPtrValue.ptr1;	\
+	    (bignum).sign = bignumPayload >> 30;			\
+	    (bignum).alloc = (bignumPayload >> 15) & 0x7fff;		\
+	    (bignum).used = bignumPayload & 0x7fff;			\
+	}								\
+    } while (0)
+
 /*
  *----------------------------------------------------------------
  * Macros used by the Tcl core to grow Tcl_Token arrays. They use the same

generic/tclIntDecls.h

@@ -653,6 +653,9 @@ EXTERN void		TclStaticPackage(Tcl_Interp *interp,
 				const char *pkgName,
 				Tcl_PackageInitProc *initProc,
 				Tcl_PackageInitProc *safeInitProc);
+/* 258 */
+EXTERN Tcl_Obj *	TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
+				Tcl_Obj *basenameObj);
 
 typedef struct TclIntStubs {
     int magic;
@@ -916,6 +919,7 @@ typedef struct TclIntStubs {
     int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */
     int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */
     void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */
+    Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */
 } TclIntStubs;
 
 extern const TclIntStubs *tclIntStubsPtr;
@@ -1359,6 +1363,8 @@ extern const TclIntStubs *tclIntStubsPtr;
 	(tclIntStubsPtr->tclPtrUnsetVar) /* 256 */
 #define TclStaticPackage \
 	(tclIntStubsPtr->tclStaticPackage) /* 257 */
+#define TclpCreateTemporaryDirectory \
+	(tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */
 
 #endif /* defined(USE_TCL_STUBS) */
 

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;

generic/tclNamesp.c

@@ -1086,6 +1086,13 @@ Tcl_DeleteNamespace(
     }
     TclNsDecrRefCount(nsPtr);
 }
+
+int
+TclNamespaceDeleted(
+    Namespace *nsPtr)
+{
+    return (nsPtr->flags & NS_DYING) ? 1 : 0;
+}
 
 /*
  *----------------------------------------------------------------------

generic/tclOO.c

@@ -346,14 +346,14 @@ InitFoundation(
      */
 
     Tcl_DStringInit(&buffer);
-    for (i=0 ; defineCmds[i].name ; i++) {
+    for (i = 0 ; defineCmds[i].name ; i++) {
 	TclDStringAppendLiteral(&buffer, "::oo::define::");
 	Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
 	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
 		defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
 	Tcl_DStringFree(&buffer);
     }
-    for (i=0 ; objdefCmds[i].name ; i++) {
+    for (i = 0 ; objdefCmds[i].name ; i++) {
 	TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
 	Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
 	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
@@ -373,10 +373,10 @@ InitFoundation(
      * Basic method declarations for the core classes.
      */
 
-    for (i=0 ; objMethods[i].name ; i++) {
+    for (i = 0 ; objMethods[i].name ; i++) {
 	TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
     }
-    for (i=0 ; clsMethods[i].name ; i++) {
+    for (i = 0 ; clsMethods[i].name ; i++) {
 	TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
     }
 
@@ -388,7 +388,7 @@ InitFoundation(
 
     TclNewLiteralStringObj(namePtr, "new");
     Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
-	    namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
+	    namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
     fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
 	    (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
 
@@ -667,10 +667,8 @@ AllocObject(
 	Tcl_ResetResult(interp);
     }
 
-
   configNamespace:
-
-    ((Namespace *)oPtr->namespacePtr)->refCount++;
+    ((Namespace *) oPtr->namespacePtr)->refCount++;
 
     /*
      * Make the namespace know about the helper commands. This grants access
@@ -874,10 +872,14 @@ TclOODeleteDescendants(
 
     if (clsPtr->mixinSubs.num > 0) {
 	while (clsPtr->mixinSubs.num > 0) {
-	    mixinSubclassPtr = clsPtr->mixinSubs.list[clsPtr->mixinSubs.num-1];
-	    /* This condition also covers the case where mixinSubclassPtr ==
+	    mixinSubclassPtr =
+		    clsPtr->mixinSubs.list[clsPtr->mixinSubs.num - 1];
+
+	    /*
+	     * This condition also covers the case where mixinSubclassPtr ==
 	     * clsPtr
 	     */
+
 	    if (!Deleted(mixinSubclassPtr->thisPtr)
 		    && !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) {
 		Tcl_DeleteCommandFromToken(interp,
@@ -897,7 +899,7 @@ TclOODeleteDescendants(
 
     if (clsPtr->subclasses.num > 0) {
 	while (clsPtr->subclasses.num > 0) {
-	    subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1];
+	    subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num - 1];
 	    if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)
 		    && !(subclassPtr->thisPtr->flags & DONT_DELETE)) {
 		Tcl_DeleteCommandFromToken(interp,
@@ -918,7 +920,8 @@ TclOODeleteDescendants(
 
     if (clsPtr->instances.num > 0) {
 	while (clsPtr->instances.num > 0) {
-	    instancePtr = clsPtr->instances.list[clsPtr->instances.num-1];
+	    instancePtr = clsPtr->instances.list[clsPtr->instances.num - 1];
+
 	    /*
 	     * This condition also covers the case where instancePtr == oPtr
 	     */
@@ -1119,8 +1122,8 @@ ObjectNamespaceDeleted(
 
     if (Deleted(oPtr)) {
 	/*
-	 * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, this
-	 * guard could be removed.
+	 * TODO:  Can ObjectNamespaceDeleted ever be called twice?  If not,
+	 * this guard could be removed.
 	 */
 
 	return;
@@ -1134,7 +1137,10 @@ ObjectNamespaceDeleted(
 
     oPtr->flags |= OBJECT_DELETED;
 
-    /* Let the dominoes fall */
+    /*
+     * Let the dominoes fall!
+     */
+
     if (oPtr->classPtr) {
 	TclOODeleteDescendants(interp, oPtr);
     }
@@ -1150,8 +1156,8 @@ ObjectNamespaceDeleted(
 	CallContext *contextPtr =
 		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
 	int result;
-
 	Tcl_InterpState state;
+
 	oPtr->flags |= DESTRUCTOR_CALLED;
 
 	if (contextPtr != NULL) {
@@ -1170,12 +1176,12 @@ ObjectNamespaceDeleted(
 
     /*
      * Instruct everyone to no longer use any allocated fields of the object.
-     * Also delete the command that refers to the object at this point (if
-     * it still exists) because otherwise its pointer to the object
-     * points into freed memory.
+     * Also delete the command that refers to the object at this point (if it
+     * still exists) because otherwise its pointer to the object points into
+     * freed memory.
      */
 
-    if (((Command *)oPtr->command)->flags && CMD_IS_DELETED) {
+    if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) {
 	/*
 	 * Something has already started the command deletion process. We can
 	 * go ahead and clean up the the namespace,
@@ -1201,10 +1207,7 @@ ObjectNamespaceDeleted(
      * methods on the object.
      */
 
-    /*
-     * TODO: Should this be protected with a * !IsRoot() condition?
-     */
-
+    /* TODO: Should this be protected with a !IsRoot() condition? */
     TclOORemoveFromInstances(oPtr, oPtr->selfCls);
 
     if (oPtr->mixins.num > 0) {
@@ -1765,7 +1768,6 @@ TclNRNewObjectInstance(
     TclPushTailcallPoint(interp);
     return TclOOInvokeContext(contextPtr, interp, objc, objv);
 }
-
 
 Object *
 TclNewObjectInstanceCommon(
@@ -1780,7 +1782,6 @@ TclNewObjectInstanceCommon(
     const char *simpleName = NULL;
     Namespace *nsPtr = NULL, *dummy;
     Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
-    int isNew;
 
     if (nameStr) {
 	TclGetNamespaceForQualName(interp, nameStr, inNsPtr,
@@ -1790,21 +1791,14 @@ TclNewObjectInstanceCommon(
 	 * Disallow creation of an object over an existing command.
 	 */
 
-	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew);
-	if (!isNew) {
+	hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simpleName);
+	if (hPtr) {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		    "can't create object \"%s\": command already exists with"
 		    " that name", nameStr));
 	    Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
 	    return NULL;
 	}
-
-	/*
-	 * We could make a hash entry! Don't actually want to do that here so
-	 * nuke it immediately because we'll create it properly soon.
-	 */
-
-	Tcl_DeleteHashEntry(hPtr);
     }
 
     /*
@@ -1837,8 +1831,6 @@ TclNewObjectInstanceCommon(
     return oPtr;
 }
 
-
-
 static int
 FinalizeAlloc(
     ClientData data[],
@@ -1974,7 +1966,11 @@ Tcl_CopyObjectInstance(
 	if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
 	    TclOOAddToInstances(o2Ptr, mixinPtr);
 	}
-	/* For the reference just created in DUPLICATE */
+
+	/*
+	 * For the reference just created in DUPLICATE.
+	 */
+
 	AddRef(mixinPtr->thisPtr);
     }
 
@@ -2012,6 +2008,7 @@ Tcl_CopyObjectInstance(
 
     o2Ptr->flags = oPtr->flags & ~(
 	    OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
+
     /*
      * Copy the object's metadata.
      */
@@ -2075,9 +2072,11 @@ Tcl_CopyObjectInstance(
 	FOREACH(superPtr, cls2Ptr->superclasses) {
 	    TclOOAddToSubclasses(cls2Ptr, superPtr);
 
-	    /* For the new item in cls2Ptr->superclasses that memcpy just
-	     * created
+	    /*
+	     * For the new item in cls2Ptr->superclasses that memcpy just
+	     * created.
 	     */
+
 	    AddRef(superPtr->thisPtr);
 	}
 
@@ -2121,7 +2120,11 @@ Tcl_CopyObjectInstance(
 	DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
 	FOREACH(mixinPtr, cls2Ptr->mixins) {
 	    TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
-	    /* For the copy just created in DUPLICATE */
+
+	    /*
+	     * For the copy just created in DUPLICATE.
+	     */
+
 	    AddRef(mixinPtr->thisPtr);
 	}
 
@@ -2783,7 +2786,7 @@ Tcl_ObjectContextInvokeNext(
     int savedSkip = contextPtr->skip;
     int result;
 
-    if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
+    if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
 	/*
 	 * We're at the end of the chain; generate an error message unless the
 	 * interpreter is being torn down, in which case we might be getting
@@ -2852,7 +2855,7 @@ TclNRObjectContextInvokeNext(
 {
     register CallContext *contextPtr = (CallContext *) context;
 
-    if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
+    if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
 	/*
 	 * We're at the end of the chain; generate an error message unless the
 	 * interpreter is being torn down, in which case we might be getting

generic/tclOOCall.c

@@ -328,7 +328,7 @@ TclOOInvokeContext(
     if (contextPtr->index == 0) {
 	int i;
 
-	for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
+	for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
 	    AddRef(contextPtr->callPtr->chain[i].mPtr);
 	}
 
@@ -406,7 +406,7 @@ FinalizeMethodRefs(
     CallContext *contextPtr = data[0];
     int i;
 
-    for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
+    for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
 	TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
     }
     return result;
@@ -641,7 +641,10 @@ SortMethodNames(
     return i;
 }
 
-/* Comparator for SortMethodNames */
+/*
+ * Comparator for SortMethodNames
+ */
+
 static int
 CmpStr(
     const void *ptr1,
@@ -1004,7 +1007,7 @@ AddMethodToCallChain(
      * any leading filters.
      */
 
-    for (i=cbPtr->filterLength ; i<callPtr->numChain ; i++) {
+    for (i = cbPtr->filterLength ; i < callPtr->numChain ; i++) {
 	if (callPtr->chain[i].mPtr == mPtr &&
 		callPtr->chain[i].isFilter == (doneFilters != NULL)) {
 	    /*
@@ -1016,8 +1019,8 @@ AddMethodToCallChain(
 
 	    Class *declCls = callPtr->chain[i].filterDeclarer;
 
-	    for (; i+1<callPtr->numChain ; i++) {
-		callPtr->chain[i] = callPtr->chain[i+1];
+	    for (; i + 1 < callPtr->numChain ; i++) {
+		callPtr->chain[i] = callPtr->chain[i + 1];
 	    }
 	    callPtr->chain[i].mPtr = mPtr;
 	    callPtr->chain[i].isFilter = (doneFilters != NULL);
@@ -1817,7 +1820,7 @@ TclOORenderCallChain(
      */
 
     objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
-    for (i=0 ; i<callPtr->numChain ; i++) {
+    for (i = 0 ; i < callPtr->numChain ; i++) {
 	struct MInvoke *miPtr = &callPtr->chain[i];
 
 	descObjs[0] =

generic/tclOODefineCmds.c

@@ -49,6 +49,12 @@ struct DeclaredSlot {
 	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
 		    resolver, NULL, NULL}}
 
+/*
+ * A [string match] pattern used to determine if a method should be exported.
+ */
+
+#define PUBLIC_PATTERN		"[a-z]*"
+
 /*
  * Forward declarations.
  */
@@ -278,7 +284,7 @@ TclOOObjectSetFilters(
 	} else {
 	    filtersList = ckrealloc(oPtr->filters.list, size);
 	}
-	for (i=0 ; i<numFilters ; i++) {
+	for (i = 0 ; i < numFilters ; i++) {
 	    filtersList[i] = filters[i];
 	    Tcl_IncrRefCount(filters[i]);
 	}
@@ -337,7 +343,7 @@ TclOOClassSetFilters(
 	} else {
 	    filtersList = ckrealloc(classPtr->filters.list, size);
 	}
-	for (i=0 ; i<numFilters ; i++) {
+	for (i = 0 ; i < numFilters ; i++) {
 	    filtersList[i] = filters[i];
 	    Tcl_IncrRefCount(filters[i]);
 	}
@@ -400,7 +406,11 @@ TclOOObjectSetMixins(
 	FOREACH(mixinPtr, oPtr->mixins) {
 	    if (mixinPtr != oPtr->selfCls) {
 		TclOOAddToInstances(oPtr, mixinPtr);
-		/* For the new copy created by memcpy */
+
+		/*
+		 * For the new copy created by memcpy().
+		 */
+
 		AddRef(mixinPtr->thisPtr);
 	    }
 	}
@@ -452,7 +462,11 @@ TclOOClassSetMixins(
 	memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
 	FOREACH(mixinPtr, classPtr->mixins) {
 	    TclOOAddToMixinSubs(classPtr, mixinPtr);
-	    /* For the new copy created by memcpy */
+
+	    /*
+	     * For the new copy created by memcpy.
+	     */
+
 	    AddRef(mixinPtr->thisPtr);
 	}
     }
@@ -724,15 +738,16 @@ TclOOUnknownDefinition(
 	 * Got one match, and only one match!
 	 */
 
-	Tcl_Obj **newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj*)*(objc-1));
+	Tcl_Obj **newObjv =
+		TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1));
 	int result;
 
 	newObjv[0] = Tcl_NewStringObj(matchedStr, -1);
 	Tcl_IncrRefCount(newObjv[0]);
 	if (objc > 2) {
-	    memcpy(newObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2));
+	    memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
 	}
-	result = Tcl_EvalObjv(interp, objc-1, newObjv, 0);
+	result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0);
 	Tcl_DecrRefCount(newObjv[0]);
 	TclStackFree(interp, newObjv);
 	return result;
@@ -1039,17 +1054,20 @@ MagicDefinitionInvoke(
     obj2Ptr = Tcl_NewObj();
     cmd = FindCommand(interp, objv[cmdIndex], nsPtr);
     if (cmd == NULL) {
-	/* punt this case! */
+	/*
+	 * Punt this case!
+	 */
+
 	Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
     } else {
 	Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
     }
     Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
     /* TODO: overflow? */
-    Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-offset, objv+offset);
+    Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset);
     Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
 
-    result = Tcl_EvalObjv(interp, objc-cmdIndex, objs, TCL_EVAL_INVOKE);
+    result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE);
     if (isRoot) {
 	TclResetRewriteEnsemble(interp, 1);
     }
@@ -1685,7 +1703,7 @@ TclOODefineDeleteMethodObjCmd(
 	return TCL_ERROR;
     }
 
-    for (i=1 ; i<objc ; i++) {
+    for (i = 1; i < objc; i++) {
 	/*
 	 * Delete the method structure from the appropriate hash table.
 	 */
@@ -1811,7 +1829,7 @@ TclOODefineExportObjCmd(
 	return TCL_ERROR;
     }
 
-    for (i=1 ; i<objc ; i++) {
+    for (i = 1; i < objc; i++) {
 	/*
 	 * Exporting is done by adding the PUBLIC_METHOD flag to the method
 	 * record. If there is no such method in this object or class (i.e.
@@ -1904,7 +1922,7 @@ TclOODefineForwardObjCmd(
 	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
-    isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
+    isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
 	    ? PUBLIC_METHOD : 0;
     if (IsPrivateDefine(interp)) {
 	isPublic = TRUE_PRIVATE_METHOD;
@@ -1914,7 +1932,7 @@ TclOODefineForwardObjCmd(
      * Create the method structure.
      */
 
-    prefixObj = Tcl_NewListObj(objc-2, objv+2);
+    prefixObj = Tcl_NewListObj(objc - 2, objv + 2);
     if (isInstanceForward) {
 	mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1],
 		prefixObj);
@@ -2002,7 +2020,7 @@ TclOODefineMethodObjCmd(
 	if (IsPrivateDefine(interp)) {
 	    isPublic = TRUE_PRIVATE_METHOD;
 	} else {
-	    isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
+	    isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
 		    ? PUBLIC_METHOD : 0;
 	}
     }
@@ -2124,7 +2142,7 @@ TclOODefineUnexportObjCmd(
 	return TCL_ERROR;
     }
 
-    for (i=1 ; i<objc ; i++) {
+    for (i = 1; i < objc; i++) {
 	/*
 	 * Unexporting is done by removing the PUBLIC_METHOD flag from the
 	 * method record. If there is no such method in this object or class
@@ -2340,7 +2358,7 @@ ClassFilterSet(
     int filterc;
     Tcl_Obj **filterv;
 
-    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
 		"filterList");
 	return TCL_ERROR;
@@ -2424,7 +2442,7 @@ ClassMixinSet(
     Tcl_Obj **mixinv;
     Class **mixins;
 
-    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
 		"mixinList");
 	return TCL_ERROR;
@@ -2445,7 +2463,7 @@ ClassMixinSet(
 
     mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
 
-    for (i=0 ; i<mixinc ; i++) {
+    for (i = 0; i < mixinc; i++) {
 	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
 		"may only mix in classes");
 	if (mixins[i] == NULL) {
@@ -2529,7 +2547,7 @@ ClassSuperSet(
     Tcl_Obj **superv;
     Class **superclasses, *superPtr;
 
-    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
 		"superclassList");
 	return TCL_ERROR;
@@ -2576,14 +2594,14 @@ ClassSuperSet(
 	superc = 1;
 	AddRef(superclasses[0]->thisPtr);
     } else {
-	for (i=0 ; i<superc ; i++) {
+	for (i = 0; i < superc; i++) {
 	    superclasses[i] = GetClassInOuterContext(interp, superv[i],
 		    "only a class can be a superclass");
 	    if (superclasses[i] == NULL) {
 		i--;
 		goto failedAfterAlloc;
 	    }
-	    for (j=0 ; j<i ; j++) {
+	    for (j = 0; j < i; j++) {
 		if (superclasses[j] == superclasses[i]) {
 		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
 			    "class should only be a direct superclass once",
@@ -2705,7 +2723,7 @@ ClassVarsSet(
     Tcl_Obj **varv;
     int i;
 
-    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
 		"filterList");
 	return TCL_ERROR;
@@ -2724,7 +2742,7 @@ ClassVarsSet(
 	return TCL_ERROR;
     }
 
-    for (i=0 ; i<varc ; i++) {
+    for (i = 0; i < varc; i++) {
 	const char *varName = TclGetString(varv[i]);
 
 	if (strstr(varName, "::") != NULL) {
@@ -2803,7 +2821,7 @@ ObjFilterSet(
     int filterc;
     Tcl_Obj **filterv;
 
-    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
 		"filterList");
 	return TCL_ERROR;
@@ -2877,7 +2895,7 @@ ObjMixinSet(
     Class **mixins;
     int i;
 
-    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
 		"mixinList");
 	return TCL_ERROR;
@@ -2892,7 +2910,7 @@ ObjMixinSet(
 
     mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
 
-    for (i=0 ; i<mixinc ; i++) {
+    for (i = 0; i < mixinc; i++) {
 	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
 		"may only mix in classes");
 	if (mixins[i] == NULL) {
@@ -2967,7 +2985,7 @@ ObjVarsSet(
     int varc, i;
     Tcl_Obj **varv;
 
-    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
 		"variableList");
 	return TCL_ERROR;
@@ -2980,7 +2998,7 @@ ObjVarsSet(
 	return TCL_ERROR;
     }
 
-    for (i=0 ; i<varc ; i++) {
+    for (i = 0; i < varc; i++) {
 	const char *varName = TclGetString(varv[i]);
 
 	if (strstr(varName, "::") != NULL) {

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;

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);
+    /*
+     * If we've got the package in the DB already, go on to actually loading
+     * it.
+     */
 
-		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 (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;
 }
 

generic/tclResult.c

@@ -464,7 +464,6 @@ Tcl_SetResult(
 
     ResetObjResult(iPtr);
 }
-#endif /* !TCL_NO_DEPRECATED */
 
 /*
  *----------------------------------------------------------------------
@@ -488,9 +487,6 @@ Tcl_GetStringResult(
     register Tcl_Interp *interp)/* Interpreter whose result to return. */
 {
     Interp *iPtr = (Interp *) interp;
-#ifdef TCL_NO_DEPRECATED
-    return Tcl_GetString(iPtr->objResultPtr);
-#else
     /*
      * If the string result is empty, move the object result to the string
      * result, then reset the object result.
@@ -501,8 +497,8 @@ Tcl_GetStringResult(
 		TCL_VOLATILE);
     }
     return iPtr->result;
-#endif
 }
+#endif /* !TCL_NO_DEPRECATED */
 
 /*
  *----------------------------------------------------------------------

generic/tclStrToD.c

@@ -1849,15 +1849,15 @@ RefineApproximation(
      */
 
     msb = binExponent + M2;	/* 1008 */
-    nDigits = msb / DIGIT_BIT + 1;
+    nDigits = msb / MP_DIGIT_BIT + 1;
     mp_init_size(&twoMv, nDigits);
-    i = (msb % DIGIT_BIT + 1);
+    i = (msb % MP_DIGIT_BIT + 1);
     twoMv.used = nDigits;
     significand *= SafeLdExp(1.0, i);
     while (--nDigits >= 0) {
 	twoMv.dp[nDigits] = (mp_digit) significand;
 	significand -= (mp_digit) significand;
-	significand = SafeLdExp(significand, DIGIT_BIT);
+	significand = SafeLdExp(significand, MP_DIGIT_BIT);
     }
     for (i = 0; i <= 8; ++i) {
 	if (M5 & (1 << i)) {
@@ -3145,7 +3145,7 @@ ShouldBankerRoundUpPowD(
     int isodd)			/* 1 if the digit is odd, 0 if even. */
 {
     int i;
-    static const mp_digit topbit = ((mp_digit)1) << (DIGIT_BIT - 1);
+    static const mp_digit topbit = ((mp_digit)1) << (MP_DIGIT_BIT - 1);
 
     if (b->used < sd || (b->dp[sd-1] & topbit) == 0) {
 	return 0;
@@ -4214,8 +4214,8 @@ TclDoubleDigits(
 	     * in the denominator' case.
 	     */
 
-	    if (s2 % DIGIT_BIT != 0) {
-		int delta = DIGIT_BIT - (s2 % DIGIT_BIT);
+	    if (s2 % MP_DIGIT_BIT != 0) {
+		int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT);
 
 		b2 += delta;
 		m2plus += delta;
@@ -4223,7 +4223,7 @@ TclDoubleDigits(
 		s2 += delta;
 	    }
 	    return ShorteningBignumConversionPowD(&d, bw, b2, b5,
-		    m2plus, m2minus, m5, s2/DIGIT_BIT, k, len, ilim, ilim1,
+		    m2plus, m2minus, m5, s2/MP_DIGIT_BIT, k, len, ilim, ilim1,
 		    decpt, endPtr);
 	} else {
 	    /*
@@ -4270,14 +4270,14 @@ TclDoubleDigits(
 	     * in the denominator' case.
 	     */
 
-	    if (s2 % DIGIT_BIT != 0) {
-		int delta = DIGIT_BIT - (s2 % DIGIT_BIT);
+	    if (s2 % MP_DIGIT_BIT != 0) {
+		int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT);
 
 		b2 += delta;
 		s2 += delta;
 	    }
 	    return StrictBignumConversionPowD(&d, bw, b2, b5,
-		    s2/DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr);
+		    s2/MP_DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr);
 	} else {
 	    /*
 	     * There are no helpful special cases, but at least we know in
@@ -4402,7 +4402,7 @@ TclInitDoubleConversion(void)
 	    + 0.5 * log(10.)) / log(10.));
     minDigits = (int) floor((DBL_MIN_EXP - DBL_MANT_DIG)
 	    * log((double) FLT_RADIX) / log(10.));
-    log10_DIGIT_MAX = (int) floor(DIGIT_BIT * log(2.) / log(10.));
+    log10_DIGIT_MAX = (int) floor(MP_DIGIT_BIT * log(2.) / log(10.));
 
     /*
      * Nokia 770's software-emulated floating point is "middle endian": the
@@ -4606,7 +4606,7 @@ TclBignumToDouble(
 
     r = 0.0;
     for (i=b.used-1 ; i>=0 ; --i) {
-	r = ldexp(r, DIGIT_BIT) + b.dp[i];
+	r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
     }
     mp_clear(&b);
 
@@ -4675,7 +4675,7 @@ TclCeil(
 		mp_add_d(&b, 1, &b);
 	    }
 	    for (i=b.used-1 ; i>=0 ; --i) {
-		r = ldexp(r, DIGIT_BIT) + b.dp[i];
+		r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
 	    }
 	    r = ldexp(r, bits - mantBits);
 	}
@@ -4725,7 +4725,7 @@ TclFloor(
 		mp_copy(a, &b);
 	    }
 	    for (i=b.used-1 ; i>=0 ; --i) {
-		r = ldexp(r, DIGIT_BIT) + b.dp[i];
+		r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
 	    }
 	    r = ldexp(r, bits - mantBits);
 	}
@@ -4787,7 +4787,7 @@ BignumToBiasedFrExp(
 
     r = 0.0;
     for (i=b.used-1; i>=0; --i) {
-	r = ldexp(r, DIGIT_BIT) + b.dp[i];
+	r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
     }
     mp_clear(&b);
 

generic/tclStringObj.c

@@ -2270,11 +2270,11 @@ Tcl_AppendFormatToObj(
 		    }
 #endif
 		} else if (useBig && big.used) {
-		    int leftover = (big.used * DIGIT_BIT) % numBits;
-		    mp_digit mask = (~(mp_digit)0) << (DIGIT_BIT-leftover);
+		    int leftover = (big.used * MP_DIGIT_BIT) % numBits;
+		    mp_digit mask = (~(mp_digit)0) << (MP_DIGIT_BIT-leftover);
 
 		    numDigits = 1 +
-			    (((Tcl_WideInt) big.used * DIGIT_BIT) / numBits);
+			    (((Tcl_WideInt) big.used * MP_DIGIT_BIT) / numBits);
 		    while ((mask & big.dp[big.used-1]) == 0) {
 			numDigits--;
 			mask >>= numBits;
@@ -2310,9 +2310,9 @@ Tcl_AppendFormatToObj(
 
 		    if (useBig && big.used) {
 			if (index < big.used && (size_t) shift <
-				CHAR_BIT*sizeof(Tcl_WideUInt) - DIGIT_BIT) {
+				CHAR_BIT*sizeof(Tcl_WideUInt) - MP_DIGIT_BIT) {
 			    bits |= ((Tcl_WideUInt) big.dp[index++]) << shift;
-			    shift += DIGIT_BIT;
+			    shift += MP_DIGIT_BIT;
 			}
 			shift -= numBits;
 		    }

generic/tclStubInit.c

@@ -368,6 +368,8 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig
 #   define Tcl_Eval 0
 #   undef Tcl_GlobalEval
 #   define Tcl_GlobalEval 0
+#   undef Tcl_GetStringResult
+#   define Tcl_GetStringResult 0
 #   undef Tcl_SaveResult
 #   define Tcl_SaveResult 0
 #   undef Tcl_RestoreResult
@@ -749,6 +751,7 @@ static const TclIntStubs tclIntStubs = {
     TclPtrObjMakeUpvar, /* 255 */
     TclPtrUnsetVar, /* 256 */
     TclStaticPackage, /* 257 */
+    TclpCreateTemporaryDirectory, /* 258 */
 };
 
 static const TclIntPlatStubs tclIntPlatStubs = {
@@ -1628,6 +1631,7 @@ const TclStubs tclStubs = {
     Tcl_IncrRefCount, /* 641 */
     Tcl_DecrRefCount, /* 642 */
     Tcl_IsShared, /* 643 */
+    Tcl_LinkArray, /* 644 */
 };
 
 /* !END!: Do not edit above this line. */

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);
@@ -968,8 +971,10 @@ AsyncHandlerProc(
 
     Tcl_MutexLock(&asyncTestMutex);
     for (asyncPtr = firstHandler; asyncPtr != NULL;
-         asyncPtr = asyncPtr->nextPtr) {
-        if (asyncPtr->id == id) break;
+            asyncPtr = asyncPtr->nextPtr) {
+        if (asyncPtr->id == id) {
+            break;
+        }
     }
     Tcl_MutexUnlock(&asyncTestMutex);
 
@@ -3280,6 +3285,124 @@ TestlinkCmd(
     return TCL_OK;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestlinkarrayCmd --
+ *
+ *      This function is invoked to process the "testlinkarray" Tcl command.
+ *      It is used to test the 'Tcl_LinkArray' function.
+ *
+ * Results:
+ *      A standard Tcl result.
+ *
+ * Side effects:
+ *	Creates, deletes, and invokes variable links.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestlinkarrayCmd(
+    ClientData dummy,           /* Not used. */
+    Tcl_Interp *interp,         /* Current interpreter. */
+    int objc,                   /* Number of arguments. */
+    Tcl_Obj *const objv[])      /* Argument objects. */
+{
+    static const char *LinkOption[] = {
+        "update", "remove", "create", NULL
+    };
+    enum LinkOption { LINK_UPDATE, LINK_REMOVE, LINK_CREATE };
+    static const char *LinkType[] = {
+	"char", "uchar", "short", "ushort", "int", "uint", "long", "ulong",
+	"wide", "uwide", "float", "double", "string", "char*", "binary", NULL
+    };
+    /* all values after TCL_LINK_CHARS_ARRAY are used as arrays (see below) */
+    static int LinkTypes[] = {
+	TCL_LINK_CHAR, TCL_LINK_UCHAR,
+	TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT,
+	TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT,
+	TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS,
+	TCL_LINK_BINARY
+    };
+    int optionIndex, typeIndex, readonly, i, size, length;
+    char *name, *arg;
+    Tcl_WideInt addr;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "option args");
+	return TCL_ERROR;
+    }
+    if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0,
+	    &optionIndex) != TCL_OK) {
+	return TCL_ERROR;
+    }
+    switch ((enum LinkOption) optionIndex) {
+    case LINK_UPDATE:
+	for (i=2; i<objc; i++) {
+	    Tcl_UpdateLinkedVar(interp, Tcl_GetString(objv[i]));
+	}
+	return TCL_OK;
+    case LINK_REMOVE:
+	for (i=2; i<objc; i++) {
+	    Tcl_UnlinkVar(interp, Tcl_GetString(objv[i]));
+	}
+	return TCL_OK;
+    case LINK_CREATE:
+	if (objc < 4) {
+	    goto wrongArgs;
+	}
+	readonly = 0;
+	i = 2;
+
+	/*
+	 * test on switch -r...
+	 */
+
+	arg = Tcl_GetStringFromObj(objv[i], &length);
+	if (length < 2) {
+	    goto wrongArgs;
+	}
+	if (arg[0] == '-') {
+	    if (arg[1] != 'r') {
+		goto wrongArgs;
+	    }
+	    readonly = TCL_LINK_READ_ONLY;
+	    i++;
+	}
+	if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0,
+ 		&typeIndex) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) {
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", -1));
+	    return TCL_ERROR;
+	}
+	name = Tcl_GetString(objv[i++]);
+
+	/*
+	 * If no address is given request one in the underlying function
+	 */
+
+	if (i < objc) {
+	    if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
+ 		Tcl_SetObjResult(interp, Tcl_NewStringObj(
+			"wrong address value", -1));
+		return TCL_ERROR;
+	    }
+	} else {
+	    addr = 0;
+	}
+	return Tcl_LinkArray(interp, name, INT2PTR(addr),
+		LinkTypes[typeIndex] | readonly, size);
+    }
+    return TCL_OK;
+
+  wrongArgs:
+    Tcl_WrongNumArgs(interp, 2, objv, "?-readonly? type size name ?address?");
+    return TCL_ERROR;
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -4294,7 +4417,7 @@ TesttranslatefilenameCmd(
  *
  * TestupvarCmd --
  *
- *	This procedure implements the "testupvar2" command.  It is used
+ *	This procedure implements the "testupvar" command.  It is used
  *	to test Tcl_UpVar and Tcl_UpVar2.
  *
  * Results:

generic/tclTimer.c

@@ -310,8 +310,8 @@ TclCreateAbsoluteTimerHandler(
     timerHandlerPtr->token = (Tcl_TimerToken) INT2PTR(tsdPtr->lastTimerId);
 
     /*
-     * Add the event to the queue in the correct position
-     * (ordered by event firing time).
+     * Add the event to the queue in the correct position (ordered by event
+     * firing time).
      */
 
     for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
@@ -1013,8 +1013,8 @@ AfterDelay(
 
     Tcl_GetTime(&now);
     endTime = now;
-    endTime.sec += (long)(ms/1000);
-    endTime.usec += ((int)(ms%1000))*1000;
+    endTime.sec += (long)(ms / 1000);
+    endTime.usec += ((int)(ms % 1000)) * 1000;
     if (endTime.usec >= 1000000) {
 	endTime.sec++;
 	endTime.usec -= 1000000;
@@ -1042,17 +1042,17 @@ AfterDelay(
 	    if (diff > TCL_TIME_MAXIMUM_SLICE) {
 		diff = TCL_TIME_MAXIMUM_SLICE;
 	    }
-	    if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
-		diff = 1;
-	    }
+            if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
+                diff = 1;
+            }
 	    if (diff > 0) {
-		Tcl_Sleep((int) diff);
-		if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
-		    break;
-		}
+		Tcl_Sleep((long) diff);
+                if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
+                    break;
+                }
 	    } else {
-		break;
-	    }
+                break;
+            }
 	} else {
 	    diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
 	    if (diff > TCL_TIME_MAXIMUM_SLICE) {

generic/tclTomMath.h

@@ -1,14 +1,6 @@
-/* LibTomMath, multiple-precision integer library -- Tom St Denis
- *
- * LibTomMath is a library that provides multiple-precision
- * integer arithmetic as well as number theoretic functionality.
- *
- * The library was designed directly after the MPI library by
- * Michael Fromberger but has been written from scratch with
- * additional optimizations in place.
- *
- * SPDX-License-Identifier: Unlicense
- */
+/* LibTomMath, multiple-precision integer library -- Tom St Denis */
+/* SPDX-License-Identifier: Unlicense */
+
 #ifndef BN_H_
 #define BN_H_
 
@@ -115,29 +107,30 @@ typedef unsigned long long   mp_word;
 #define MP_MASK          ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1))
 #define MP_DIGIT_MAX     MP_MASK
 
-/* equalities */
+typedef int mp_sign;
+#define MP_ZPOS       0   /* positive integer */
+#define MP_NEG        1   /* negative */
+typedef int mp_ord;
 #define MP_LT        -1   /* less than */
 #define MP_EQ         0   /* equal to */
 #define MP_GT         1   /* greater than */
-
-#define MP_ZPOS       0   /* positive integer */
-#define MP_NEG        1   /* negative */
-
+typedef int mp_bool;
+#define MP_YES        1   /* yes response */
+#define MP_NO         0   /* no response */
+typedef int mp_err;
 #define MP_OKAY       0   /* ok result */
+#define MP_ERR        -1  /* unknown error */
 #define MP_MEM        -2  /* out of mem */
 #define MP_VAL        -3  /* invalid input */
 #define MP_RANGE      MP_VAL
 #define MP_ITER       -4  /* Max. iterations reached */
 
-#define MP_YES        1   /* yes response */
-#define MP_NO         0   /* no response */
-
 /* Primality generation flags */
 #define LTM_PRIME_BBS      0x0001 /* BBS style prime */
 #define LTM_PRIME_SAFE     0x0002 /* Safe prime (p-1)/2 == prime */
 #define LTM_PRIME_2MSB_ON  0x0008 /* force 2nd MSB to 1 */
 
-typedef int           mp_err;
+/* tunable cutoffs */
 
 /* define this to use lower memory usage routines (exptmods mostly) */
 /* #define MP_LOW_MEM */
@@ -146,6 +139,8 @@ typedef int           mp_err;
 #ifndef MP_PREC
 #   ifndef MP_LOW_MEM
 #      define MP_PREC 32        /* default digits of precision */
+#   elif defined(MP_8BIT)
+#      define MP_PREC 16        /* default digits of precision */
 #   else
 #      define MP_PREC 8         /* default digits of precision */
 #   endif
@@ -154,6 +149,45 @@ typedef int           mp_err;
 /* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
 #define MP_WARRAY               (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1))
 
+/*
+ * MP_WUR - warn unused result
+ * ---------------------------
+ *
+ * The result of functions annotated with MP_WUR must be
+ * checked and cannot be ignored.
+ *
+ * Most functions in libtommath return an error code.
+ * This error code must be checked in order to prevent crashes or invalid
+ * results.
+ *
+ * If you still want to avoid the error checks for quick and dirty programs
+ * without robustness guarantees, you can `#define MP_WUR` before including
+ * tommath.h, disabling the warnings.
+ */
+#ifndef MP_WUR
+#  if defined(__GNUC__) && __GNUC__ >= 4
+#     define MP_WUR __attribute__((warn_unused_result))
+#  else
+#     define MP_WUR
+#  endif
+#endif
+
+#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 301)
+#  define MP_DEPRECATED(x) __attribute__((deprecated("replaced by " #x)))
+#  define PRIVATE_MP_DEPRECATED_PRAGMA(s) _Pragma(#s)
+#  define MP_DEPRECATED_PRAGMA(s) PRIVATE_MP_DEPRECATED_PRAGMA(GCC warning s)
+#elif defined(_MSC_VER) && _MSC_VER >= 1500
+#  define MP_DEPRECATED(x) __declspec(deprecated("replaced by " #x))
+#  define MP_DEPRECATED_PRAGMA(s) __pragma(message(s))
+#else
+#  define MP_DEPRECATED
+#  define MP_DEPRECATED_PRAGMA(s)
+#endif
+
+#define USED(m)    ((m)->used)
+#define DIGIT(m,k) ((m)->dp[(k)])
+#define SIGN(m)    ((m)->sign)
+
 /* the infamous mp_int structure */
 #ifndef MP_INT_DECLARED
 #define MP_INT_DECLARED
@@ -168,10 +202,6 @@ struct mp_int {
 typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat);
 
 
-#define USED(m)     ((m)->used)
-#define DIGIT(m, k) ((m)->dp[(k)])
-#define SIGN(m)     ((m)->sign)
-
 /* error code to char* string */
 const char *mp_error_to_string(int code);
 

generic/tclTomMathDecls.h

@@ -45,8 +45,11 @@
 /* Rename the global symbols in libtommath to avoid linkage conflicts */
 
 #define bn_reverse TclBN_reverse
+#define s_mp_reverse TclBN_reverse
 #define fast_s_mp_mul_digs TclBN_fast_s_mp_mul_digs
+#define s_mp_mul_digs_fast TclBN_fast_s_mp_mul_digs
 #define fast_s_mp_sqr TclBN_fast_s_mp_sqr
+#define s_mp_sqr_fast TclBN_fast_s_mp_sqr
 #define mp_add TclBN_mp_add
 #define mp_add_d TclBN_mp_add_d
 #define mp_and TclBN_mp_and
@@ -79,7 +82,9 @@
 #define mp_init_set_int TclBN_mp_init_set_int
 #define mp_init_size TclBN_mp_init_size
 #define mp_karatsuba_mul TclBN_mp_karatsuba_mul
+#define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul
 #define mp_karatsuba_sqr TclBN_mp_karatsuba_sqr
+#define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr
 #define mp_lshd TclBN_mp_lshd
 #define mp_mod TclBN_mp_mod
 #define mp_mod_2d TclBN_mp_mod_2d
@@ -108,7 +113,9 @@
 #define mp_to_unsigned_bin TclBN_mp_to_unsigned_bin
 #define mp_to_unsigned_bin_n TclBN_mp_to_unsigned_bin_n
 #define mp_toom_mul TclBN_mp_toom_mul
+#define s_mp_toom_mul TclBN_mp_toom_mul
 #define mp_toom_sqr TclBN_mp_toom_sqr
+#define s_mp_toom_sqr TclBN_mp_toom_sqr
 #define mp_toradix_n TclBN_mp_toradix_n
 #define mp_unsigned_bin_size TclBN_mp_unsigned_bin_size
 #define mp_xor TclBN_mp_xor

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;

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);

generic/tclVar.c

@@ -6885,6 +6885,114 @@ SetArrayDefault(
     }
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPragmaNoAliasCmd --
+ *
+ *	This function implements the 'tcl::pragma noalias' Tcl command.
+ *	Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ *	Returns a standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+TclPragmaNoAliasCmd(
+    ClientData clientData,	/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    typedef struct {
+	int setIndex;
+	Tcl_Obj *variableName;
+    } AliasData;
+    int i, j, varc, isNew, result = TCL_ERROR;
+    Var *key, *ignored;
+    Tcl_HashTable table;
+    Tcl_HashEntry *hPtr;
+    Tcl_HashSearch search;
+    Tcl_Obj **varv;
+    AliasData *aliasData;
+
+    Tcl_InitHashTable(&table, TCL_ONE_WORD_KEYS);
+
+    /*
+     * For each set of variables...
+     */
+
+    for (i=1 ; i<objc ; i++) {
+	if (Tcl_ListObjGetElements(interp, objv[i], &varc, &varv) != TCL_OK) {
+	    goto error;
+	}
+
+	/*
+	 * ... build a map from real variable location (because
+	 * TclObjLookupVarEx will follow links for us) to the name that led us
+	 * there.
+	 */
+
+	for (j=0 ; j<varc ; j++) {
+	    Tcl_Obj *varName = varv[j];
+
+	    Tcl_IncrRefCount(varName);
+	    key = TclObjLookupVarEx(interp, varName, NULL, TCL_LEAVE_ERR_MSG,
+		    "resolve", 0, 0, &ignored);
+	    if (key == NULL) {
+		TclDecrRefCount(varName);
+		goto error;
+	    }
+
+	    hPtr = Tcl_CreateHashEntry(&table, key, &isNew);
+	    if (isNew) {
+		aliasData = ckalloc(sizeof(AliasData));
+		aliasData->setIndex = i;
+		aliasData->variableName = varName;
+		Tcl_SetHashValue(hPtr, aliasData);
+		continue;
+	    }
+
+	    /*
+	     * Two variables alias, but that's OK if they're in the same
+	     * variable set.
+	     */
+
+	    aliasData = Tcl_GetHashValue(hPtr);
+	    if (aliasData->setIndex != i) {
+		/*
+		 * There was a real duplicate! Generate an error message.
+		 */
+
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"\"%s\" aliases to the same variable as \"%s\"",
+			Tcl_GetString(varName),
+			Tcl_GetString(aliasData->variableName)));
+		Tcl_SetErrorCode(interp, "TCL", "VAR_ALIAS", NULL);
+		TclDecrRefCount(varName);
+		goto error;
+	    }
+	    TclDecrRefCount(varName);
+	}
+    }
+    result = TCL_OK;
+  error:
+    for (hPtr = Tcl_FirstHashEntry(&table, &search); hPtr != NULL;
+	    hPtr = Tcl_NextHashEntry(&search)) {
+	aliasData = Tcl_GetHashValue(hPtr);
+	TclDecrRefCount(aliasData->variableName);
+	ckfree(Tcl_GetHashValue(hPtr));
+    }
+    Tcl_DeleteHashTable(&table);
+    return result;
+}
+
 /*
  * Local Variables:
  * mode: c

generic/tclZipfs.c

@@ -381,6 +381,7 @@ static int		ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index,
 static int		ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path,
 			    Tcl_LoadHandle *loadHandle,
 			    Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
+static void		ZipfsExitHandler(ClientData clientData);
 static void		ZipfsSetup(void);
 static int		ZipChannelClose(void *instanceData,
 			    Tcl_Interp *interp);
@@ -1286,6 +1287,7 @@ ZipFSCatalogFilesystem(
 
     *zf = *zf0;
     zf->mountPoint = Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
+    Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)zf);
     zf->mountPointLen = strlen(zf->mountPoint);
     zf->nameLength = strlen(zipname);
     zf->name = ckalloc(zf->nameLength + 1);
@@ -1679,9 +1681,16 @@ TclZipfs_Mount(
 	return TCL_ERROR;
     }
     if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) {
+	ckfree(zf);
 	return TCL_ERROR;
     }
-    return ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname);
+    if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname)
+	    != TCL_OK) {
+	ckfree(zf);
+	return TCL_ERROR;
+    }
+    ckfree(zf);
+    return TCL_OK;
 }
 
 /*
@@ -1711,6 +1720,7 @@ TclZipfs_MountBuffer(
     int copy)
 {
     ZipFile *zf;
+    int result;
 
     ReadLock();
     if (!ZipFS.initialized) {
@@ -1768,11 +1778,14 @@ TclZipfs_MountBuffer(
 	zf->data = data;
 	zf->ptrToFree = NULL;
     }
+    zf->passBuf[0] = 0;	/* stop valgrind cries */
     if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) {
 	return TCL_ERROR;
     }
-    return ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL,
+    result = ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL,
 	    "Memory Buffer");
+    ckfree(zf);
+    return result;
 }
 
 /*
@@ -1840,6 +1853,7 @@ TclZipfs_Unmount(
 	ckfree(z);
     }
     ZipFSCloseArchive(interp, zf);
+    Tcl_DeleteExitHandler(ZipfsExitHandler, (ClientData)zf);
     ckfree(zf);
     unmounted = 1;
   done:
@@ -1911,7 +1925,7 @@ ZipFSMountBufferObjCmd(
     unsigned char *data;
     int length;
 
-    if (objc > 4) {
+    if (objc > 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? ?data?");
 	return TCL_ERROR;
     }
@@ -4833,6 +4847,17 @@ ZipfsAppHookFindTclInit(
     return TCL_ERROR;
 }
 
+static void
+ZipfsExitHandler(
+    ClientData clientData)
+{
+    ZipFile *zf = (ZipFile *)clientData;
+
+    if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) {
+	Tcl_Panic("tried to unmount busy filesystem");
+    }
+}
+
 /*
  *-------------------------------------------------------------------------
  *

library/msgs/ja.msg

@@ -40,5 +40,5 @@ namespace eval ::tcl::clock {
     ::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY年%m月%d日"
     ::msgcat::mcset ja LOCALE_TIME_FORMAT "%H時%M分%S秒"
     ::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY年%m月%d日 (%a) %H時%M分%S秒 %z"
-    ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 西暦 0} {-3061011600 明治 1867} {-1812186000 大正 1911} {-1357635600 昭和 1925} {600220800 平成 1988}"
+    ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 西暦 0} {-3061011600 明治 1867} {-1812186000 大正 1911} {-1357635600 昭和 1925} {600220800 平成 1988} {1556668800 令和 2018}"
 }

tests-perf/test-performance.tcl

@@ -51,13 +51,13 @@ proc _test_out_total {} {
 
   set mintm 0x7fffffff
   set maxtm 0
-  set nett 0
+  set nettm 0
   set wtm 0
   set wcnt 0
   set i 0
   foreach tm $_(itm) {
     if {[llength $tm] > 6} {
-      set nett [expr {$nett + [lindex $tm 6]}]
+      set nettm [expr {$nettm + [lindex $tm 6]}]
     }
     set wtm [expr {$wtm + [lindex $tm 0]}]
     set wcnt [expr {$wcnt + [lindex $tm 2]}]
@@ -69,15 +69,15 @@ proc _test_out_total {} {
 
   puts [string repeat ** 40]
   set s [format "%d cases in %.2f sec." $tcnt [expr {([clock milliseconds] - $_(starttime)) / 1000.0}]]
-  if {$nett > 0} {
-    append s [format " (%.2f nett-sec.)" [expr {$nett / 1000.0}]]
+  if {$nettm > 0} {
+    append s [format " (%.2f net-sec.)" [expr {$nettm / 1000.0}]]
   }
   puts "Total $s:"
   lset _(m) 0 [format %.6f $wtm]
   lset _(m) 2 $wcnt
-  lset _(m) 4 [format %.3f [expr {$wcnt / (($nett ? $nett : ($tcnt * [lindex $_(reptime) 0])) / 1000.0)}]]
+  lset _(m) 4 [format %.3f [expr {$wcnt / (($nettm ? $nettm : ($tcnt * [lindex $_(reptime) 0])) / 1000.0)}]]
   if {[llength $_(m)] > 6} {
-    lset _(m) 6 [format %.3f $nett]
+    lset _(m) 6 [format %.3f $nettm]
   }
   puts $_(m)
   puts "Average:"
@@ -94,51 +94,97 @@ proc _test_out_total {} {
   puts [lindex $_(itm) $maxi]
   puts [string repeat ** 40]
   puts ""
+  unset -nocomplain _(itm) _(starttime)
+}
+
+proc _test_start {reptime} {
+  upvar _ _
+  array set _ [list itm {} reptime $reptime starttime [clock milliseconds] -from-run 0]
+}
+
+proc _test_iter {args} {
+  if {[llength $args] > 2} {
+    return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?level? measure-result\""
+  }
+  set lvl 1
+  if {[llength $args] > 1} {
+    set args [lassign $args lvl]
+  }
+  upvar $lvl _ _
+  puts [set _(m) {*}$args]
+  lappend _(itm) $_(m)
+  puts ""
+}
+
+proc _adjust_maxcount {reptime maxcount} {
+  if {[llength $reptime] > 1} {
+    lreplace $reptime 1 1 [expr {min($maxcount,[lindex $reptime 1])}]
+  } else {
+    lappend reptime $maxcount
+  }
 }
 
 proc _test_run {args} {
   upvar _ _
   # parse args:
-  set _(out-result) 1
-  if {[lindex $args 0] eq "-no-result"} {
-    set _(out-result) 0
+  array set _ [set _opts {-no-result 0 -uplevel 0}]
+  while {[llength $args] > 2} {
+    if {[set o [lindex $args 0]] ni $_opts || $_($o)} {
+      break
+    }
+    set _($o) 1
     set args [lrange $args 1 end]
   }
+  unset -nocomplain _opts o
   if {[llength $args] < 2 || [llength $args] > 3} {
     return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?-no-result? reptime lst ?outcmd?\""
   }
-  set outcmd {puts $_(r)}
+  set _(outcmd) {puts}
   set args [lassign $args reptime lst]
   if {[llength $args]} {
-    set outcmd [lindex $args 0]
+    set _(outcmd) [lindex $args 0]
   }
   # avoid output if only once:
   if {[lindex $reptime 0] <= 1 || ([llength $reptime] > 1 && [lindex $reptime 1] == 1)} {
-    set _(out-result) 0
+    set _(-no-result) 1
+  }
+  if {![info exists _(itm)]} {
+    array set _ [list itm {} reptime $reptime starttime [clock milliseconds] -from-run 1]
+  } else {
+    array set _ [list reptime $reptime]
   }
-  array set _ [list itm {} reptime $reptime starttime [clock milliseconds]]
 
   # process measurement:
   foreach _(c) [_test_get_commands $lst] {
-    puts "% [regsub -all {\n[ \t]*} $_(c) {; }]"
+    {*}$_(outcmd) "% [regsub -all {\n[ \t]*} $_(c) {; }]"
     if {[regexp {^\s*\#} $_(c)]} continue
     if {[regexp {^\s*(?:setup|cleanup)\s+} $_(c)]} {
-      puts [if 1 [lindex $_(c) 1]]
+      set _(c) [lindex $_(c) 1]
+      if {$_(-uplevel)} {
+        set _(c) [list uplevel 1 $_(c)]
+      }
+      {*}$_(outcmd) [if 1 $_(c)]
       continue
     }
+    if {$_(-uplevel)} {
+      set _(c) [list uplevel 1 $_(c)]
+    }
+    set _(ittime) $_(reptime)
     # if output result (and not once):
-    if {$_(out-result)} {
+    if {!$_(-no-result)} {
       set _(r) [if 1 $_(c)]
-      if {$outcmd ne {}} $outcmd
-      if {[llength $_(reptime)] > 1} { # decrement max-count
-        lset _(reptime) 1 [expr {[lindex $_(reptime) 1] - 1}]
+      if {$_(outcmd) ne {}} {{*}$_(outcmd) $_(r)}
+      if {[llength $_(ittime)] > 1} { # decrement max-count
+        lset _(ittime) 1 [expr {[lindex $_(ittime) 1] - 1}]
       }
     }
-    puts [set _(m) [timerate $_(c) {*}$_(reptime)]]
+    {*}$_(outcmd) [set _(m) [timerate $_(c) {*}$_(ittime)]]
     lappend _(itm) $_(m)
-    puts ""
+    {*}$_(outcmd) ""
+  }
+  if {$_(-from-run)} {
+    _test_out_total
   }
-  _test_out_total
 }
 
 }; # end of namespace ::tclTestPerf

tests/basic.test

@@ -964,6 +964,18 @@ test basic-48.24.$noComp {expansion: empty not canonical list, regression test,
     run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]}
 } -result [lrepeat 3 {}] -cleanup {unset -nocomplain a}
 
+test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -setup {
+    unset -nocomplain ::CRLF
+    set ::CRLF "\r\n"
+} -body {
+    # Force variant that turned up in Bug 2c154a40be as that's externally
+    # noticeable in an important downstream project.
+    run {scan [list {*}$::CRLF]x %c%c%c}
+} -cleanup {
+    unset -nocomplain ::CRLF
+} -result {120 {} {}}
+
+
 } ;# End of noComp loop
 
 test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {

tests/clock.test

@@ -36707,16 +36707,18 @@ test clock-58.1 {clock l10n - Japanese localisation} {*}{
     }
     -body {
 	set trouble {}
-	foreach {date jdate} [list \
-	    1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 \
-	    1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 \
-	    1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 \
-	    1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 \
-	    1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 \
-	    1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 \
-	    1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 \
-	    1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 \
-	] {
+	foreach {date jdate} {
+	    1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5
+	    1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5
+	    1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5
+	    1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5
+	    1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5
+	    1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5
+	    1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5
+	    1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5
+	    2019-04-30 \u5e73\u621031\u5e7404\u670830\u65e5
+	    2019-05-01 \u4ee4\u548c01\u5e7405\u670801\u65e5
+	} {
 	    set status [catch {
 		set secs [clock scan $date \
 			      -timezone +0900 \

tests/cmdAH.test

@@ -235,7 +235,7 @@ test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body {
 } -result {wrong # args: should be "file subcommand ?arg ...?"}
 test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body {
     file x
-} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable}
+} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable}
 test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body {
     file exists
 } -result {wrong # args: should be "file exists name"}
@@ -1526,7 +1526,7 @@ test cmdAH-29.6.1 {
 # Error conditions
 test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
     file gorp x
-} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable}
+} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable}
 test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
     file ex x
 } -match glob -result {unknown or ambiguous subcommand "ex": must be *}
@@ -1658,6 +1658,62 @@ test cmdAH-32.6 {file tempfile - templates} -body {
 } -constraints {unix nonPortable} -cleanup {
     catch {file delete $name}
 } -result ok
+
+test cmdAH-33.1 {file tempdir} -body {
+    file tempdir a b
+} -returnCodes error -result {wrong # args: should be "file tempdir ?template?"}
+test cmdAH-33.2 {file tempdir} -body {
+    set d [file tempdir]
+    list [file tail $d] [file exists $d] [file type $d] \
+	[glob -nocomplain -directory $d *]
+} -match glob -result {tcl_* 1 directory {}} -cleanup {
+    catch {file delete $d}
+}
+test cmdAH-33.3 {file tempdir} -body {
+    set d [file tempdir gorp]
+    list [file tail $d] [file exists $d] [file type $d] \
+	[glob -nocomplain -directory $d *]
+} -match glob -result {gorp_* 1 directory {}} -cleanup {
+    catch {file delete $d}
+}
+test cmdAH-33.4 {file tempdir} -setup {
+    set base [file join [temporaryDirectory] gorp]
+    file mkdir $base
+} -body {
+    set pre [glob -nocomplain -directory $base *]
+    set d [file normalize [file tempdir $base/]]
+    list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \
+	$pre [glob -nocomplain -directory $d *]
+} -match glob -result {GORP:/tcl_* 1 directory {} {}} -cleanup {
+    catch {file delete -force $base}
+}
+test cmdAH-33.5 {file tempdir} -setup {
+    set base [file join [temporaryDirectory] gorp]
+    file mkdir $base
+} -body {
+    set pre [glob -nocomplain -directory $base *]
+    set d [file normalize [file tempdir $base/gorp]]
+    list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \
+	$pre [glob -nocomplain -directory $d *]
+} -match glob -result {GORP:/gorp_* 1 directory {} {}} -cleanup {
+    catch {file delete -force $base}
+}
+test cmdAH-33.6 {file tempdir: missing parent dir} -setup {
+    set base [file join [temporaryDirectory] gorp]
+    file mkdir $base
+} -returnCodes error -body {
+    file tempdir $base/quux/
+} -cleanup {
+    catch {file delete -force $base}
+} -result {can't create temporary directory: no such file or directory}
+test cmdAH-33.7 {file tempdir: missing parent dir} -setup {
+    set base [file join [temporaryDirectory] gorp]
+    file mkdir $base
+} -returnCodes error -body {
+    file tempdir $base/quux/foobar
+} -cleanup {
+    catch {file delete -force $base}
+} -result {can't create temporary directory: no such file or directory}
 
 # This shouldn't work, but just in case a test above failed...
 catch {close $newFileId}

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

tests/cmdMZ.test

@@ -316,7 +316,7 @@ test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} {
 # The tests for Tcl_SubstObjCmd are in subst.test
 # The tests for Tcl_SwitchObjCmd are in switch.test
 
-# todo: rewrite this if monotonic clock is provided resp. command "after" 
+# todo: rewrite this if monotonic clock is provided resp. command "after"
 # gets microsecond accuracy (RFE [fdfbd5e10] gets merged):
 proc _nrt_sleep {msec} {
     set usec [expr {$msec * 1000}]
@@ -369,10 +369,10 @@ test cmdMZ-6.4 {Tcl_TimeRateObjCmd: compile of script happens even with negative
     list [catch {timerate "foreach a {c d e} \{" -12456} msg] $msg
 } {1 {missing close-brace}}
 test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} {
-    regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? nett-ms$} [timerate {} 0]
+    regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? net-ms$} [timerate {} 0]
 } 1
 test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
-    regexp {^0 \ws/# 0 # 0 #/sec 0 nett-ms$} [timerate {} 0 0]
+    regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0]
 } 1
 test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} {
     set m1 [timerate {_nrt_sleep 0} 20]
@@ -403,6 +403,14 @@ test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} {
 	[expr {[lindex $m1 4] > 1000}] \
 	[expr {[lindex $m1 6] < 10}]
 } {1 1 1 1}
+test cmdMZ-6.8.1 {Tcl_TimeRateObjCmd: allow (conditional) continue in timerate} {
+    set m1 [timerate {continue; return -code error "unexpected"} 1000 10]
+    list \
+    [expr {[lindex $m1 0] < 1000}] \
+    [expr {[lindex $m1 2] == 10}] \
+    [expr {[lindex $m1 4] > 1000}] \
+    [expr {[lindex $m1 6] < 100}]
+} {1 1 1 1}
 test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} {
     set m1 [timerate {} 1000 5];	# max-count wins
     set m2 [timerate {_nrt_sleep 20} 1 5];	# max-time wins
@@ -416,6 +424,12 @@ test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} {
 	[expr {[lindex $m1 4] == 1000000}] \
 	[expr {[lindex $m1 6] <= 0.001}]
 } {1 1 1 1}
+test cmdMZ-6.11 {Tcl_TimeRateObjCmd: done/continue optimization rollback} {
+    set m1 {set m2 ok}
+    if 1 $m1
+    timerate $m1 1000 10
+    if 1 $m1; # if rollback is missing throws an error: invoked "continue" outside of a loop
+} ok
 
 test cmdMZ-try-1.0 {
 
@@ -434,6 +448,184 @@ test cmdMZ-try-1.0 {
 } -result 5
 
 
+# Pragmas
+test cmdMZ-6.1 {tcl::pragma: basics} -returnCodes error -body {
+    tcl::pragma
+} -result {wrong # args: should be "tcl::pragma subcommand ?arg ...?"}
+test cmdMZ-6.2 {tcl::pragma: basics} -returnCodes error -body {
+    tcl::pragma ?
+} -result {unknown or ambiguous subcommand "?": must be noalias, or type}
+
+test cmdMZ-7.1 {tcl::pragma noalias} -body {
+    tcl::pragma noalias
+} -result {}
+test cmdMZ-7.2 {tcl::pragma noalias} -body {
+    tcl::pragma noalias no_such_var
+} -returnCodes error -result {can't resolve "no_such_var": no such variable}
+test cmdMZ-7.3 {tcl::pragma noalias} -body {
+    tcl::pragma noalias ::env
+} -result {}
+test cmdMZ-7.4 {tcl::pragma noalias} -body {
+    tcl::pragma noalias ::env ::tcl_platform
+} -result {}
+test cmdMZ-7.5 {tcl::pragma noalias} -body {
+    tcl::pragma noalias ::env ::tcl_platform ::auto_path
+} -result {}
+test cmdMZ-7.6 {tcl::pragma noalias} -body {
+    tcl::pragma noalias ::env ::env
+} -returnCodes error -result {"::env" aliases to the same variable as "::env"}
+test cmdMZ-7.6 {tcl::pragma noalias} -body {
+    tcl::pragma noalias {::env ::env}
+} -result {}
+test cmdMZ-7.7 {tcl::pragma noalias} -body {
+    tcl::pragma noalias {::env ::tcl_platform}
+} -result {}
+test cmdMZ-7.8 {tcl::pragma noalias} -body {
+    apply {{x y} {
+	tcl::pragma noalias env
+    }} 1 2
+} -returnCodes error -result {can't resolve "env": no such variable}
+test cmdMZ-7.9 {tcl::pragma noalias} -body {
+    apply {{x y} {
+	tcl::pragma noalias {*}[info locals]
+    }} 1 2
+} -result {}
+test cmdMZ-7.10 {tcl::pragma noalias} -body {
+    apply {{x y} {
+	global env
+	tcl::pragma noalias {*}[info locals] env
+    }} 1 2
+} -result {}
+test cmdMZ-7.11 {tcl::pragma noalias} -body {
+    apply {{x y} {
+	global env
+	upvar ::env(PATH) path
+	tcl::pragma noalias [list {*}[info locals] env path]
+    }} 1 2
+} -result {}
+test cmdMZ-7.12 {tcl::pragma noalias} -body {
+    apply {{x y} {
+	upvar 0 x z
+	tcl::pragma noalias x y z
+    }} 1 2
+} -returnCodes error -result {"z" aliases to the same variable as "x"}
+test cmdMZ-7.13 {tcl::pragma noalias} -setup {
+    variable a 3 b 4
+} -body {
+    proc swap {&x &y} {
+	upvar 1 ${&x} x ${&y} y
+	tcl::pragma noalias x y
+	set y $x[set x $y;string cat]
+	return
+    }
+    swap a b
+    list $a $b
+} -cleanup {
+    unset -nocomplain a b
+} -result {4 3}
+test cmdMZ-7.14 {tcl::pragma noalias} -setup {
+    variable a 3
+} -body {
+    proc swap {&x &y} {
+	upvar 1 ${&x} x ${&y} y
+	tcl::pragma noalias x y
+	set y $x[set x $y;string cat]
+	return
+    }
+    swap a a
+} -returnCodes error -cleanup {
+    unset -nocomplain a
+} -result {"y" aliases to the same variable as "x"}
+rename swap {}
+
+test cmdMZ-8.1 {tcl::pragma type} -returnCodes error -body {
+    tcl::pragma type
+} -result {wrong # args: should be "tcl::pragma type typeName ?value...?"}
+test cmdMZ-8.2 {tcl::pragma type} -returnCodes error -body {
+    tcl::pragma type ?
+} -result {bad type "?": must be boolean, dict, double, int32, int64, integer, list, or number}
+test cmdMZ-8.3 {tcl::pragma type} -body {
+    tcl::pragma type boolean
+} -result {}
+test cmdMZ-8.4 {tcl::pragma type} -body {
+    tcl::pragma type boolean gorp
+} -returnCodes error -result {expected boolean value but got "gorp"}
+test cmdMZ-8.5 {tcl::pragma type} -body {
+    tcl::pragma type boolean true false gorp
+} -returnCodes error -result {expected boolean value but got "gorp"}
+test cmdMZ-8.6 {tcl::pragma type} -body {
+    tcl::pragma type boolean yes no 0 1 1.5 true false on off
+} -result {}
+test cmdMZ-8.7 {tcl::pragma type} -body {
+    tcl::pragma type dict gorp
+} -returnCodes error -result {expected dict value but got "gorp"}
+test cmdMZ-8.8 {tcl::pragma type} -body {
+    tcl::pragma type dict {true false} {gorp foo bar}
+} -returnCodes error -result {expected dict value but got "gorp foo bar"}
+test cmdMZ-8.9 {tcl::pragma type} -body {
+    tcl::pragma type dict {} {yes no 0 1 1.5 true} {false on off {}}
+} -result {}
+test cmdMZ-8.10 {tcl::pragma type} -body {
+    tcl::pragma type double gorp
+} -returnCodes error -result {expected floating-point number but got "gorp"}
+test cmdMZ-8.11 {tcl::pragma type} -body {
+    tcl::pragma type double 0.1 -inf gorp
+} -returnCodes error -result {expected floating-point number but got "gorp"}
+test cmdMZ-8.12 {tcl::pragma type} -body {
+    tcl::pragma type double 0 1 0x1 123 1e2 -.0 inf { +inf }
+} -result {}
+test cmdMZ-8.13 {tcl::pragma type} -body {
+    tcl::pragma type int32 gorp
+} -returnCodes error -result {expected integer but got "gorp"}
+test cmdMZ-8.14 {tcl::pragma type} -body {
+    tcl::pragma type int32 123 0x123 gorp
+} -returnCodes error -result {expected integer but got "gorp"}
+test cmdMZ-8.15 {tcl::pragma type} -returnCodes error -body {
+    tcl::pragma type int32 123 0x123 123456123456123
+} -result {integer value too large to represent as non-long integer}
+test cmdMZ-8.16 {tcl::pragma type} -body {
+    tcl::pragma type int32 123 0b10101 0d123 0o123 0x123 { 456 }
+} -result {}
+test cmdMZ-8.17 {tcl::pragma type} -body {
+    tcl::pragma type int64 gorp
+} -returnCodes error -result {expected integer but got "gorp"}
+test cmdMZ-8.18 {tcl::pragma type} -body {
+    tcl::pragma type int64 123 0x123 gorp
+} -returnCodes error -result {expected integer but got "gorp"}
+test cmdMZ-8.19 {tcl::pragma type} -body {
+    tcl::pragma type int64 123 0b10101 0d123 0o123 0x123 { 456 } \
+	123456123456123
+} -result {}
+test cmdMZ-8.20 {tcl::pragma type} -body {
+    tcl::pragma type integer gorp
+} -returnCodes error -result {expected integer but got "gorp"}
+test cmdMZ-8.21 {tcl::pragma type} -body {
+    tcl::pragma type integer 123 0x123 gorp
+} -returnCodes error -result {expected integer but got "gorp"}
+test cmdMZ-8.22 {tcl::pragma type} -body {
+    tcl::pragma type integer 123 0b10101 0d123 0o123 0x123 { 456 } \
+	123456123456123 \
+	123456789012345678901234567890123456789012345678901234567890
+} -result {}
+test cmdMZ-8.23 {tcl::pragma type} -body {
+    tcl::pragma type list \{gorp
+} -returnCodes error -result "expected list value but got \"\{gorp\""
+test cmdMZ-8.24 {tcl::pragma type} -body {
+    tcl::pragma type list true false \{gorp
+} -returnCodes error -result "expected list value but got \"\{gorp\""
+test cmdMZ-8.25 {tcl::pragma type} -body {
+    tcl::pragma type list yes no 0 1 1.5 true false on off
+} -result {}
+test cmdMZ-8.26 {tcl::pragma type} -body {
+    tcl::pragma type number gorp
+} -returnCodes error -result {expected number but got "gorp"}
+test cmdMZ-8.27 {tcl::pragma type} -body {
+    tcl::pragma type number .5 nan gorp
+} -returnCodes error -result {expected number but got "gorp"}
+test cmdMZ-8.28 {tcl::pragma type} -body {
+    tcl::pragma type number 0 1 1.5 inf -25.375e8
+} -result {}
+
 # The tests for Tcl_WhileObjCmd are in while.test
 
 # cleanup

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.7 {Bug 2486550} -setup {
-    interp hide {} yield
+test coroutine-7.6 {Early yield crashes} -setup {
+    set i [interp create]
 } -body {
-    coroutine demo interp invokehidden {} yield ok
+    # 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 {
-    demo
-    interp expose {} yield
+    interp delete $i
+} -result ok
+test coroutine-7.7 {Bug 2486550} -setup {
+    set i [interp create]
+    $i hide yield
+} -body {
+    # Force into a child interpreter [bug 60559fd4a6]
+    $i eval {
+	coroutine demo interp invokehidden {} yield ok
+    }
+} -cleanup {
+    $i eval demo
+    interp delete $i
 } -result ok
 test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup {
     namespace eval cotest {}
@@ -781,7 +793,225 @@ test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body {
     set result
 } -result {inject-executed}
 
+test coroutine-9.1 {coroprobe with yield} -body {
+    coroutine demo apply {{} { foreach i {1 2} yield }}
+    list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo]
+} -cleanup {
+    catch {rename demo {}}
+} -result {1 {} 2 {}}
+test coroutine-9.2 {coroprobe with yieldto} -body {
+    coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }}
+    list [coroprobe demo set i] [demo a b] [coroprobe demo set i] [demo c d]
+} -cleanup {
+    catch {rename demo {}}
+} -result {1 {} 2 {{a b} {c d}}}
+test coroutine-9.3 {coroprobe errors} -setup {
+    catch {rename demo {}}
+} -body {
+    coroprobe demo set i
+} -returnCodes error -result {can only inject a probe command into a coroutine}
+test coroutine-9.4 {coroprobe errors} -body {
+    proc demo {} { foreach i {1 2} yield }
+    coroprobe demo set i
+} -returnCodes error -cleanup {
+    catch {rename demo {}}
+} -result {can only inject a probe command into a coroutine}
+test coroutine-9.5 {coroprobe errors} -body {
+    coroutine demo apply {{} { foreach i {1 2} yield }}
+    coroprobe
+} -returnCodes error -cleanup {
+    catch {rename demo {}}
+} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"}
+test coroutine-9.6 {coroprobe errors} -body {
+    coroutine demo apply {{} { foreach i {1 2} yield }}
+    coroprobe demo
+} -returnCodes error -cleanup {
+    catch {rename demo {}}
+} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"}
+test coroutine-9.7 {coroprobe errors in probe command} -body {
+    coroutine demo apply {{} { foreach i {1 2} yield }}
+    coroprobe demo set
+} -returnCodes error -cleanup {
+    catch {rename demo {}}
+} -result {wrong # args: should be "set varName ?newValue?"}
+test coroutine-9.8 {coroprobe errors in probe command} -body {
+    coroutine demo apply {{} { foreach i {1 2} yield }}
+    list [catch {coroprobe demo set}] [demo] [coroprobe demo set i]
+} -cleanup {
+    catch {rename demo {}}
+} -result {1 {} 2}
+test coroutine-9.9 {coroprobe: advanced features} -setup {
+    set i [interp create]
+} -body {
+    $i eval {
+	coroutine demo apply {{} {
+	    set f [info level],[info frame]
+	    foreach i {1 2} yield
+	}}
+	coroprobe demo apply {{} {
+	    upvar 1 f f
+	    list [info coroutine] [info level] [info frame] $f
+	}}
+    }
+} -cleanup {
+    interp delete $i
+} -result {::demo 2 3 1,2}
 
+test coroutine-10.1 {coroinject with yield} -setup {
+    set result {}
+} -body {
+    coroutine demo apply {{} { lmap i {1 2} yield }}
+    coroinject demo apply {{op val} {lappend ::result $op $val}}
+    list $result [demo x] [demo y] $result
+} -cleanup {
+    catch {rename demo {}}
+} -result {{} {} {{yield x} y} {yield x}}
+test coroutine-10.2 {coroinject stacking} -setup {
+    set result {}
+} -body {
+    coroutine demo apply {{} { lmap i {1 2} yield }}
+    coroinject demo apply {{op val} {lappend ::result $op $val A;return $val}}
+    coroinject demo apply {{op val} {lappend ::result $op $val B;return $val}}
+    list $result [demo x] [demo y] $result
+} -cleanup {
+    catch {rename demo {}}
+} -result {{} {} {x y} {yield x B yield x A}}
+test coroutine-10.3 {coroinject with yieldto} -setup {
+    set result {}
+} -body {
+    coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }}
+    coroinject demo apply {{op val} {lappend ::result $op $val;return $val}}
+    list $result [demo x mp] [demo y le] $result
+} -cleanup {
+    catch {rename demo {}}
+} -result {{} {} {{x mp} {y le}} {yieldto {x mp}}}
+test coroutine-10.4 {coroinject errors} -setup {
+    catch {rename demo {}}
+} -body {
+    coroinject demo set i
+} -returnCodes error -result {can only inject a command into a coroutine}
+test coroutine-10.5 {coroinject errors} -body {
+    proc demo {} { foreach i {1 2} yield }
+    coroinject demo set i
+} -returnCodes error -cleanup {
+    catch {rename demo {}}
+} -result {can only inject a command into a coroutine}
+test coroutine-10.6 {coroinject errors} -body {
+    coroutine demo apply {{} { foreach i {1 2} yield }}
+    coroinject
+} -returnCodes error -cleanup {
+    catch {rename demo {}}
+} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"}
+test coroutine-10.7 {coroinject errors} -body {
+    coroutine demo apply {{} { foreach i {1 2} yield }}
+    coroinject demo
+} -returnCodes error -cleanup {
+    catch {rename demo {}}
+} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"}
+test coroutine-10.8 {coroinject errors in injected command} -body {
+    coroutine demo apply {{} { foreach i {1 2} yield }}
+    coroinject demo apply {args {error "ERR: $args"}}
+    list [catch demo msg] $msg [catch demo msg] $msg
+} -cleanup {
+    catch {rename demo {}}
+} -result {1 {ERR: yield {}} 1 {invalid command name "demo"}}
+test coroutine-10.9 {coroinject: advanced features} -setup {
+    set i [interp create]
+} -body {
+    $i eval {
+	coroutine demo apply {{} {
+	    set l [info level]
+	    set f [info frame]
+	    lmap i {1 2} yield
+	}}
+	coroinject demo apply {{arg op val} {
+	    global result
+	    upvar 1 f f l l
+	    lappend result [info coroutine] $arg $op $val
+	    lappend result [info level] $l [info frame] $f
+	    lappend result [yield $arg]
+	    return [string toupper $val]
+	}} grill
+	list [demo ABC] [demo pqr] [demo def] $result
+    }
+} -cleanup {
+    interp delete $i
+} -result {grill {} {ABC def} {::demo grill yield ABC 2 1 3 2 pqr}}
+
+test coroutine-11.1 {coro type} {
+    coroutine demo eval {
+	yield
+	yield "PHASE 1"
+	yieldto string cat "PHASE 2"
+	::tcl::unsupported::corotype [info coroutine]
+    }
+    list [demo] [::tcl::unsupported::corotype demo] \
+	[demo] [::tcl::unsupported::corotype demo] [demo]
+} {{PHASE 1} yield {PHASE 2} yieldto active}
+test coroutine-11.2 {coro type} -setup {
+    catch {rename nosuchcommand ""}
+} -returnCodes error -body {
+    ::tcl::unsupported::corotype nosuchcommand
+} -result {can only get coroutine type of a coroutine}
+test coroutine-11.3 {coro type} -returnCodes error -body {
+    proc notacoroutine {} {}
+    ::tcl::unsupported::corotype notacoroutine
+} -returnCodes error -cleanup {
+    rename notacoroutine {}
+} -result {can only get coroutine type of a coroutine}
+
+test coroutine-12.1 {coroutine general introspection} -setup {
+    set i [interp create]
+} -body {
+    $i eval {
+	# Make the introspection code
+	namespace path tcl::unsupported
+	proc probe {type var} {
+	    upvar 1 $var v
+	    set f [info frame]
+	    incr f -1
+	    set result [list $v [dict get [info frame $f] proc]]
+	    if {$type eq "yield"} {
+		tailcall yield $result
+	    } else {
+		tailcall yieldto string cat $result
+	    }
+	}
+	proc pokecoro {c var} {
+	    inject $c probe [corotype $c] $var
+	    $c
+	}
+
+	# Coroutine implementations
+	proc cbody1 {} {
+	    set val [info coroutine]
+	    set accum {}
+	    while {[set val [yield $val]] ne ""} {
+		lappend accum $val
+		set val ok
+	    }
+	    return $accum
+	}
+	proc cbody2 {} {
+	    set val [info coroutine]
+	    set accum {}
+	    while {[llength [set val [yieldto string cat $val]]]} {
+		lappend accum {*}$val
+		set val ok
+	    }
+	    return $accum
+	}
+
+	# Make the coroutines
+	coroutine c1 cbody1
+	coroutine c2 cbody2
+	list [c1 abc] [c2 1 2 3] [pokecoro c1 accum] [pokecoro c2 accum] \
+	    [c1 def] [c2 4 5 6] [pokecoro c1 accum] [pokecoro c2 accum] \
+	    [c1] [c2]
+    }
+} -cleanup {
+    interp delete $i
+} -result {ok ok {abc ::cbody1} {{1 2 3} ::cbody2} ok ok {{abc def} ::cbody1} {{1 2 3 4 5 6} ::cbody2} {abc def} {1 2 3 4 5 6}}
 
 # cleanup
 unset lambda

tests/dict.test

@@ -2047,6 +2047,111 @@ test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]}
 	dict update item item item two two {}
     }}
 } {}
+
+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
+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-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
+} -result b
+test dict-27.2 {dict getwithdefault command} -body {
+    dict getwithdefault {a b} b c
+} -result c
+test dict-27.3 {dict getwithdefault command} -body {
+    dict getwithdefault {a {b c}} a b d
+} -result c
+test dict-27.4 {dict getwithdefault command} -body {
+    dict getwithdefault {a {b c}} a c d
+} -result d
+test dict-27.5 {dict getwithdefault command} -body {
+    dict getwithdefault {a {b c}} b c d
+} -result d
+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-27.7 {dict getwithdefault command} -returnCodes error -body {
+    dict getwithdefault
+} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
+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-27.9 {dict getwithdefault command} -returnCodes error -body {
+    dict getwithdefault {} {}
+} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
+test dict-27.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-27.17 {dict getdef command} -returnCodes error -body {
+    $dict getwithdefault {a b c} d e
+} -result {missing value to go with key}
 
 # cleanup
 ::tcltest::cleanupTests

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.
 

tests/info.test

@@ -768,26 +768,26 @@ test info-22.8 {info frame, basic trace} -match glob -body {
 * {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
 unset -nocomplain msg
 
-test info-23.0.0 {eval'd info frame} {!singleTestInterp} {
-    eval {info frame}
-} 8
-test info-23.0.1 {eval'd info frame} -constraints {singleTestInterp} -match glob -body {
-    eval {info frame}
-} -result {1[12]} ;# SingleTestInterp results changes depending on running the whole suite, or info.test alone.
-test info-23.1.0 {eval'd info frame, semi-dynamic} {!singleTestInterp} {
-    eval info frame
-} 8
-test info-23.1.1 {eval'd info frame, semi-dynamic} -constraints {singleTestInterp} -match glob -body {
-    eval info frame
-} -result {1[12]}
-test info-23.2.0 {eval'd info frame, dynamic} -constraints {!singleTestInterp} -body {
-    set script {info frame}
-    eval $script
-} -cleanup {unset script} -result 8
-test info-23.2.1 {eval'd info frame, dynamic} -constraints {singleTestInterp} -match glob -body {
-    set script {info frame}
-    eval $script
-} -cleanup {unset script} -result {1[12]}
+
+
+
+
+
+
+
+
+
+## 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} -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

tests/interp.test

@@ -20,7 +20,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
 
 testConstraint testinterpdelete [llength [info commands testinterpdelete]]
 
-set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload}
+set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload}
 
 foreach i [interp slaves] {
   interp delete $i

tests/io.test

@@ -5963,6 +5963,69 @@ test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fi
 } {initial foo eof}
 
 close $f
+
+test chan-io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup {
+} -constraints {stdio unixExecs fileevent openpipe} -body {
+
+    namespace eval refchan {
+	namespace ensemble create
+	namespace export *
+
+
+	proc finalize {chan args} {
+	    namespace delete c_$chan
+	}
+
+	proc initialize {chan args} {
+	    namespace eval c_$chan {}
+	    namespace upvar c_$chan watching watching
+	    set watching {}
+	    list finalize initialize seek watch write
+	}
+
+
+	proc watch {chan args} {
+	    namespace upvar c_$chan watching watching
+	    foreach arg $args {
+		switch $arg {
+		    write {
+			if {$arg ni $watching} {
+			    lappend watching $arg
+			}
+			chan postevent $chan $arg
+		    }
+		}
+	    }
+	}
+
+
+	proc write {chan args} {
+	    chan postevent $chan write
+	    return 1
+	}
+    }
+    set f [chan create w [namespace which refchan]]
+    chan configure $f -blocking 0
+    set data "some data"
+    set x 0
+    chan event $f writable [namespace code {
+	puts $f $data
+	incr count [string length $data]
+	if {$count > 262144} {
+	    chan event $f writable {}
+	    set x done
+	}
+    }]
+    after 10000 [namespace code {
+	set x timeout
+    }]
+    vwait [namespace which -variable x]
+    return $x
+} -cleanup {
+    catch {chan close $f}
+} -result done
+
+
 makeFile "foo bar" foo
 
 test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {

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).
 
@@ -912,6 +930,17 @@ proc onfinal {} {
     if {[lindex $hargs 0] ne "finalize"} {return}
     return -code return ""
 }
+
+proc onwatch {} {
+    upvar args hargs
+    lassign $hargs watch chan eventspec
+    if {$watch ne "watch"} return
+    foreach spec $eventspec {
+	chan postevent $chan $spec
+    }
+    return
+}
+
 }
 
 # Set everything up in the main thread.
@@ -1984,28 +2013,29 @@ test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; return}
     set c [chan create {r w} foo]
-    note [fileevent $c readable {note TOCK}]
-    set stop [after 10000 {note TIMEOUT}]
+    set tock {}
+    note [fileevent $c readable {lappend res TOCK; set tock 1}]
+    set stop [after 10000 {lappend res TIMEOUT; set tock 1}]
     after  1000 {note [chan postevent $c r]}
-    vwait ::res
+    vwait ::tock
     catch {after cancel $stop}
     close $c
     rename foo {}
     set res
-} -result {{watch rc* read} {} TOCK {} {watch rc* {}}}
+} -result {{watch rc* read} {} {} TOCK {watch rc* {}}}
 test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; return}
     set c [chan create {r w} foo]
-    note [fileevent $c writable {note TOCK}]
-    set stop [after 10000 {note TIMEOUT}]
+    note [fileevent $c writable {lappend res TOCK; set tock 1}]
+    set stop [after 10000 {lappend res TIMEOUT; set tock 1}]
     after  1000 {note [chan postevent $c w]}
-    vwait ::res
+    vwait ::tock
     catch {after cancel $stop}
     close $c
     rename foo {}
     set res
-} -result {{watch rc* write} {} TOCK {} {watch rc* {}}}
+} -result {{watch rc* write} {} {} TOCK {watch rc* {}}}
 test iocmd-31.8 {chan postevent after close throws error} -match glob -setup {
     proc foo {args} {oninit; onfinal; track; return}
     proc dummy args { return }
@@ -2018,6 +2048,31 @@ test iocmd-31.8 {chan postevent after close throws error} -match glob -setup {
     rename foo   {}
     rename dummy {}
 } -returnCodes error -result {can not find reflected channel named "rc*"}
+test iocmd-31.9 {
+    chan postevent
+
+    call to current coroutine
+
+    see 67a5eabbd3d1
+} -match glob -body {
+    set res {}
+    proc foo {args} {oninit; onwatch; onfinal; track; return}
+    set c [chan create {r w} foo]
+    after 0 [list ::apply [list c {
+	coroutine c1 ::apply [list c {
+	    chan event $c readable [list [info coroutine]]
+	    yield
+	    set ::done READING
+	} [namespace current]] $c
+    } [namespace current]] $c]
+    set stop [after 10000 {set done TIMEOUT}]
+    vwait ::done
+    catch {after cancel $stop}
+    lappend res $done
+    close $c
+    rename foo {}
+    set res
+} -result {{watch rc* read} READING {watch rc* {}}}
 
 # --- === *** ###########################
 # 'Pull the rug' tests. Create channel in a interpreter A, move to

tests/link.test

@@ -20,11 +20,22 @@ if {"::tcltest" ni [namespace children]} {
 catch [list package require -exact Tcltest [info patchlevel]]
 
 testConstraint testlink [llength [info commands testlink]]
+testConstraint testlinkarray [llength [info commands testlinkarray]]
 
 foreach i {int real bool string} {
     unset -nocomplain $i
 }
 
+test link-0.1 {leak test} {testlink} {
+    interp create i
+    load {} Tcltest i
+    i eval {
+	testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0
+	namespace delete ::
+    }
+    interp delete i
+} {}
+
 test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
     testlink delete
 } -body {
@@ -88,7 +99,7 @@ test link-2.5 {writing bad values into variables} -setup {
     testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
     testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
     list [catch {set wide gorp} msg] $msg $bool
-} -result {1 {can't set "wide": variable must have integer value} 1}
+} -result {1 {can't set "wide": variable must have wide integer value} 1}
 test link-2.6 {writing C variables from Tcl} -constraints {testlink} -setup {
     testlink delete
 } -body {
@@ -363,7 +374,7 @@ test link-7.7 {access to linked variables via upvar} -setup {
     testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
     testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {}
     list [catch x msg] $msg $wide
-} -result {1 {can't set "y": variable must have integer value} 778899}
+} -result {1 {can't set "y": variable must have wide integer value} 778899}
 
 test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} {
     proc x args {
@@ -398,6 +409,477 @@ test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} {
 	testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {}
     } msg] $msg $int
 } {0 {} 47}
+
+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]
+} -body {
+    testlinkarray create char* 1 ::my(var)
+    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
+    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
+    return $msg
+} -cleanup {
+    testlinkarray remove ::my(var)
+    unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-11.1 {linkarray char} -setup {
+    set mylist [list]
+} -body {
+    testlinkarray create char 1 ::my(var)
+    catch {set ::my(var) x} msg
+    lappend mylist $msg
+    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
+    return $msg
+} -cleanup {
+    testlinkarray remove ::my(var)
+    unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-12.1 {linkarray unsigned char} -setup {
+    set mylist [list]
+} -body {
+    testlinkarray create uchar 1 ::my(var)
+    catch {set ::my(var) x} msg
+    lappend mylist $msg
+    lappend mylist [set ::my(var) 120]
+    catch {set ::my(var) 1234} msg
+    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
+    return $msg
+} -cleanup {
+    testlinkarray remove ::my(var)
+    unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-13.1 {linkarray short} -setup {
+    set mylist [list]
+} -body {
+    testlinkarray create short 1 ::my(var)
+    catch {set ::my(var) x} msg
+    lappend mylist $msg
+    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
+    return $msg
+} -cleanup {
+    testlinkarray remove ::my(var)
+    unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-14.1 {linkarray unsigned short} -setup {
+    set mylist [list]
+} -body {
+    testlinkarray create ushort 1 ::my(var)
+    catch {set ::my(var) x} msg
+    lappend mylist $msg
+    lappend mylist [set ::my(var) 120]
+    catch {set ::my(var) 123456} msg
+    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
+    return $msg
+} -cleanup {
+    testlinkarray remove ::my(var)
+    unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-15.1 {linkarray int} -setup {
+    set mylist [list]
+} -body {
+    testlinkarray create int 1 ::my(var)
+    catch {set ::my(var) x} msg
+    lappend mylist $msg
+    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
+    return $msg
+} -cleanup {
+    testlinkarray remove ::my(var)
+    unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-16.1 {linkarray unsigned int} -setup {
+    set mylist [list]
+} -body {
+    testlinkarray create uint 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
+    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
+    return $msg
+} -cleanup {
+    testlinkarray remove ::my(var)
+    unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-17.1 {linkarray long} -setup {
+    set mylist [list]
+} -body {
+    testlinkarray create long 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 * 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
+    return $msg
+} -cleanup {
+    testlinkarray remove ::my(var)
+    unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-18.1 {linkarray unsigned long} -setup {
+    set mylist [list]
+} -body {
+    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} -body {
+    testlinkarray create ulong 1 ::my(var)
+    set ::my(var) 120
+    catch {set ::my(var) -1} 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
+    return $msg
+} -cleanup {
+    testlinkarray remove ::my(var)
+    unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-19.1 {linkarray wide} -setup {
+    set mylist [list]
+} -body {
+    testlinkarray create wide 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 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
+    return $msg
+} -cleanup {
+    testlinkarray remove ::my(var)
+    unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-20.1 {linkarray unsigned wide} -setup {
+    set mylist [list]
+} -body {
+    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
+    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} 0xbabed00dbabed00d}
+test link-20.2 {linkarray unsigned wide} -body {
+    testlinkarray create uwide 1 ::my(var)
+    set ::my(var) 120
+    catch {set ::my(var) -1} 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
+    return $msg
+} -cleanup {
+    testlinkarray remove ::my(var)
+    unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+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)
+} -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
+    return $msg
+} -cleanup {
+    testlinkarray remove ::my(var)
+    unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+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} 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
+    catch {set ::my(var) abcde} msg
+    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
+    return $msg
+} -cleanup {
+    testlinkarray remove ::my(var)
+    unset -nocomplain my
+} -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}

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] \

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

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
 

tests/upvar.test

@@ -356,6 +356,10 @@ test upvar-8.11 {upvar will not create a variable that looks like an array} -set
 test upvar-9.1 {Tcl_UpVar2 procedure} testupvar {
     list [catch {testupvar xyz a {} x global} msg] $msg
 } {1 {bad level "xyz"}}
+test upvar-9.1.1 {TclGetFrame, via Tcl_UpVar2} testupvar {
+    apply {{} {testupvar xyz a {} x local; set x foo}}
+    set a
+} foo
 test upvar-9.2 {Tcl_UpVar2 procedure} testupvar {
     catch {unset a}
     catch {unset x}

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

unix/Makefile.in

@@ -685,20 +685,20 @@ ${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS}
 	@rm -rf ${TCL_VFS_ROOT}
 	@mkdir -p ${TCL_VFS_PATH}
 	@echo "creating ${TCL_VFS_PATH} (prepare compression)"
-	@( \
-	  ln -s $(TOP_DIR)/library/* ${TCL_VFS_PATH}/ && \
-	  ln ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl \
-	) || ( \
-	  cp -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \
-	  cp -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \
-	)
+	@if \
+	    ln -s $(TOP_DIR)/library/* ${TCL_VFS_PATH}/ && \
+	    ln ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \
+	then : ; else \
+	    cp -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \
+	    cp -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \
+	fi
 	@find ${TCL_VFS_ROOT} -type d -empty -delete
-	(zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}') 2>/dev/null || \
-	  (echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?")`; \
-	  cd ${TCL_VFS_ROOT} && \
-	  $$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null && \
-	  echo "${TCL_ZIP_FILE} successful created with $$zip" && \
-	  cd ..)
+	@echo "creating ${TCL_ZIP_FILE} from ${TCL_VFS_PATH}"
+	@(zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}' || \
+	    echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?")  2>/dev/null`; \
+	    echo 'cd ${TCL_VFS_ROOT} &&' $$zip '${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH}'; \
+	    cd ${TCL_VFS_ROOT} && \
+	    $$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null)
 
 # The following target is configured by autoconf to generate either a shared
 # library or non-shared library for Tcl.
@@ -706,9 +706,9 @@ ${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} ${TCL_ZIP_FILE}
 	rm -f $@
 	@MAKE_LIB@
 	@if test "${ZIPFS_BUILD}" = "1" ; then \
-		cat ${TCL_ZIP_FILE} >> ${LIB_FILE}; \
-		${NATIVE_ZIP} -A ${LIB_FILE} \
-		  || echo 'ignore zip-error by adjust sfx process (not executable?)'; \
+	    cat ${TCL_ZIP_FILE} >> ${LIB_FILE}; \
+	    ${NATIVE_ZIP} -A ${LIB_FILE} \
+	    || echo 'ignore zip-error by adjust sfx process (not executable?)'; \
 	fi
 
 ${STUB_LIB_FILE}: ${STUB_LIB_OBJS}
@@ -2088,8 +2088,9 @@ checkstubs: $(TCL_LIB_FILE)
 
 checkdoc: $(TCL_LIB_FILE)
 	-@for i in `nm -p $(TCL_LIB_FILE) | awk '$$3 ~ /Tcl_/ { print $$3 }' \
-		| grep -v 'Cmd$$' | sort -n` ; do \
+		| grep -Fv . | grep -v 'Cmd$$' | sort -n` ; do \
 	    match=0; \
+	    i=`echo $$i | sed 's/^_//'`; \
 	    for j in $(TOP_DIR)/doc/*.3 ; do \
 		if [ `grep '\-' $$j | grep -c $$i` -gt 0 ] ; then \
 		    match=1; \
@@ -2105,7 +2106,7 @@ checkdoc: $(TCL_LIB_FILE)
 #
 
 checkuchar:
-	-egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR
+	-@egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR
 
 #
 # Target to make sure that only symbols with "Tcl" prefixes are exported.
@@ -2125,14 +2126,17 @@ checkexports: $(TCL_LIB_FILE)
 # system.
 #
 
+RPM_PLATFORMS = i386
 rpm: all
 	-@rm -f THIS.TCL.SPEC
 	echo "%define _builddir `pwd`" > THIS.TCL.SPEC
 	echo "%define _rpmdir `pwd`/RPMS" >> THIS.TCL.SPEC
 	cat tcl.spec >> THIS.TCL.SPEC
-	mkdir -p RPMS/i386
-	rpmbuild -bb THIS.TCL.SPEC
-	mv RPMS/i386/*.rpm .
+	for platform in $(RPM_PLATFORMS); do \
+	    mkdir -p RPMS/$$platform && \
+	    rpmbuild -bb THIS.TCL.SPEC && \
+	    mv RPMS/$$platform/*.rpm .; \
+	done
 	-rm -rf RPMS THIS.TCL.SPEC
 
 #
@@ -2155,7 +2159,8 @@ $(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure
 $(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure
 	cd $(MAC_OSX_DIR); autoheader; touch $@
 
-dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(MAC_OSX_DIR)/configure genstubs dist-packages ${NATIVE_TCLSH}
+dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in \
+		$(MAC_OSX_DIR)/configure genstubs dist-packages ${NATIVE_TCLSH}
 	rm -rf $(DISTDIR)
 	mkdir -p $(DISTDIR)/unix
 	cp -p $(UNIX_DIR)/*.[ch] $(DISTDIR)/unix
@@ -2181,7 +2186,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M
 	@mkdir $(DISTDIR)/library
 	cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \
 		$(TOP_DIR)/library/tclIndex $(DISTDIR)/library
-	for i in $(BUILTIN_PACKAGE_LIST) ; do \
+	@for i in $(BUILTIN_PACKAGE_LIST) ; do \
 	    mkdir $(DISTDIR)/library/$$i;\
 	    cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \
 	done
@@ -2190,8 +2195,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M
 	@mkdir $(DISTDIR)/library/msgs
 	cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs
 	@echo cp -r $(TOP_DIR)/library/tzdata $(DISTDIR)/library/tzdata
-	@( cd $(TOP_DIR); \
-	  find library/tzdata -name CVS -prune -o -type f -print ) \
+	@( cd $(TOP_DIR); find library/tzdata -type f -print ) \
 	    | ( cd $(TOP_DIR) ; xargs tar cf - ) \
 	    | ( cd $(DISTDIR) ; tar xfp - )
 	@mkdir $(DISTDIR)/doc
@@ -2201,8 +2205,8 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M
 	cp -p $(TOP_DIR)/license.terms $(COMPAT_DIR)/*.[ch] \
 		$(COMPAT_DIR)/README $(DISTDIR)/compat
 	@mkdir $(DISTDIR)/compat/zlib
-	( cd $(COMPAT_DIR)/zlib; \
-	  find . -name CVS -prune -o -type f -print ) \
+	@echo cp -r $(COMPAT_DIR)/zlib $(DISTDIR)/compat/zlib
+	@( cd $(COMPAT_DIR)/zlib; find . -type f -print ) \
 	    | ( cd $(COMPAT_DIR)/zlib ; xargs tar cf - ) \
 	    | ( cd $(DISTDIR)/compat/zlib ; tar xfp - )
 	@mkdir $(DISTDIR)/tests

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"

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

unix/dltest/Makefile.in

@@ -17,7 +17,7 @@ TCL_VERSION=		@TCL_VERSION@
 
 CFLAGS_DEBUG		= @CFLAGS_DEBUG@
 CFLAGS_OPTIMIZE		= @CFLAGS_OPTIMIZE@
-CFLAGS			= @CFLAGS_DEFAULT@ @CFLAGS@
+CFLAGS			= @CFLAGS_DEFAULT@ @CFLAGS@ -DTCL_NO_DEPRECATED=1
 LDFLAGS_DEBUG		= @LDFLAGS_DEBUG@
 LDFLAGS_OPTIMIZE	= @LDFLAGS_OPTIMIZE@
 LDFLAGS			= @LDFLAGS_DEFAULT@ @LDFLAGS@

unix/tclUnixChan.c

@@ -48,6 +48,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
@@ -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,18 @@ typedef struct {
 				 * which operations are valid on the file. */
 } FileState;
 
+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
 
 /*
@@ -83,7 +106,7 @@ typedef struct {
     int stop;
 } TtyAttrs;
 
-#endif	/* !SUPPORTS_TTY */
+#endif	/* SUPPORTS_TTY */
 
 #define UNSUPPORTED_OPTION(detail) \
     if (interp) {							\
@@ -113,6 +136,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 +187,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 +335,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 +373,46 @@ FileCloseProc(
     ckfree(fsPtr);
     return errorCode;
 }
+
+#ifdef SUPPORTS_TTY
+static int
+TtyCloseProc(
+    ClientData instanceData,
+    Tcl_Interp *interp)
+{
+    TtyState *ttyPtr = instanceData;
+
+    /*
+     * If we've been asked by the user to drain or flush, do so now.
+     */
+
+    switch (ttyPtr->closeMode) {
+    case CLOSE_DRAIN:
+	tcdrain(ttyPtr->fileState.fd);
+	break;
+    case CLOSE_DISCARD:
+	tcflush(ttyPtr->fileState.fd, TCIOFLUSH);
+	break;
+    default:
+	/* Do nothing */
+	break;
+    }
+
+    /*
+     * 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.
+     */
+
+    return FileCloseProc(instanceData, interp);
+}
+#endif /* SUPPORTS_TTY */
 
 /*
  *----------------------------------------------------------------------
@@ -578,7 +644,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 +667,7 @@ TtySetOptionProc(
 	 * system calls results should be checked there. - dl
 	 */
 
-	TtySetAttributes(fsPtr->fd, &tty);
+	TtySetAttributes(fsPtr->fileState.fd, &tty);
 	return TCL_OK;
     }
 
@@ -614,7 +680,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 +711,7 @@ TtySetOptionProc(
 	    }
 	    return TCL_ERROR;
 	}
-	tcsetattr(fsPtr->fd, TCSADRAIN, &iostate);
+	tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate);
 	return TCL_OK;
     }
 
@@ -668,7 +734,7 @@ TtySetOptionProc(
 	    return TCL_ERROR;
 	}
 
-	tcgetattr(fsPtr->fd, &iostate);
+	tcgetattr(fsPtr->fileState.fd, &iostate);
 
 	iostate.c_cc[VSTART] = argv[0][0];
 	iostate.c_cc[VSTOP] = argv[1][0];
@@ -689,7 +755,7 @@ TtySetOptionProc(
 	}
 	ckfree(argv);
 
-	tcsetattr(fsPtr->fd, TCSADRAIN, &iostate);
+	tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate);
 	return TCL_OK;
     }
 
@@ -700,13 +766,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;
     }
 
@@ -733,7 +799,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);
@@ -754,9 +820,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");
@@ -776,7 +842,7 @@ TtySetOptionProc(
 	    }
 	} /* -ttycontrol options loop */
 
-	ioctl(fsPtr->fd, TIOCMSET, &control);
+	ioctl(fsPtr->fileState.fd, TIOCMSET, &control);
 	ckfree(argv);
 	return TCL_OK;
 #else /* TIOCMGET&TIOCMSET */
@@ -784,8 +850,112 @@ 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 serial terminal control state: %s",
+			Tcl_PosixError(interp)));
+	    }
+	    return TCL_ERROR;
+	}
+	if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) {
+	    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) {
+	    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) {
+#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, raw, or reset", 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 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;
+    }
+
     return Tcl_BadChannelOption(interp, optionName,
-	    "mode handshake timeout ttycontrol xchar");
+	    "closemode inputmode mode handshake timeout ttycontrol xchar");
 }
 
 /*
@@ -813,16 +983,74 @@ 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. */
+    struct termios iostate;
 
     if (optionName == NULL) {
 	len = 0;
     } 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)) {
+	valid = 1;
+	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");
+	    } else {
+		Tcl_DStringAppendElement(dsPtr, "password");
+	    }
+	} else {
+	    Tcl_DStringAppendElement(dsPtr, "raw");
+	}
+    }
+
+    /*
+     * Get option -mode
+     */
+
     if (len == 0) {
 	Tcl_DStringAppendElement(dsPtr, "-mode");
     }
@@ -830,7 +1058,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);
     }
@@ -844,11 +1072,10 @@ TtyGetOptionProc(
 	Tcl_DStringStartSublist(dsPtr);
     }
     if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) {
-	struct termios iostate;
 	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);
@@ -873,10 +1100,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);
@@ -895,16 +1122,42 @@ TtyGetOptionProc(
 	int status;
 
 	valid = 1;
-	ioctl(fsPtr->fd, TIOCMGET, &status);
+	ioctl(fsPtr->fileState.fd, TIOCMGET, &status);
 	TtyModemStatusStr(status, dsPtr);
     }
 #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,
-		"mode queue ttystatus xchar");
+		"closemode inputmode mode queue ttystatus winsize xchar");
 }
 
 static const struct {int baud; speed_t speed;} speeds[] = {
@@ -1375,7 +1628,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;
@@ -1431,8 +1684,6 @@ TclpOpenFileChannel(
 
     fcntl(fd, F_SETFD, FD_CLOEXEC);
 
-    sprintf(channelName, "file%d", fd);
-
 #ifdef SUPPORTS_TTY
     if (strcmp(native, "/dev/tty") != 0 && isatty(fd)) {
 	/*
@@ -1452,18 +1703,27 @@ 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(FileState));
-    fsPtr->validMask = channelPermissions | TCL_EXCEPTION;
-    fsPtr->fd = fd;
+    fsPtr = ckalloc(sizeof(TtyState));
+    fsPtr->fileState.validMask = channelPermissions | TCL_EXCEPTION;
+    fsPtr->fileState.fd = fd;
+#ifdef SUPPORTS_TTY
+    if (channelTypePtr == &ttyChannelType) {
+	fsPtr->closeMode = CLOSE_DEFAULT;
+	fsPtr->doReset = 0;
+	tcgetattr(fsPtr->fileState.fd, &fsPtr->initState);
+    }
+#endif /* SUPPORTS_TTY */
 
-    fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
+    fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName,
 	    fsPtr, channelPermissions);
 
     if (translation != NULL) {
@@ -1475,14 +1735,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;
 }
 
 /*
@@ -1507,7 +1767,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;
@@ -1526,22 +1786,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;
 }
 
 /*

unix/tclUnixFCmd.c

@@ -2273,6 +2273,85 @@ DefaultTempDir(void)
     return TCL_TEMPORARY_FILE_DIRECTORY;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpCreateTemporaryDirectory --
+ *
+ *	Creates a temporary directory, possibly based on the supplied bits and
+ *	pieces of template supplied in the arguments.
+ *
+ * Results:
+ *	An object (refcount 0) containing the name of the newly-created
+ *	directory, or NULL on failure.
+ *
+ * Side effects:
+ *	Accesses the native filesystem. Makes a directory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclpCreateTemporaryDirectory(
+    Tcl_Obj *dirObj,
+    Tcl_Obj *basenameObj)
+{
+    Tcl_DString template, tmp;
+    const char *string;
+
+#define DEFAULT_TEMP_DIR_PREFIX	"tcl"
+
+    /*
+     * Build the template in writable memory from the user-supplied pieces and
+     * some defaults.
+     */
+
+    if (dirObj) {
+	string = TclGetString(dirObj);
+	Tcl_UtfToExternalDString(NULL, string, dirObj->length, &template);
+    } else {
+	Tcl_DStringInit(&template);
+	Tcl_DStringAppend(&template, DefaultTempDir(), -1); /* INTL: native */
+    }
+
+    if (Tcl_DStringValue(&template)[Tcl_DStringLength(&template) - 1] != '/') {
+	TclDStringAppendLiteral(&template, "/");
+    }
+
+    if (basenameObj) {
+	string = TclGetString(basenameObj);
+	if (basenameObj->length) {
+	    Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp);
+	    TclDStringAppendDString(&template, &tmp);
+	    Tcl_DStringFree(&tmp);
+	} else {
+	    TclDStringAppendLiteral(&template, DEFAULT_TEMP_DIR_PREFIX);
+	}
+    } else {
+	TclDStringAppendLiteral(&template, DEFAULT_TEMP_DIR_PREFIX);
+    }
+
+    TclDStringAppendLiteral(&template, "_XXXXXX");
+
+    /*
+     * Make the temporary directory.
+     */
+
+    if (mkdtemp(Tcl_DStringValue(&template)) == NULL) {
+	Tcl_DStringFree(&template);
+	return NULL;
+    }
+
+    /*
+     * The template has been updated. Tell the caller what it was.
+     */
+
+    Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&template),
+	    Tcl_DStringLength(&template), &tmp);
+    Tcl_DStringFree(&template);
+    return TclDStringToObj(&tmp);
+}
+
 #if defined(__CYGWIN__)
 
 static void

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. */
@@ -568,6 +577,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
@@ -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);
@@ -1414,6 +1436,213 @@ ConsoleThreadActionProc(
     Tcl_MutexUnlock(&consoleMutex);
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+    int vlen = strlen(value);
+
+    /*
+     * 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, "");
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+    char buf[TCL_INTEGER_SPACE];
+
+    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");
+	    }
+	}
+    }
+
+    /*
+     * 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 winsize");
+    } else {
+	return Tcl_BadChannelOption(interp, optionName, "");
+    }
+}
+
 /*
  * Local Variables:
  * mode: c

win/tclWinFCmd.c

@@ -1956,6 +1956,121 @@ TclpObjListVolumes(void)
     return resultPtr;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpCreateTemporaryDirectory --
+ *
+ *	Creates a temporary directory, possibly based on the supplied bits and
+ *	pieces of template supplied in the arguments.
+ *
+ * Results:
+ *	An object (refcount 0) containing the name of the newly-created
+ *	directory, or NULL on failure.
+ *
+ * Side effects:
+ *	Accesses the native filesystem. Makes a directory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclpCreateTemporaryDirectory(
+    Tcl_Obj *dirObj,
+    Tcl_Obj *basenameObj)
+{
+    Tcl_DString base, name;	/* Contains WCHARs */
+    int baseLen;
+    DWORD error;
+    WCHAR tempBuf[MAX_PATH + 1];
+    DWORD len = GetTempPathW(MAX_PATH, tempBuf);
+
+    /*
+     * Build the path in writable memory from the user-supplied pieces and
+     * some defaults. First, the parent temporary directory.
+     */
+
+    if (dirObj) {
+	Tcl_GetString(dirObj);
+	if (dirObj->length < 1) {
+	    goto useSystemTemp;
+	}
+	Tcl_WinUtfToTChar(Tcl_GetString(dirObj), -1, &base);
+	if (dirObj->bytes[dirObj->length - 1] != '\\') {
+	    TclUtfToWCharDString("\\", -1, &base);
+	}
+    } else {
+    useSystemTemp:
+	Tcl_DStringInit(&base);
+	Tcl_DStringAppend(&base, (char *) tempBuf, len * sizeof(WCHAR));
+    }
+
+    /*
+     * Next, the base of the directory name.
+     */
+
+#define DEFAULT_TEMP_DIR_PREFIX	"tcl"
+#define SUFFIX_LENGTH	8
+
+    if (basenameObj) {
+	Tcl_WinUtfToTChar(Tcl_GetString(basenameObj), -1, &name);
+	TclDStringAppendDString(&base, &name);
+	Tcl_DStringFree(&name);
+    } else {
+	TclUtfToWCharDString(DEFAULT_TEMP_DIR_PREFIX, -1, &base);
+    }
+    TclUtfToWCharDString("_", -1, &base);
+
+    /*
+     * Now we keep on trying random suffixes until we get one that works
+     * (i.e., that doesn't trigger the ERROR_ALREADY_EXISTS error). Note that
+     * SUFFIX_LENGTH is longer than on Unix because we expect to be not on a
+     * case-sensitive filesystem.
+     */
+
+    baseLen = Tcl_DStringLength(&base);
+    do {
+	char tempbuf[SUFFIX_LENGTH + 1];
+	int i;
+	static const char randChars[] =
+	    "QWERTYUIOPASDFGHJKLZXCVBNM1234567890";
+	static const int numRandChars = sizeof(randChars) - 1;
+
+	/*
+	 * Put a random suffix on the end.
+	 */
+
+	error = ERROR_SUCCESS;
+	tempbuf[SUFFIX_LENGTH] = '\0';
+	for (i = 0 ; i < SUFFIX_LENGTH; i++) {
+	    tempbuf[i] = randChars[(int) (rand() % numRandChars)];
+	}
+	Tcl_DStringSetLength(&base, baseLen);
+	TclUtfToWCharDString(tempbuf, -1, &base);
+    } while (!CreateDirectoryW((LPCWSTR) Tcl_DStringValue(&base), NULL)
+	    && (error = GetLastError()) == ERROR_ALREADY_EXISTS);
+
+    /*
+     * Check for other errors. The big ones are ERROR_PATH_NOT_FOUND and
+     * ERROR_ACCESS_DENIED.
+     */
+
+    if (error != ERROR_SUCCESS) {
+	TclWinConvertError(error);
+	Tcl_DStringFree(&base);
+	return NULL;
+    }
+
+    /*
+     * We actually made the directory, so we're done! Report what we made back
+     * as a (clean) Tcl_Obj.
+     */
+
+    Tcl_WinTCharToUtf((LPCWSTR) Tcl_DStringValue(&base), -1, &name);
+    Tcl_DStringFree(&base);
+    return TclDStringToObj(&name);
+}
+
 /*
  * Local Variables:
  * mode: c

win/tclWinFile.c

@@ -680,7 +680,8 @@ NativeReadReparse(
     HANDLE hFile;
     DWORD returnedLength;
 
-    hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL, OPEN_EXISTING,
+    hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL,
+	    OPEN_EXISTING,
 	    FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
 
     if (hFile == INVALID_HANDLE_VALUE) {
@@ -842,7 +843,7 @@ tclWinDebugPanic(
 #endif
     abort();
 }
-
+
 /*
  *---------------------------------------------------------------------------
  *
@@ -1450,11 +1451,16 @@ TclpGetUserHome(
     if (domain == NULL) {
 	const char *ptr;
 
-	/* no domain - firstly check it's the current user */
-	if ( (ptr = TclpGetUserName(&ds)) != NULL
-	  && strcasecmp(name, ptr) == 0
-	) {
-	    /* try safest and fastest way to get current user home */
+	/*
+	 * No domain. Firstly check it's the current user
+	 */
+
+	ptr = TclpGetUserName(&ds);
+	if (ptr != NULL && strcasecmp(name, ptr) == 0) {
+	    /*
+	     * Try safest and fastest way to get current user home
+	     */
+
 	    ptr = TclGetEnv("HOME", &ds);
 	    if (ptr != NULL) {
 		Tcl_JoinPath(1, &ptr, bufferPtr);
@@ -1475,18 +1481,28 @@ TclpGetUserHome(
 	wName = TclUtfToWCharDString(name, nameLen, &ds);
 	while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) {
 	    /*
-	     * user does not exists - if domain was not specified,
-	     * try again using current domain.
+	     * User does not exist; if domain was not specified, try again
+	     * using current domain.
 	     */
+
 	    rc = 1;
-	    if (domain != NULL) break;
-	    /* get current domain */
+	    if (domain != NULL) {
+		break;
+	    }
+
+	    /*
+	     * Get current domain
+	     */
+
 	    rc = NetGetDCName(NULL, NULL, (LPBYTE *) &wDomain);
-	    if (rc != 0) break;
+	    if (rc != 0) {
+		break;
+	    }
 	    domain = INT2PTR(-1); /* repeat once */
 	}
 	if (rc == 0) {
 	    DWORD i, size = MAX_PATH;
+
 	    wHomeDir = uiPtr->usri1_home_dir;
 	    if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
 		size = lstrlenW(wHomeDir);
@@ -1496,15 +1512,22 @@ TclpGetUserHome(
 		 * User exists but has no home dir. Return
 		 * "{GetProfilesDirectory}/<user>".
 		 */
+
 		GetProfilesDirectoryW(buf, &size);
 		TclWCharToUtfDString(buf, size-1, bufferPtr);
 		Tcl_DStringAppend(bufferPtr, "/", 1);
 		Tcl_DStringAppend(bufferPtr, name, nameLen);
 	    }
 	    result = Tcl_DStringValue(bufferPtr);
-	    /* be sure we return normalized path */
-	    for (i = 0; i < size; ++i){
-		if (result[i] == '\\') result[i] = '/';
+
+	    /*
+	     * Be sure we return normalized path
+	     */
+
+	    for (i = 0; i < size; ++i) {
+		if (result[i] == '\\') {
+		    result[i] = '/';
+		}
 	    }
 	    NetApiBufferFree((void *) uiPtr);
 	}
@@ -1592,48 +1615,72 @@ NativeAccess(
     /*
      * If it's not a directory (assume file), do several fast checks:
      */
+
     if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) {
 	/*
 	 * If the attributes say this is not writable at all.  The file is a
 	 * regular file (i.e., not a directory), then the file is not
-	 * writable, full stop.	 For directories, the read-only bit is
+	 * writable, full stop.  For directories, the read-only bit is
 	 * (mostly) ignored by Windows, so we can't ascertain anything about
 	 * directory access from the attrib data.  However, if we have the
-	 * advanced 'getFileSecurityProc', then more robust ACL checks
-	 * will be done below.
+	 * advanced 'getFileSecurityProc', then more robust ACL checks will be
+	 * done below.
 	 */
+
 	if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
 	    Tcl_SetErrno(EACCES);
 	    return -1;
 	}
 
-	/* If doesn't have the correct extension, it can't be executable */
+	/*
+	 * If doesn't have the correct extension, it can't be executable
+	 */
+
 	if ((mode & X_OK) && !NativeIsExec(nativePath)) {
 	    Tcl_SetErrno(EACCES);
 	    return -1;
 	}
-	/* Special case for read/write/executable check on file */
+
+	/*
+	 * Special case for read/write/executable check on file
+	 */
+
 	if ((mode & (R_OK|W_OK|X_OK)) && !(mode & ~(R_OK|W_OK|X_OK))) {
 	    DWORD mask = 0;
 	    HANDLE hFile;
-	    if (mode & R_OK) { mask |= GENERIC_READ;  }
-	    if (mode & W_OK) { mask |= GENERIC_WRITE; }
-	    if (mode & X_OK) { mask |= GENERIC_EXECUTE; }
+
+	    if (mode & R_OK) {
+		mask |= GENERIC_READ;
+	    }
+	    if (mode & W_OK) {
+		mask |= GENERIC_WRITE;
+	    }
+	    if (mode & X_OK) {
+		mask |= GENERIC_EXECUTE;
+	    }
 
 	    hFile = CreateFile(nativePath, mask,
-		FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL,
-		OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL);
+		    FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
+		    NULL, OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL);
 	    if (hFile != INVALID_HANDLE_VALUE) {
 		CloseHandle(hFile);
 		return 0;
 	    }
-	    /* fast exit if access was denied */
+
+	    /*
+	     * Fast exit if access was denied
+	     */
+
 	    if (GetLastError() == ERROR_ACCESS_DENIED) {
 		Tcl_SetErrno(EACCES);
 		return -1;
 	    }
 	}
-	/* We cannnot verify the access fast, check it below using security info. */
+
+	/*
+	 * We cannnot verify the access fast, check it below using security
+	 * info.
+	 */
     }
 
     /*
@@ -2008,13 +2055,12 @@ NativeStat(
      * 'getFileAttributesExProc', and if that isn't available, then on even
      * simpler routines.
      *
-     * Special consideration must be given to Windows hardcoded names
-     * like CON, NULL, COM1, LPT1 etc. For these, we still need to
-     * do the CreateFile as some may not exist (e.g. there is no CON
-     * in wish by default). However the subsequent GetFileInformationByHandle
-     * will fail. We do a WinIsReserved to see if it is one of the special
-     * names, and if successful, mock up a BY_HANDLE_FILE_INFORMATION
-     * structure.
+     * Special consideration must be given to Windows hardcoded names like
+     * CON, NULL, COM1, LPT1 etc. For these, we still need to do the
+     * CreateFile as some may not exist (e.g. there is no CON in wish by
+     * default). However the subsequent GetFileInformationByHandle will
+     * fail. We do a WinIsReserved to see if it is one of the special names,
+     * and if successful, mock up a BY_HANDLE_FILE_INFORMATION structure.
      */
 
     fileHandle = CreateFile(nativePath, GENERIC_READ,
@@ -2032,7 +2078,11 @@ NativeStat(
                 Tcl_SetErrno(ENOENT);
                 return -1;
             }
-            /* Mock up the expected structure */
+
+            /*
+	     * Mock up the expected structure
+	     */
+
             memset(&data, 0, sizeof(data));
             statPtr->st_atime = 0;
             statPtr->st_mtime = 0;
@@ -2315,7 +2365,7 @@ TclpGetNativeCwd(
     }
 
     if (clientData != NULL) {
-	if (wcscmp((const WCHAR*)clientData, buffer) == 0) {
+	if (wcscmp((const WCHAR *) clientData, buffer) == 0) {
 	    return clientData;
 	}
     }
@@ -2543,10 +2593,12 @@ TclpObjNormalizePath(
 				(int)(sizeof(WCHAR) * len));
 			lastValidPathEnd = currentPathEndPosition;
 		    } else if (nextCheckpoint == 0) {
-			/* Path starts with a drive designation
-			 * that's not actually on the system.
-			 * We still must normalize up past the
-			 * first separator.  [Bug 3603434] */
+			/*
+			 * Path starts with a drive designation that's not
+			 * actually on the system. We still must normalize up
+			 * past the first separator. [Bug 3603434]
+			 */
+
 			currentPathEndPosition++;
 		    }
 		}
@@ -2561,11 +2613,10 @@ TclpObjNormalizePath(
 	     */
 
 	    /*
-	     * Check for symlinks, except at last component of path (we
-	     * don't follow final symlinks). Also a drive (C:/) for
-	     * example, may sometimes have the reparse flag set for some
-	     * reason I don't understand. We therefore don't perform this
-	     * check for drives.
+	     * Check for symlinks, except at last component of path (we don't
+	     * follow final symlinks). Also a drive (C:/) for example, may
+	     * sometimes have the reparse flag set for some reason I don't
+	     * understand. We therefore don't perform this check for drives.
 	     */
 
 	    if (cur != 0 && !isDrive &&
@@ -2574,8 +2625,8 @@ TclpObjNormalizePath(
 
 		if (to != NULL) {
 		    /*
-		     * Read the reparse point ok. Now, reparse points need
-		     * not be normalized, otherwise we could use:
+		     * Read the reparse point ok. Now, reparse points need not
+		     * be normalized, otherwise we could use:
 		     *
 		     * Tcl_GetStringFromObj(to, &pathLen);
 		     * nextCheckpoint = pathLen;
@@ -2615,9 +2666,9 @@ TclpObjNormalizePath(
 
 #ifndef TclNORM_LONG_PATH
 	    /*
-	     * Now we convert the tail of the current path to its 'long
-	     * form', and append it to 'dsNorm' which holds the current
-	     * normalized path
+	     * Now we convert the tail of the current path to its 'long form',
+	     * and append it to 'dsNorm' which holds the current normalized
+	     * path
 	     */
 
 	    if (isDrive) {
@@ -2646,10 +2697,10 @@ TclpObjNormalizePath(
 		    int dotLen = currentPathEndPosition-lastValidPathEnd;
 
 		    /*
-		     * Path is just dots. We shouldn't really ever see a
-		     * path like that. However, to be nice we at least
-		     * don't mangle the path - we just add the dots as a
-		     * path segment and continue.
+		     * Path is just dots. We shouldn't really ever see a path
+		     * like that. However, to be nice we at least don't mangle
+		     * the path - we just add the dots as a path segment and
+		     * continue.
 		     */
 
 		    Tcl_DStringAppend(&dsNorm, ((const char *)nativePath)
@@ -2667,8 +2718,7 @@ TclpObjNormalizePath(
 		    handle = FindFirstFileW((WCHAR *) nativePath, &fData);
 		    if (handle == INVALID_HANDLE_VALUE) {
 			/*
-			 * This is usually the '/' in 'c:/' at end of
-			 * string.
+			 * This is usually the '/' in 'c:/' at end of string.
 			 */
 
 			Tcl_DStringAppend(&dsNorm, (const char *) L"/",
@@ -2698,8 +2748,8 @@ TclpObjNormalizePath(
 	    }
 
 	    /*
-	     * If we get here, we've got past one directory delimiter, so
-	     * we know it is no longer a drive.
+	     * If we get here, we've got past one directory delimiter, so we
+	     * know it is no longer a drive.
 	     */
 
 	    isDrive = 0;
@@ -2993,7 +3043,11 @@ TclNativeCreateNativeRep(
 	if (validPathPtr == NULL) {
 	    return NULL;
 	}
-	/* refCount of validPathPtr was already incremented in Tcl_FSGetTranslatedPath */
+
+	/*
+	 * refCount of validPathPtr was already incremented in
+	 * Tcl_FSGetTranslatedPath
+	 */
     } else {
 	/*
 	 * Make sure the normalized path is set.
@@ -3003,72 +3057,100 @@ TclNativeCreateNativeRep(
 	if (validPathPtr == NULL) {
 	    return NULL;
 	}
-	/* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl, so incr refCount here */
+
+	/*
+	 * validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl,
+	 * so incr refCount here
+	 */
+
 	Tcl_IncrRefCount(validPathPtr);
     }
 
     str = Tcl_GetStringFromObj(validPathPtr, &len);
 
-    if (strlen(str)!=(size_t)len) {
-	/* String contains NUL-bytes. This is invalid. */
+    if (strlen(str) != (size_t) len) {
+	/*
+	 * String contains NUL-bytes. This is invalid.
+	 */
+
 	goto done;
     }
-    /* For a reserved device, strip a possible postfix ':' */
+
+    /*
+     * For a reserved device, strip a possible postfix ':'
+     */
+
     len = WinIsReserved(str);
     if (len == 0) {
-	/* Let MultiByteToWideChar check for other invalid sequences, like
-	 * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames */
+	/*
+	 * Let MultiByteToWideChar check for other invalid sequences, like
+	 * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames
+	 */
+
 	len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0);
 	if (len==0) {
 	    goto done;
 	}
     }
-    /* Overallocate 6 chars, making some room for extended paths */
-    wp = nativePathPtr = ckalloc( (len+6) * sizeof(WCHAR) );
+
+    /*
+     * Overallocate 6 chars, making some room for extended paths
+     */
+
+    wp = nativePathPtr = ckalloc((len + 6) * sizeof(WCHAR));
     if (nativePathPtr==0) {
       goto done;
     }
-    MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, len+1);
+    MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr,
+	    len + 1);
+
     /*
-    ** If path starts with "//?/" or "\\?\" (extended path), translate
-    ** any slashes to backslashes but leave the '?' intact
-    */
-    if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/')
-	    && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) {
+     * If path starts with "//?/" or "\\?\" (extended path), translate any
+     * slashes to backslashes but leave the '?' intact
+     */
+
+    if ((str[0] == '\\' || str[0] == '/') && (str[1] == '\\' || str[1] == '/')
+	    && str[2] == '?' && (str[3] == '\\' || str[3] == '/')) {
 	wp[0] = wp[1] = wp[3] = '\\';
 	str += 4;
 	wp += 4;
     }
+
     /*
-    ** If there is no "\\?\" prefix but there is a drive or UNC
-    ** path prefix and the path is larger than MAX_PATH chars,
-    ** no Win32 API function can handle that unless it is
-    ** prefixed with the extended path prefix. See:
-    ** <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath>
-    **/
-    if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z'))
-	    && str[1]==':') {
-	if (wp==nativePathPtr && len>MAX_PATH && (str[2]=='\\' || str[2]=='/')) {
-	    memmove(wp+4, wp, len*sizeof(WCHAR));
-	    memcpy(wp, L"\\\\?\\", 4*sizeof(WCHAR));
+     * If there is no "\\?\" prefix but there is a drive or UNC path prefix
+     * and the path is larger than MAX_PATH chars, no Win32 API function can
+     * handle that unless it is prefixed with the extended path prefix. See:
+     * <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath>
+     */
+
+    if (((str[0] >= 'A' && str[0] <= 'Z') || (str[0] >= 'a' && str[0] <= 'z'))
+	    && str[1] == ':') {
+	if (wp == nativePathPtr && len > MAX_PATH
+		&& (str[2] == '\\' || str[2] == '/')) {
+	    memmove(wp + 4, wp, len * sizeof(WCHAR));
+	    memcpy(wp, L"\\\\?\\", 4 * sizeof(WCHAR));
 	    wp += 4;
 	}
+
 	/*
-	 ** If (remainder of) path starts with "<drive>:",
-	 ** leave the ':' intact.
+	 * If (remainder of) path starts with "<drive>:", leave the ':'
+	 * intact.
 	 */
+
 	wp += 2;
-    } else if (wp==nativePathPtr && len>MAX_PATH
-	    && (str[0]=='\\' || str[0]=='/')
-	    && (str[1]=='\\' || str[1]=='/') && str[2]!='?') {
-	memmove(wp+6, wp, len*sizeof(WCHAR));
-	memcpy(wp, L"\\\\?\\UNC", 7*sizeof(WCHAR));
+    } else if (wp == nativePathPtr && len > MAX_PATH
+	    && (str[0] == '\\' || str[0] == '/')
+	    && (str[1] == '\\' || str[1] == '/') && str[2] != '?') {
+	memmove(wp + 6, wp, len * sizeof(WCHAR));
+	memcpy(wp, L"\\\\?\\UNC", 7 * sizeof(WCHAR));
 	wp += 7;
     }
+
     /*
-    ** In the remainder of the path, translate invalid characters to
-    ** characters in the Unicode private use area.
-    */
+     * In the remainder of the path, translate invalid characters to
+     * characters in the Unicode private use area.
+     */
+
     while (*wp != '\0') {
 	if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) {
 	    *wp |= 0xF000;
@@ -3079,7 +3161,6 @@ TclNativeCreateNativeRep(
     }
 
   done:
-
     TclDecrRefCount(validPathPtr);
     return nativePathPtr;
 }
@@ -3205,21 +3286,28 @@ TclWinFileOwned(
     native = Tcl_FSGetNativePath(pathPtr);
 
     if (GetNamedSecurityInfo((LPTSTR) native, SE_FILE_OBJECT,
-                             OWNER_SECURITY_INFORMATION, &ownerSid,
-                             NULL, NULL, NULL, &secd) != ERROR_SUCCESS) {
-        /* Either not a file, or we do not have access to it in which
-           case we are in all likelihood not the owner */
+	    OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL,
+	    &secd) != ERROR_SUCCESS) {
+        /*
+	 * Either not a file, or we do not have access to it in which case we
+	 * are in all likelihood not the owner.
+	 */
+
         return 0;
     }
 
     /*
-     * Getting the current process SID is a multi-step process.
-     * We make the assumption that if a call fails, this process is
-     * so underprivileged it could not possibly own anything. Normally
-     * a process can *always* look up its own token.
+     * Getting the current process SID is a multi-step process.  We make the
+     * assumption that if a call fails, this process is so underprivileged it
+     * could not possibly own anything. Normally a process can *always* look
+     * up its own token.
      */
+
     if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) {
-        /* Find out how big the buffer needs to be */
+        /*
+	 * Find out how big the buffer needs to be.
+	 */
+
         bufsz = 0;
         GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
         if (bufsz) {
@@ -3231,15 +3319,20 @@ TclWinFileOwned(
         CloseHandle(token);
     }
 
-    /* Free allocations and be done */
-    if (secd)
+    /*
+     * Free allocations and be done.
+     */
+
+    if (secd) {
         LocalFree(secd);            /* Also frees ownerSid */
-    if (buf)
+    }
+    if (buf) {
         ckfree(buf);
+    }
 
     return (owned != 0);        /* Convert non-0 to 1 */
 }
-
+
 /*
  * Local Variables:
  * mode: c

win/tclWinPipe.c

@@ -124,8 +124,7 @@ typedef struct PipeInfo {
 				 * write. Set to 0 if no error has been
 				 * detected. This word is shared with the
 				 * writer thread so access must be
-				 * synchronized with the writable object.
-				 */
+				 * synchronized with the writable object. */
     char *writeBuf;		/* Current background output buffer. Access is
 				 * synchronized with the writable object. */
     int writeBufLen;		/* Size of write buffer. Access is
@@ -218,7 +217,7 @@ static const Tcl_ChannelType pipeChannelType = {
     NULL,			/* handler proc. */
     NULL,			/* wide seek proc */
     PipeThreadActionProc,	/* thread action proc */
-    NULL                       /* truncate */
+    NULL			/* truncate */
 };
 
 /*
@@ -1428,9 +1427,12 @@ ApplicationType(
 static const char *
 BuildCmdLineBypassBS(
     const char *current,
-    const char **bspos
-) {
-    /* mark first backslash possition */
+    const char **bspos)
+{
+    /*
+     * Mark first backslash position.
+     */
+
     if (!*bspos) {
 	*bspos = current;
     }
@@ -1445,14 +1447,14 @@ QuoteCmdLineBackslash(
     Tcl_DString *dsPtr,
     const char *start,
     const char *current,
-    const char *bspos
-) {
+    const char *bspos)
+{
     if (!bspos) {
-	if (current > start) { /* part before current (special) */
+	if (current > start) {	/* part before current (special) */
 	    Tcl_DStringAppend(dsPtr, start, (int) (current - start));
 	}
     } else {
-    	if (bspos > start) { /* part before first backslash */
+    	if (bspos > start) {	/* part before first backslash */
 	    Tcl_DStringAppend(dsPtr, start, (int) (bspos - start));
 	}
 	while (bspos++ < current) { /* each backslash twice */
@@ -1467,38 +1469,59 @@ QuoteCmdLinePart(
     const char *start,
     const char *special,
     const char *specMetaChars,
-    const char **bspos
-) {
+    const char **bspos)
+{
     if (!*bspos) {
-	/* rest before special (before quote) */
+	/*
+	 * Rest before special (before quote).
+	 */
+
 	QuoteCmdLineBackslash(dsPtr, start, special, NULL);
 	start = special;
     } else {
-	/* rest before first backslash and backslashes into new quoted block */
+	/*
+	 * Rest before first backslash and backslashes into new quoted block.
+	 */
+
 	QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
 	start = *bspos;
     }
+
     /*
-     * escape all special chars enclosed in quotes like `"..."`, note that here we
-     * don't must escape `\` (with `\`), because it's outside of the main quotes,
-     * so `\` remains `\`, but important - not at end of part, because results as
-     * before the quote,  so `%\%\` should be escaped as `"%\%"\\`).
+     * escape all special chars enclosed in quotes like `"..."`, note that
+     * here we don't must escape `\` (with `\`), because it's outside of the
+     * main quotes, so `\` remains `\`, but important - not at end of part,
+     * because results as before the quote, so `%\%\` should be escaped as
+     * `"%\%"\\`).
      */
+
     TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */
     do {
     	*bspos = NULL;
 	special++;
 	if (*special == '\\') {
-	    /* bypass backslashes (and mark first backslash possition)*/
+	    /*
+	     * Bypass backslashes (and mark first backslash position).
+	     */
+
 	    special = BuildCmdLineBypassBS(special, bspos);
-	    if (*special == '\0') break;
+	    if (*special == '\0') {
+		break;
+	    }
 	}
     } while (*special && strchr(specMetaChars, *special));
     if (!*bspos) {
-	/* unescaped rest before quote */
+	/*
+	 * Unescaped rest before quote.
+	 */
+
 	QuoteCmdLineBackslash(dsPtr, start, special, NULL);
     } else {
-	/* unescaped rest before first backslash (rather belongs to the main block) */
+	/*
+	 * Unescaped rest before first backslash (rather belongs to the main
+	 * block).
+	 */
+
 	QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
     }
     TclDStringAppendLiteral(dsPtr, "\""); /* closing escape quote-char */
@@ -1517,13 +1540,14 @@ BuildCommandLine(
     const char *arg, *start, *special, *bspos;
     int quote = 0, i;
     Tcl_DString ds;
-
-    /* characters to enclose in quotes if unpaired quote flag set */
     static const char specMetaChars[] = "&|^<>!()%";
-    /* character to enclose in quotes in any case (regardless unpaired-flag) */
+				/* Characters to enclose in quotes if unpaired
+				 * quote flag set. */
     static const char specMetaChars2[] = "%";
-
-    /* Quote flags:
+				/* Character to enclose in quotes in any case
+				 * (regardless of unpaired-flag). */
+    /*
+     * Quote flags:
      *   CL_ESCAPE   - escape argument;
      *   CL_QUOTE    - enclose in quotes;
      *   CL_UNPAIRED - previous arguments chain contains unpaired quote-char;
@@ -1555,30 +1579,31 @@ BuildCommandLine(
 	    quote = CL_QUOTE;
 	} else {
 	    for (start = arg;
-		*start != '\0' &&
-		    (quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE);
-		start++
-	    ) {
-		if (*start & 0x80) continue;
+		    *start != '\0' &&
+			(quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE);
+		    start++) {
+		if (*start & 0x80) {
+		    continue;
+		}
 		if (TclIsSpaceProc(*start)) {
-		    quote |= CL_QUOTE; /* quote only */
-		    if (bspos) { /* if backslash found - escape & quote */
+		    quote |= CL_QUOTE;	/* quote only */
+		    if (bspos) {	/* if backslash found, escape & quote */
 			quote |= CL_ESCAPE;
 			break;
 		    }
 		    continue;
 		}
 		if (strchr(specMetaChars, *start)) {
-		    quote |= (CL_ESCAPE|CL_QUOTE); /*escape & quote */
+		    quote |= (CL_ESCAPE|CL_QUOTE); /* escape & quote */
 		    break;
 		}
 		if (*start == '"') {
-		    quote |= CL_ESCAPE; /* escape only */
+		    quote |= CL_ESCAPE;		/* escape only */
 		    continue;
 		}
 		if (*start == '\\') {
 		    bspos = start;
-		    if (quote & CL_QUOTE) { /* if quote - escape & quote */
+		    if (quote & CL_QUOTE) {	/* if quote, escape & quote */
 			quote |= CL_ESCAPE;
 			break;
 		    }
@@ -1588,56 +1613,116 @@ BuildCommandLine(
 	    bspos = NULL;
 	}
 	if (quote & CL_QUOTE) {
-	    /* start of argument (main opening quote-char) */
+	    /*
+	     * Start of argument (main opening quote-char).
+	     */
+
 	    TclDStringAppendLiteral(&ds, "\"");
 	}
 	if (!(quote & CL_ESCAPE)) {
-	    /* nothing to escape */
+	    /*
+	     * Nothing to escape.
+	     */
+
 	    Tcl_DStringAppend(&ds, arg, -1);
 	} else {
 	    start = arg;
 	    for (special = arg; *special != '\0'; ) {
-		/* position of `\` is important before quote or at end (equal `\"` because quoted) */
+		/*
+		 * Position of `\` is important before quote or at end (equal
+		 * `\"` because quoted).
+		 */
+
 		if (*special == '\\') {
-		    /* bypass backslashes (and mark first backslash possition)*/
+		    /*
+		     * Bypass backslashes (and mark first backslash position)
+		     */
+
 		    special = BuildCmdLineBypassBS(special, &bspos);
-		    if (*special == '\0') break;
+		    if (*special == '\0') {
+			break;
+		    }
 		}
 		/* ["] */
 		if (*special == '"') {
-		    quote ^= CL_UNPAIRED; /* invert unpaired flag - observe unpaired quotes */
-		    /* add part before (and escape backslashes before quote) */
+		    /*
+		     * Invert the unpaired flag - observe unpaired quotes
+		     */
+
+		    quote ^= CL_UNPAIRED;
+
+		    /*
+		     * Add part before (and escape backslashes before quote).
+		     */
+
 		    QuoteCmdLineBackslash(&ds, start, special, bspos);
 		    bspos = NULL;
-		    /* escape using backslash */
+
+		    /*
+		     * Escape using backslash
+		     */
+
 		    TclDStringAppendLiteral(&ds, "\\\"");
 		    start = ++special;
 		    continue;
 		}
-		/* unpaired (escaped) quote causes special handling on meta-chars */
+
+		/*
+		 * Unpaired (escaped) quote causes special handling on
+		 * meta-chars
+		 */
+
 		if ((quote & CL_UNPAIRED) && strchr(specMetaChars, *special)) {
-		    special = QuoteCmdLinePart(&ds, start, special, specMetaChars, &bspos);
-		    /* start to current or first backslash */
+		    special = QuoteCmdLinePart(&ds, start, special,
+			    specMetaChars, &bspos);
+
+		    /*
+		     * Start to current or first backslash
+		     */
+
 		    start = !bspos ? special : bspos;
 		    continue;
 		}
-		/* special case for % - should be enclosed always (paired also) */
+
+		/*
+		 * Special case for % - should be enclosed always (paired
+		 * also)
+		 */
+
 		if (strchr(specMetaChars2, *special)) {
-		    special = QuoteCmdLinePart(&ds, start, special, specMetaChars2, &bspos);
-		    /* start to current or first backslash */
+		    special = QuoteCmdLinePart(&ds, start, special,
+			    specMetaChars2, &bspos);
+
+		    /*
+		     * Start to current or first backslash.
+		     */
+
 		    start = !bspos ? special : bspos;
 		    continue;
 		}
-		/* other not special (and not meta) character */
-		bspos = NULL; /* reset last backslash possition (not interesting) */
+
+		/*
+		 * Other not special (and not meta) character
+		 */
+
+		bspos = NULL;		/* reset last backslash position (not
+					 * interesting) */
 		special++;
 	    }
-	    /* rest of argument (and escape backslashes before closing main quote) */
+
+	    /*
+	     * Rest of argument (and escape backslashes before closing main
+	     * quote)
+	     */
+
 	    QuoteCmdLineBackslash(&ds, start, special,
-	    	(quote & CL_QUOTE) ? bspos : NULL);
+		    (quote & CL_QUOTE) ? bspos : NULL);
 	}
 	if (quote & CL_QUOTE) {
-	    /* end of argument (main closing quote-char) */
+	    /*
+	     * End of argument (main closing quote-char)
+	     */
+
 	    TclDStringAppendLiteral(&ds, "\"");
 	}
     }
@@ -2175,8 +2260,9 @@ PipeOutputProc(
     *errorCode = 0;
 
     /* avoid blocking if pipe-thread exited */
-    timeout = ((infoPtr->flags & PIPE_ASYNC) || !TclPipeThreadIsAlive(&infoPtr->writeTI)
-	|| TclInExit() || TclInThreadExit()) ? 0 : INFINITE;
+    timeout = ((infoPtr->flags & PIPE_ASYNC)
+	    || !TclPipeThreadIsAlive(&infoPtr->writeTI)
+	    || TclInExit() || TclInThreadExit()) ? 0 : INFINITE;
     if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
 	/*
 	 * The writer thread is blocked waiting for a write to complete and
@@ -2362,6 +2448,7 @@ PipeWatchProc(
     infoPtr->watchMask = mask & infoPtr->validMask;
     if (infoPtr->watchMask) {
 	Tcl_Time blockTime = { 0, 0 };
+
 	if (!oldMask) {
 	    infoPtr->nextPtr = tsdPtr->firstPipePtr;
 	    tsdPtr->firstPipePtr = infoPtr;
@@ -2831,7 +2918,7 @@ static DWORD WINAPI
 PipeReaderThread(
     LPVOID arg)
 {
-    TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg;
+    TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *) arg;
     PipeInfo *infoPtr = NULL; /* access info only after success init/wait */
     HANDLE handle = NULL;
     DWORD count, err;
@@ -2842,13 +2929,14 @@ PipeReaderThread(
 	 * Wait for the main thread to signal before attempting to wait on the
 	 * pipe becoming readable.
 	 */
+
 	if (!TclPipeThreadWaitForSignal(&pipeTI)) {
 	    /* exit */
 	    break;
 	}
 
 	if (!infoPtr) {
-	    infoPtr = (PipeInfo *)pipeTI->clientData;
+	    infoPtr = (PipeInfo *) pipeTI->clientData;
 	    handle = ((WinFile *) infoPtr->readFile)->handle;
 	}
 
@@ -3194,7 +3282,7 @@ TclPipeThreadCreateTI(
     pipeTI = malloc(sizeof(TclPipeThreadInfo));
 #else
     pipeTI = ckalloc(sizeof(TclPipeThreadInfo));
-#endif
+#endif /* !_PTI_USE_CKALLOC */
     pipeTI->evControl = CreateEvent(NULL, FALSE, FALSE, NULL);
     pipeTI->state = PTI_STATE_IDLE;
     pipeTI->clientData = clientData;
@@ -3233,40 +3321,64 @@ TclPipeThreadWaitForSignal(
     }
 
     wakeEvent = pipeTI->evWakeUp;
+
     /*
      * Wait for the main thread to signal before attempting to do the work.
      */
 
-    /* reset work state of thread (idle/waiting) */
-    if ((state = InterlockedCompareExchange(&pipeTI->state,
-	    PTI_STATE_IDLE, PTI_STATE_WORK)) & (PTI_STATE_STOP|PTI_STATE_END)) {
-	/* end of work, check the owner of structure */
+    /*
+     * Reset work state of thread (idle/waiting)
+     */
+
+    state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_IDLE,
+	    PTI_STATE_WORK);
+    if (state & (PTI_STATE_STOP|PTI_STATE_END)) {
+	/*
+	 * End of work, check the owner of structure.
+	 */
+
 	goto end;
     }
-    /* entering wait */
+
+    /*
+     * Entering wait
+     */
+
     waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE);
-
     if (waitResult != WAIT_OBJECT_0) {
-
 	/*
 	 * The control event was not signaled, so end of work (unexpected
 	 * behaviour, main thread can be dead?).
 	 */
+
 	goto end;
     }
 
-    /* try to set work state of thread */
-    if ((state = InterlockedCompareExchange(&pipeTI->state,
-	    PTI_STATE_WORK, PTI_STATE_IDLE)) & (PTI_STATE_STOP|PTI_STATE_END)) {
-	/* end of work */
+    /*
+     * Try to set work state of thread
+     */
+
+    state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_WORK,
+	    PTI_STATE_IDLE);
+    if (state & (PTI_STATE_STOP|PTI_STATE_END)) {
+	/*
+	 * End of work
+	 */
+
 	goto end;
     }
 
-    /* signaled to work */
+    /*
+     * Signaled to work.
+     */
+
     return 1;
 
-end:
-    /* end of work, check the owner of the TI structure */
+  end:
+    /*
+     * End of work, check the owner of the TI structure.
+     */
+
     if (state != PTI_STATE_STOP) {
 	*pipeTIPtr = NULL;
     } else {
@@ -3296,7 +3408,8 @@ end:
 
 int
 TclPipeThreadStopSignal(
-    TclPipeThreadInfo **pipeTIPtr, HANDLE wakeEvent)
+    TclPipeThreadInfo **pipeTIPtr,
+    HANDLE wakeEvent)
 {
     TclPipeThreadInfo *pipeTI = *pipeTIPtr;
     HANDLE evControl;
@@ -3307,28 +3420,27 @@ TclPipeThreadStopSignal(
     }
     evControl = pipeTI->evControl;
     pipeTI->evWakeUp = wakeEvent;
-    switch (
-	(state = InterlockedCompareExchange(&pipeTI->state,
-	    PTI_STATE_STOP, PTI_STATE_IDLE))
-    ) {
-
-	case PTI_STATE_IDLE:
-
-	    /* Thread was idle/waiting, notify it goes teardown */
-	    SetEvent(evControl);
-
-	    *pipeTIPtr = NULL;
-
-	case PTI_STATE_DOWN:
+    state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP,
+	    PTI_STATE_IDLE);
+    switch (state) {
+    case PTI_STATE_IDLE:
+	/*
+	 * Thread was idle/waiting, notify it goes teardown
+	 */
 
+	SetEvent(evControl);
+	*pipeTIPtr = NULL;
+    case PTI_STATE_DOWN:
 	return 1;
 
-	default:
-	    /*
-	     * Thread works currently, we should try to end it, own the TI structure
-	     * (because of possible sharing the joint structures with thread)
-	     */
-	    InterlockedExchange(&pipeTI->state, PTI_STATE_END);
+    default:
+	/*
+	 * Thread works currently, we should try to end it, own the TI
+	 * structure (because of possible sharing the joint structures with
+	 * thread)
+	 */
+
+	InterlockedExchange(&pipeTI->state, PTI_STATE_END);
 	break;
     }
 
@@ -3371,46 +3483,63 @@ TclPipeThreadStop(
     pipeTI = *pipeTIPtr;
     evControl = pipeTI->evControl;
     pipeTI->evWakeUp = NULL;
+
     /*
      * Try to sane stop the pipe worker, corresponding its current state
      */
-    switch (
-	(state = InterlockedCompareExchange(&pipeTI->state,
-	    PTI_STATE_STOP, PTI_STATE_IDLE))
-    ) {
 
-	case PTI_STATE_IDLE:
+    state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP,
+	    PTI_STATE_IDLE);
+    switch (state) {
+    case PTI_STATE_IDLE:
+	/*
+	 * Thread was idle/waiting, notify it goes teardown
+	 */
 
-	    /* Thread was idle/waiting, notify it goes teardown */
-	    SetEvent(evControl);
+	SetEvent(evControl);
 
-	    /* we don't need to wait for it at all, thread frees himself (owns the TI structure) */
-	    pipeTI = NULL;
+	/*
+	 * We don't need to wait for it at all, thread frees himself (owns the
+	 * TI structure)
+	 */
+
+	pipeTI = NULL;
 	break;
 
-	case PTI_STATE_STOP:
-	    /* already stopped, thread frees himself (owns the TI structure) */
-	    pipeTI = NULL;
-	break;
-	case PTI_STATE_DOWN:
-	    /* Thread already down (?), do nothing */
+    case PTI_STATE_STOP:
+	/*
+	 * Already stopped, thread frees himself (owns the TI structure)
+	 */
 
-	    /* we don't need to wait for it, but we should free pipeTI */
-	    hThread = NULL;
+	pipeTI = NULL;
+	break;
+    case PTI_STATE_DOWN:
+	/*
+	 * Thread already down (?), do nothing
+	 */
+
+	/*
+	 * We don't need to wait for it, but we should free pipeTI
+	 */
+	hThread = NULL;
 	break;
 
 	/* case PTI_STATE_WORK: */
-	default:
+    default:
+	/*
+	 * Thread works currently, we should try to end it, own the TI
+	 * structure (because of possible sharing the joint structures with
+	 * thread)
+	 */
+
+	state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_END,
+		PTI_STATE_WORK);
+	if (state == PTI_STATE_DOWN) {
 	    /*
-	     * Thread works currently, we should try to end it, own the TI structure
-	     * (because of possible sharing the joint structures with thread)
+	     * We don't need to wait for it, but we should free pipeTI
 	     */
-	    if ((state = InterlockedCompareExchange(&pipeTI->state,
-		    PTI_STATE_END, PTI_STATE_WORK)) == PTI_STATE_DOWN
-	    ) {
-		/* we don't need to wait for it, but we should free pipeTI */
-		hThread = NULL;
-	    };
+	    hThread = NULL;
+	}
 	break;
     }
 
@@ -3425,8 +3554,8 @@ TclPipeThreadStop(
 	GetExitCodeThread(hThread, &exitCode);
 
 	if (exitCode == STILL_ACTIVE) {
-
 	    int inExit = (TclInExit() || TclInThreadExit());
+
 	    /*
 	     * Set the stop event so that if the pipe thread is blocked
 	     * somewhere, it may hereafter sane exit cleanly.
@@ -3437,59 +3566,69 @@ TclPipeThreadStop(
 	    /*
 	     * Cancel all sync-IO of this thread (may be blocked there).
 	     */
+
 	    if (tclWinProcs.cancelSynchronousIo) {
 		tclWinProcs.cancelSynchronousIo(hThread);
 	    }
 
 	    /*
-	     * Wait at most 20 milliseconds for the reader thread to
-	     * close (regarding TIP#398-fast-exit).
+	     * Wait at most 20 milliseconds for the reader thread to close
+	     * (regarding TIP#398-fast-exit).
 	     */
 
-	    /* if we want TIP#398-fast-exit. */
-	    if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) {
+	    /*
+	     * If we want TIP#398-fast-exit.
+	     */
 
+	    if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) {
 		/*
-		 * The thread must be blocked waiting for the pipe to
-		 * become readable in ReadFile(). There isn't a clean way
-		 * to exit the thread from this condition. We should
-		 * terminate the child process instead to get the reader
-		 * thread to fall out of ReadFile with a FALSE. (below) is
-		 * not the correct way to do this, but will stay here
-		 * until a better solution is found.
+		 * The thread must be blocked waiting for the pipe to become
+		 * readable in ReadFile(). There isn't a clean way to exit the
+		 * thread from this condition. We should terminate the child
+		 * process instead to get the reader thread to fall out of
+		 * ReadFile with a FALSE. (below) is not the correct way to do
+		 * this, but will stay here until a better solution is found.
 		 *
-		 * Note that we need to guard against terminating the
-		 * thread while it is in the middle of Tcl_ThreadAlert
-		 * because it won't be able to release the notifier lock.
+		 * Note that we need to guard against terminating the thread
+		 * while it is in the middle of Tcl_ThreadAlert because it
+		 * won't be able to release the notifier lock.
 		 *
-		 * Also note that terminating threads during their initialization or teardown phase
-		 * may result in ntdll.dll's LoaderLock to remain locked indefinitely.
-		 * This causes ntdll.dll's LdrpInitializeThread() to deadlock trying to acquire LoaderLock.
-		 * LdrpInitializeThread() is executed within new threads to perform
-		 * initialization and to execute DllMain() of all loaded dlls.
-		 * As a result, all new threads are deadlocked in their initialization phase and never execute,
-		 * even though CreateThread() reports successful thread creation.
-		 * This results in a very weird process-wide behavior, which is extremely hard to debug.
+		 * Also note that terminating threads during their
+		 * initialization or teardown phase may result in ntdll.dll's
+		 * LoaderLock to remain locked indefinitely.  This causes
+		 * ntdll.dll's LdrpInitializeThread() to deadlock trying to
+		 * acquire LoaderLock.  LdrpInitializeThread() is executed
+		 * within new threads to perform initialization and to execute
+		 * DllMain() of all loaded dlls.  As a result, all new threads
+		 * are deadlocked in their initialization phase and never
+		 * execute, even though CreateThread() reports successful
+		 * thread creation.  This results in a very weird process-wide
+		 * behavior, which is extremely hard to debug.
 		 *
 		 * THREADS SHOULD NEVER BE TERMINATED. Period.
 		 *
-		 * But for now, check if thread is exiting, and if so, let it die peacefully.
+		 * But for now, check if thread is exiting, and if so, let it
+		 * die peacefully.
 		 *
-		 * Also don't terminate if in exit (otherwise deadlocked in ntdll.dll's).
+		 * Also don't terminate if in exit (otherwise deadlocked in
+		 * ntdll.dll's).
 		 */
 
-		if ( pipeTI->state != PTI_STATE_DOWN
-		  && WaitForSingleObject(hThread,
-			inExit ? 50 : 5000) != WAIT_OBJECT_0
-		) {
+		if (pipeTI->state != PTI_STATE_DOWN
+			&& WaitForSingleObject(hThread,
+				inExit ? 50 : 5000) != WAIT_OBJECT_0) {
 		    /* BUG: this leaks memory */
 		    if (inExit || !TerminateThread(hThread, 0)) {
-			/* in exit or terminate fails, just give thread a chance to exit */
+			/*
+			 * in exit or terminate fails, just give thread a
+			 * chance to exit
+			 */
+
 			if (InterlockedExchange(&pipeTI->state,
 				PTI_STATE_STOP) != PTI_STATE_DOWN) {
 			    pipeTI = NULL;
 			}
-		    };
+		    }
 		}
 	    }
 	}
@@ -3501,11 +3640,11 @@ TclPipeThreadStop(
 	    SetEvent(pipeTI->evWakeUp);
 	}
 	CloseHandle(pipeTI->evControl);
-#   ifndef _PTI_USE_CKALLOC
+#ifndef _PTI_USE_CKALLOC
 	free(pipeTI);
-#   else
+#else
 	ckfree(pipeTI);
-#   endif
+#endif /* !_PTI_USE_CKALLOC */
     }
 }
 
@@ -3534,28 +3673,30 @@ TclPipeThreadExit(
 {
     LONG state;
     TclPipeThreadInfo *pipeTI = *pipeTIPtr;
+
     /*
      * If state of thread was set to stop (exactly), we can sane free its info
      * structure, otherwise it is shared with main thread, so main thread will
      * own it.
      */
+
     if (!pipeTI) {
 	return;
     }
     *pipeTIPtr = NULL;
-    if ((state = InterlockedExchange(&pipeTI->state,
-	    PTI_STATE_DOWN)) == PTI_STATE_STOP) {
+    state = InterlockedExchange(&pipeTI->state, PTI_STATE_DOWN);
+    if (state == PTI_STATE_STOP) {
 	CloseHandle(pipeTI->evControl);
 	if (pipeTI->evWakeUp) {
 	    SetEvent(pipeTI->evWakeUp);
 	}
-#   ifndef _PTI_USE_CKALLOC
+#ifndef _PTI_USE_CKALLOC
 	free(pipeTI);
-#   else
+#else
 	ckfree(pipeTI);
 	/* be sure all subsystems used are finalized */
 	Tcl_FinalizeThread();
-#   endif
+#endif /* !_PTI_USE_CKALLOC */
     }
 }
 

win/tclWinSerial.c

@@ -43,6 +43,15 @@ TCL_DECLARE_MUTEX(serialMutex)
 #define SERIAL_EOF	(1<<2)	/* Serial has reached EOF. */
 #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;
@@ -1609,6 +1635,32 @@ SerialSetOptionProc(
     len = strlen(optionName);
     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) {
@@ -1998,6 +2051,27 @@ SerialGetOptionProc(
 	len = strlen(optionName);
     }
 
+    /*
+     * 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");
 }
 
 /*