Tcl Source Code

2017-06-23 (TIP 472) Support 0d as prefix of decimal numbers (iyer,griffin)

2017-08-31 (bug)[2a9465] http state 100 continue handling broken (oehlmann)

2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter)

--- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details

2018-03-12 (TIP 490) add oo support for msgcat => msgcat 1.7.0 (oehlmann)

2018-03-12 (TIP 499) custom locale preference list (oehlmann)
=> msgcat 1.7.0

This option implies \fB\-sorted\fR and cannot be used with either \fB\-all\fR
or \fB\-not\fR.
.VE 8.6
.SS "NESTED LIST OPTIONS"
.PP
These options are used to search lists of lists.  They may be used
with any other options.
.TP
\fB\-stride\0\fIstrideLength\fR
.
If this option is specified, the list is treated as consisting of
groups of \fIstrideLength\fR elements and the groups are searched by
either their first element or, if the \fB\-index\fR option is used,
by the element within each group given by the first index passed to
\fB\-index\fR (which is then ignored by \fB\-index\fR). The resulting
index always points to the first element in a group.
.PP
The list length must be an integer multiple of \fIstrideLength\fR, which
in turn must be at least 1. A \fIstrideLength\fR of 1 is the default and
indicates no grouping.
.TP
\fB\-index\fR\0\fIindexList\fR
.
This option is designed for use when searching within nested lists.
The \fIindexList\fR argument gives a path of indices (much as might be
used with the \fBlindex\fR or \fBlset\fR commands) within each element
to allow the location of the term being matched against.

.PP
It is also possible to search inside elements:
.PP
.CS
\fBlsearch\fR -index 1 -all -inline {{a abc} {b bcd} {c cde}} *bc*
      \fI\(-> {a abc} {b bcd}\fR
.CE
.PP
The same thing for a flattened list:
.PP
.CS
\fBlsearch\fR -stride 2 -index 1 -all -inline {a abc b bcd c cde} *bc*
      \fI\(-> {a abc b bcd}\fR
.CE
.SH "SEE ALSO"
foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n),
lset(n), lsort(n), lrange(n), lreplace(n),
string(n)
.SH KEYWORDS
binary search, linear search,
list, match, pattern, regular expression, search, string
'\" Local Variables:
'\" mode: nroff
'\" End:

'\"
'\" Copyright (c) 1998 Mark Harrison.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH "msgcat" n 1.5 msgcat "Tcl Bundled Packages"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
msgcat \- Tcl message catalog
.SH SYNOPSIS
\fBpackage require Tcl 8.7\fR
.sp
\fBpackage require msgcat 1.7\fR
.sp
\fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR?
.sp
\fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
.sp
.VS "TIP 412"
\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR
.VE "TIP 412"
.sp
.VS "TIP 490"
\fB::msgcat::mcpackagenamespaceget\fR
.VE "TIP 490"
.sp
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
.sp
.VS "TIP 499"
\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ...
.VE "TIP 499"
.sp
.VS "TIP 412"
\fB::msgcat::mcloadedlocales subcommand\fR ?\fIlocale\fR?
.VE "TIP 412"
.sp
\fB::msgcat::mcload \fIdirname\fR
.sp

.VS "TIP 412"
\fB::msgcat::mcpackagelocale subcommand\fR ?\fIlocale\fR?
.sp
\fB::msgcat::mcpackageconfig subcommand\fR \fIoption\fR ?\fIvalue\fR?
.sp
\fB::msgcat::mcforgetpackage\fR
.VE "TIP 412"
.sp
.VS "TIP 499"
\fB::msgcat::mcutil subcommand\fR ?\fIlocale\fR?
.VS "TIP 499"
.BE
.SH DESCRIPTION
.PP
The \fBmsgcat\fR package provides a set of functions
that can be used to manage multi-lingual user interfaces.
Text strings are defined in a
.QW "message catalog"

Each package has its own message catalog and configuration settings in \fBmsgcat\fR.
.PP
A \fIlocale\fR is a specification string describing a user language like \fBde_ch\fR for Swiss German.
In \fBmsgcat\fR, there is a global locale initialized by the system locale of the current system.
Each package may decide to use the global locale or to use a package specific locale.
.PP
The global locale may be changed on demand, for example by a user initiated language change or within a multi user application like a web server.
.PP
.VS tip490
Object oriented programming is supported by the use of a package namespace.
.VE tip490
.PP
.SH COMMANDS
.TP
\fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR?
.
Returns a translation of \fIsrc-string\fR according to the
current locale.  If additional arguments past \fIsrc-string\fR
are given, the \fBformat\fR command is used to substitute the

\fB::msgcat::mc\fR is the main function used to localize an
application.  Instead of using an English string directly, an
application can pass the English string through \fB::msgcat::mc\fR and
use the result.  If an application is written for a single language in
this fashion, then it is easy to add support for additional languages
later simply by defining new message catalog entries.
.RE
.VS "TIP 490"
.TP
\fB::msgcat::mcn \fInamespace\fR \fIsrc-string\fR ?\fIarg arg ...\fR?
.
Like \fB::msgcat::mc\fR, but with the message namespace specified as first argument.
.PP
.RS
\fBmcn\fR may be used for cases where the package namespace is not the namespace of the caller.
An example is shown within the description of the command \fB::msgcat::mcpackagenamespaceget\fR below.
.RE
.PP
.TP
\fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
.
Given several source strings, \fB::msgcat::mcmax\fR returns the length
of the longest translated string.  This is useful when designing
localized GUIs, which may require that all buttons, for example, be a
fixed width (which will be the width of the widest button).
.TP
.VS "TIP 412"
\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? ?\fB-namespace\fR \fInamespace\fR? \fIsrc-string\fR
.

Return true, if there is a translation for the given \fIsrc-string\fR.
.PP
.RS
The search may be limited by the option \fB\-exactnamespace\fR to only check the current namespace and not any parent namespaces.
.PP
It may also be limited by the option \fB\-exactlocale\fR to only check the first prefered locale (e.g. first element returned by \fB::msgcat::mcpreferences\fR if global locale is used).
.PP
.VE "TIP 412"
.VS "TIP 490"
An explicit package namespace may be specified by the option \fB-namespace\fR.
The namespace of the caller is used if not explicitly specified.
.RE
.PP
.VE "TIP 490"
.VS "TIP 490"
.TP
\fB::msgcat::mcpackagenamespaceget\fR
.
Return the package namespace of the caller.
This command handles all cases described in section \fBOBJECT ORIENTED PROGRAMMING\fR.
.PP
.RS
Example usage is a tooltip package, which saves the caller package namespace to update the translation each time the tooltip is shown:
.CS
proc ::tooltip::tooltip {widget message} {
    ...
    set messagenamespace [uplevel 1 {::msgcat::mcpackagenamespaceget}]
    ...
    bind $widget  [list ::tooltip::show $widget $messagenamespace $message]
}

proc ::tooltip::show {widget messagenamespace message} {
    ...
    set message [::msgcat::mcn $messagenamespace $message]
    ...
}
.CE
.RE
.PP
.VE "TIP 490"
.TP
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
.

If \fInewLocale\fR is omitted, the current locale is returned, otherwise the current locale
is set to \fInewLocale\fR.
.PP
.RS
If the new locale is set to \fInewLocale\fR, the corresponding preferences are calculated and set.
For example, if the current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR returns \fB{en_us_funky en_us en {}}\fR.
.PP
The same result may be acheved by \fB::msgcat::mcpreferences\fR {*}[\fB::msgcat::mcutil getpreferences\fR \fInewLocale\fR].
.PP
The current locale is always the first element of the list returned by \fBmcpreferences\fR.
.PP
msgcat stores and compares the locale in a
case-insensitive manner, and returns locales in lowercase.
The initial locale is determined by the locale specified in
the user's environment.  See \fBLOCALE SPECIFICATION\fR
below for a description of the locale string format.

.PP
.VS "TIP 412"
If the locale is set, the preference list of locales is evaluated.
Locales in this list are loaded now, if not jet loaded.
.VE "TIP 412"
.RE
.TP
\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ...
.
Without arguments, returns an ordered list of the locales preferred by
the user.
The list is ordered from most specific to least preference.
.PP
.VS "TIP 499"
.RS
A set of locale preferences may be given to set the list of locale preferences.
The current locale is also set, which is the first element of the locale preferences list.
.PP
Locale preferences are loaded now, if not jet loaded.
.PP
As an example, the user may prefer French or English text. This may be configured by:
.CS
::msgcat::mcpreferences fr en {}

.CE
.RE
.PP
.VS "TIP 499"
.TP
\fB::msgcat:mcloadedlocales subcommand\fR ?\fIlocale\fR?
.
This group of commands manage the list of loaded locales for packages not setting a package locale.
.PP
.RS
The subcommand \fBget\fR returns the list of currently loaded locales.

Note that this routine is only called if the concerned package did not set a package locale unknown command name.
.RE
.TP
\fB::msgcat::mcforgetpackage\fR
.
The calling package clears all its state within the \fBmsgcat\fR package including all settings and translations.
.VE "TIP 412"
.PP
.VS "TIP 499"
.TP
\fB::msgcat::mcutil getpreferences\fR \fIlocale\fR
.
Return the preferences list of the given locale as described in section \fBLOCALE SPECIFICATION\fR.
An example is the composition of a preference list for the bilingual region "Biel/Bienne" as a concatenation of swiss german and swiss french:
.CS
% concat [lrange [msgcat::mcutil getpreferences fr_CH] 0 end-1] [msgcat::mcutil getpreferences de_CH]
fr_ch fr de_ch de {}
.CE
.TP
\fB::msgcat::mcutil getsystemlocale\fR
.
The system locale is returned as described by the section \fBLOCALE SPECIFICATION\fR.
.VE "TIP 499"
.PP
.SH "LOCALE SPECIFICATION"
.PP
The locale is specified to \fBmsgcat\fR by a locale string
passed to \fB::msgcat::mclocale\fR.
The locale string consists of
a language code, an optional country code, and an optional

.PP
.CS
\fBmsgcat::mc\fR {Produced %1$d at %2$s} $num $city
# ... where that key is mapped to one of the
# human-oriented versions by \fBmsgcat::mcset\fR
.CE
.VS "TIP 412"
.SH "PACKAGE PRIVATE LOCALE"
.PP
A package using \fBmsgcat\fR may choose to use its own package private
locale and its own set of loaded locales, independent to the global
locale set by \fB::msgcat::mclocale\fR.
.PP
This allows a package to change its locale without causing any locales load or removal in other packages and not to invoke the global locale change callback (see below).
.PP

This command may cause the load of locales.
.RE
.TP
\fB::msgcat::mcpackagelocale get\fR
.
Return the package private locale or the global locale, if no package private locale is set.
.TP
\fB::msgcat::mcpackagelocale preferences\fR ?\fIlocale preference\fR? ...
.
With no parameters, return the package private preferences or the global preferences,
if no package private locale is set.
The package locale state (set or not) is not changed (in contrast to the command \fB::msgcat::mcpackagelocale set\fR).
.PP
.RS
.VS "TIP 499"
If a set of locale preferences is given, it is set as package locale preference list.
The package locale is set to the first element of the preference list.
A package locale is activated, if it was not set so far.
.PP
Locale preferences are loaded now for the package, if not jet loaded.
.VE "TIP 499"
.RE
.PP
.TP
\fB::msgcat::mcpackagelocale loaded\fR
.
Return the list of locales loaded for this package.
.TP
\fB::msgcat::mcpackagelocale isset\fR
.

.
Returns true, if the given locale is loaded for the package.
.TP
\fB::msgcat::mcpackagelocale clear\fR
.
Clear any loaded locales of the package not present in the package preferences.
.PP
.SH "CHANGING PACKAGE OPTIONS"
.PP
Each package using msgcat has a set of options within \fBmsgcat\fR.
The package options are described in the next sectionPackage options.
Each package option may be set or unset individually using the following ensemble:
.TP
\fB::msgcat::mcpackageconfig get\fR \fIoption\fR
.

The called procedure must return the formatted message which will finally be returned by msgcat::mc.
.PP
A generic unknown handler is used if set to the empty string. This consists in returning the key if no arguments are given. With given arguments, format is used to process the arguments.
.PP
See section \fBcallback invocation\fR below.
The appended arguments are identical to \fB::msgcat::mcunknown\fR.
.RE
.SH "Callback invocation"
A package may decide to register one or multiple callbacks, as described above.
.PP
Callbacks are invoked, if:
.PP
1. the callback command is set,
.PP
2. the command is not the empty string,
.PP
3. the registering namespace exists.
.PP
If a called routine fails with an error, the \fBbgerror\fR routine for the interpreter is invoked after command completion.
Only exception is the callback \fBunknowncmd\fR, where an error causes the invoking \fBmc\fR-command to fail with that error.
.PP
.VS tip490
.SH "OBJECT ORIENTED PROGRAMMING"
\fBmsgcat\fR supports packages implemented by object oriented programming.
Objects and classes should be defined within a package namespace.
.PP
There are 3 supported cases where package namespace sensitive commands of msgcat (\fBmc\fR, \fBmcexists\fR, \fBmcpackagelocale\fR, \fBmcforgetpackage\fR, \fBmcpackagenamespaceget\fR, \fBmcpackageconfig\fR, \fBmcset\fR and \fBmcmset\fR) may be called:
.PP
.TP
\fB1) In class definition script\fR
.
\fBmsgcat\fR command is called within a class definition script.
.CS
namespace eval ::N2 {
    mcload $dir/msgs
    oo::class create C1 {puts [mc Hi!]}
}
.CE
.PP
.TP
\fB2) method defined in a class\fR
.
\fBmsgcat\fR command is called from a method in an object and the method is defined in a class.
.CS
namespace eval ::N3Class {
    mcload $dir/msgs
    oo::class create C1
    oo::define C1 method m1 {
        puts [mc Hi!]
    }
}
.CE
.PP
.TP
\fB3) method defined in a classless object\fR
.
\fBmsgcat\fR command is called from a method of a classless object.
.CS
namespace eval ::N4 {
    mcload $dir/msgs
    oo::object create O1
    oo::objdefine O1 method m1 {} {
        puts [mc Hi!]
    }
}
.CE
.PP
.VE tip490
.SH EXAMPLES
Packages which display a GUI may update their widgets when the global locale changes.
To register to a callback, use:
.CS
namespace eval gui {
    msgcat::mcpackageconfig changecmd updateGUI

    proc updateGui args {

}
.CE
.VE "TIP 412"
.SH CREDITS
.PP
The message catalog code was developed by Mark Harrison.
.SH "SEE ALSO"
format(n), scan(n), namespace(n), package(n), oo::class(n), oo::object
.SH KEYWORDS
internationalization, i18n, localization, l10n, message, text, translation, class, object
.\" Local Variables:
.\" mode: nroff
.\" End:

    {"jump4",		ASSEM_JUMP4,	INST_JUMP4,		0,	0},
    {"jumpFalse",	ASSEM_JUMP,	INST_JUMP_FALSE1,	1,	0},
    {"jumpFalse4",	ASSEM_JUMP4,	INST_JUMP_FALSE4,	1,	0},
    {"jumpTable",	ASSEM_JUMPTABLE,INST_JUMP_TABLE,	1,	0},
    {"jumpTrue",	ASSEM_JUMP,	INST_JUMP_TRUE1,	1,	0},
    {"jumpTrue4",	ASSEM_JUMP4,	INST_JUMP_TRUE4,	1,	0},
    {"label",		ASSEM_LABEL,	0,			0,	0},

    {"lappend",		ASSEM_LVT,	(INST_LAPPEND_SCALAR1<<8
					 | INST_LAPPEND_SCALAR4),
								1,	1},
    {"lappendArray",	ASSEM_LVT,	(INST_LAPPEND_ARRAY1<<8
					 | INST_LAPPEND_ARRAY4),2,	1},
    {"lappendArrayStk", ASSEM_1BYTE,	INST_LAPPEND_ARRAY_STK,	3,	1},
    {"lappendList",	ASSEM_LVT4,	INST_LAPPEND_LIST,	1,	1},

    {"listNotIn",	ASSEM_1BYTE,	INST_LIST_NOT_IN,	2,	1},
    {"load",		ASSEM_LVT,	(INST_LOAD_SCALAR1 << 8
					 | INST_LOAD_SCALAR4),	0,	1},
    {"loadArray",	ASSEM_LVT,	(INST_LOAD_ARRAY1<<8
					 | INST_LOAD_ARRAY4),	1,	1},
    {"loadArrayStk",	ASSEM_1BYTE,	INST_LOAD_ARRAY_STK,	2,	1},
    {"loadStk",		ASSEM_1BYTE,	INST_LOAD_STK,		1,	1},

    {"lsetFlat",	ASSEM_LSET_FLAT,INST_LSET_FLAT,		INT_MIN,1},
    {"lsetList",	ASSEM_1BYTE,	INST_LSET_LIST,		3,	1},
    {"lshift",		ASSEM_1BYTE,	INST_LSHIFT,		2,	1},
    {"lt",		ASSEM_1BYTE,	INST_LT,		2,	1},
    {"mod",		ASSEM_1BYTE,	INST_MOD,		2,	1},
    {"mult",		ASSEM_1BYTE,	INST_MULT,		2,	1},
    {"neq",		ASSEM_1BYTE,	INST_NEQ,		2,	1},

    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    Tcl_Token* tokenPtr = *tokenPtrPtr;
				/* INOUT: Pointer to the next token in the
				 * source code */
    Tcl_Obj *value;
    int status;




    /* General operand validity check */
    if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &value) != TCL_OK) {
	return TCL_ERROR;
    }
     
    /* Convert to an integer, advance to the next token and return. */
    /*
     * NOTE: Indexing a list with an index before it yields the
     * same result as indexing after it, and might be more easily portable
     * when list size limits grow.
     */
    status = TclIndexEncode(interp, value,
	    TCL_INDEX_BEFORE,TCL_INDEX_BEFORE, result);


    Tcl_DecrRefCount(value);
    *tokenPtrPtr = TokenAfter(tokenPtr);
    return status;
}

/*
 *-----------------------------------------------------------------------------
 *

    TclInitDictCmd(interp);
    TclInitEncodingCmd(interp);
    TclInitFileCmd(interp);
    TclInitInfoCmd(interp);
    TclInitNamespaceCmd(interp);
    TclInitStringCmd(interp);
    TclInitPrefixCmd(interp);
    TclInitProcessCmd(interp);

    /*
     * Register "clock" subcommands. These *do* go through
     * Tcl_CreateObjCommand, since they aren't in the global namespace and
     * involve ensembles.
     */

    /*
     * If we are just starting to log an error, errorInfo is initialized from
     * the error message in the interpreter's result.
     */

    iPtr->flags |= ERR_LEGACY_COPY;
    if (iPtr->errorInfo == NULL) {
	iPtr->errorInfo = iPtr->objResultPtr;
	Tcl_IncrRefCount(iPtr->errorInfo);
	if (!iPtr->errorCode) {
	    Tcl_SetErrorCode(interp, "NONE", NULL);
	}
    }

    /*

    int isIncreasing;		/* Nonzero means sort in increasing order. */
    int sortMode;		/* The sort mode. One of SORTMODE_* values
				 * defined below. */
    Tcl_Obj *compareCmdPtr;	/* The Tcl comparison command when sortMode is
				 * SORTMODE_COMMAND. Pre-initialized to hold
				 * base of command. */
    int *indexv;		/* If the -index option was specified, this
				 * holds an encoding of the indexes contained
				 * in the list supplied as an argument to
				 * that option.
				 * NULL if no indexes supplied, and points to
				 * singleIndex field when only one
				 * supplied. */
    int indexc;			/* Number of indexes in indexv array. */
    int singleIndex;		/* Static space for common index case. */
    int unique;
    int numElements;

#define SORTMODE_ASCII		0
#define SORTMODE_INTEGER	1
#define SORTMODE_REAL		2
#define SORTMODE_COMMAND	3
#define SORTMODE_DICTIONARY	4
#define SORTMODE_ASCII_NC	8









/*
 * Forward declarations for procedures defined in this file:
 */

static int		DictionaryCompare(const char *left, const char *right);
static Tcl_NRPostProc	IfConditionCallback;
static int		InfoArgsCmd(ClientData dummy, Tcl_Interp *interp,

Tcl_LrangeObjCmd(
    ClientData notUsed,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    register Tcl_Obj *const objv[])
				/* Argument objects. */
{

    int listLen, first, last, result;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "list first last");
	return TCL_ERROR;
    }

    result = TclListObjLength(interp, objv[1], &listLen);
    if (result != TCL_OK) {
	return result;
    }

    result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1,
	    &first);
    if (result != TCL_OK) {
	return result;
    }




    result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1,
	    &last);
    if (result != TCL_OK) {
	return result;
    }





































    Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last));


    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LrepeatObjCmd --

    /*
     * Complain if the user asked for a start element that is greater than the
     * list length. This won't ever trigger for the "end-*" case as that will
     * be properly constrained by TclGetIntForIndex because we use listLen-1
     * (to allow for replacing the last elem).
     */

    if ((first >= listLen) && (listLen > 0)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"list doesn't contain element %s", TclGetString(objv[2])));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX",
		NULL);
	return TCL_ERROR;
    }
    if (last >= listLen) {

Tcl_LsearchObjCmd(
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument values. */
{
    const char *bytes, *patternBytes;
    int i, match, index, result=TCL_OK, listc, length, elemLen, bisect;
    int allocatedIndexVector = 0;
    int dataType, isIncreasing, lower, upper, start, groupSize, groupOffset;
    Tcl_WideInt patWide, objWide;
    int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
    double patDouble, objDouble;
    SortInfo sortInfo;
    Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
    SortStrCmpFn_t strCmpFn = TclUtfCmp;
    Tcl_RegExp regexp = NULL;
    static const char *const options[] = {
	"-all",	    "-ascii",   "-bisect", "-decreasing", "-dictionary",
	"-exact",   "-glob",    "-increasing", "-index",
	"-inline",  "-integer", "-nocase",     "-not",
	"-real",    "-regexp",  "-sorted",     "-start", "-stride",
	"-subindices", NULL
    };
    enum options {
	LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_BISECT, LSEARCH_DECREASING,
	LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING,
	LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE,
	LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED,
	LSEARCH_START, LSEARCH_STRIDE, LSEARCH_SUBINDICES
    };
    enum datatypes {
	ASCII, DICTIONARY, INTEGER, REAL
    };
    enum modes {
	EXACT, GLOB, REGEXP, SORTED
    };
    enum modes mode;

    mode = GLOB;
    dataType = ASCII;
    isIncreasing = 1;
    allMatches = 0;
    inlineReturn = 0;
    returnSubindices = 0;
    negatedMatch = 0;
    bisect = 0;
    listPtr = NULL;
    startPtr = NULL;
    groupSize = 1;
    groupOffset = 0;
    start = 0;
    noCase = 0;
    sortInfo.compareCmdPtr = NULL;
    sortInfo.isIncreasing = 1;
    sortInfo.sortMode = 0;
    sortInfo.interp = interp;
    sortInfo.resultCode = TCL_OK;
    sortInfo.indexv = NULL;
    sortInfo.indexc = 0;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list pattern");
	return TCL_ERROR;
    }

    for (i = 1; i < objc-2; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
		!= TCL_OK) {



	    result = TCL_ERROR;
	    goto done;
	}
	switch ((enum options) index) {
	case LSEARCH_ALL:		/* -all */
	    allMatches = 1;
	    break;

	    /*
	     * If there was a previous -start option, release its saved index
	     * because it will either be replaced or there will be an error.
	     */

	    if (startPtr != NULL) {
		Tcl_DecrRefCount(startPtr);
		startPtr = NULL;
	    }
	    if (i > objc-4) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"missing starting index", -1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	    i++;
	    if (objv[i] == objv[objc - 2]) {
		/*
		 * Take copy to prevent shimmering problems. Note that it does
		 * not matter if the index obj is also a component of the list
		 * being searched. We only need to copy where the list and the
		 * index are one-and-the-same.
		 */

		startPtr = Tcl_DuplicateObj(objv[i]);
	    } else {
		startPtr = objv[i];
	    }
	    Tcl_IncrRefCount(startPtr);
	    break;
	case LSEARCH_STRIDE:		/* -stride */
	    if (i > objc-4) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-stride\" option must be "
			"followed by stride length", -1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	    if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) {
		result = TCL_ERROR;
		goto done;
	    }
	    if (groupSize < 1) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"stride length must be at least 1", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
			"BADSTRIDE", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	    i++;
	    break;
	case LSEARCH_INDEX: {		/* -index */
	    Tcl_Obj **indices;
	    int j;

	    if (allocatedIndexVector) {
		TclStackFree(interp, sortInfo.indexv);
		allocatedIndexVector = 0;
	    }
	    if (i > objc-4) {



		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-index\" option must be followed by list index",
			-1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		result = TCL_ERROR;
		goto done;
	    }

	    /*
	     * Store the extracted indices for processing by sublist
	     * extraction. Note that we don't do this using objects because
	     * that has shimmering problems.
	     */

	    i++;
	    if (TclListObjGetElements(interp, objv[i],
		    &sortInfo.indexc, &indices) != TCL_OK) {



		result = TCL_ERROR;
		goto done;
	    }
	    switch (sortInfo.indexc) {
	    case 0:
		sortInfo.indexv = NULL;
		break;
	    case 1:
		sortInfo.indexv = &sortInfo.singleIndex;
		break;
	    default:
		sortInfo.indexv =
			TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
		allocatedIndexVector = 1; /* Cannot use indexc field, as it
					   * might be decreased by 1 later. */
	    }

	    /*
	     * Fill the array by parsing each index. We don't know whether
	     * their scale is sensible yet, but we at least perform the
	     * syntactic check here.
	     */

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		int encoded = 0;
		if (TclIndexEncode(interp, indices[j], TCL_INDEX_BEFORE,
			TCL_INDEX_AFTER, &encoded) != TCL_OK) {
		    result = TCL_ERROR;
		}
		if ((encoded == TCL_INDEX_BEFORE)
			|| (encoded == TCL_INDEX_AFTER)) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "index \"%s\" cannot select an element "
			    "from any list", Tcl_GetString(indices[j])));
		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
			    "OUTOFRANGE", NULL);
		    result = TCL_ERROR;
		}
		if (result == TCL_ERROR) {
		    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
			    "\n    (-index option item number %d)", j));

		    goto done;
		}
		sortInfo.indexv[j] = encoded;
	    }
	    break;
	}
	}
    }

    /*
     * Subindices only make sense if asked for with -index option set.
     */

    if (returnSubindices && sortInfo.indexc==0) {



	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"-subindices cannot be used without -index option", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
		"BAD_OPTION_MIX", NULL);
	result = TCL_ERROR;
	goto done;
    }

    if (bisect && (allMatches || negatedMatch)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"-bisect is not compatible with -all or -not", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
		"BAD_OPTION_MIX", NULL);
	result = TCL_ERROR;
	goto done;
    }

    if (mode == REGEXP) {
	/*
	 * We can shimmer regexp/list if listv[i] == pattern, so get the
	 * regexp rep before the list rep. First time round, omit the interp
	 * and hope that the compilation will succeed. If it fails, we'll

	     */

	    regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1],
		    TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0));
	}

	if (regexp == NULL) {



	    result = TCL_ERROR;
	    goto done;
	}
    }

    /*
     * Make sure the list argument is a list object and get its length and a
     * pointer to its array of element pointers.
     */

    result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv);
    if (result != TCL_OK) {
	goto done;
    }

    /*
     * Check for sanity when grouping elements of the overall list together
     * because of the -stride option. [TIP #351]
     */

    if (groupSize > 1) {
	if (listc % groupSize) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "list size must be a multiple of the stride length",
		    -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE",
		    NULL);
	    result = TCL_ERROR;
	    goto done;
	}
	if (sortInfo.indexc > 0) {
	    /*
	     * Use the first value in the list supplied to -index as the
	     * offset of the element within each group by which to sort.
	     */

	    groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
	    if (groupOffset < 0 || groupOffset >= groupSize) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"when used with \"-stride\", the leading \"-index\""
			" value must be within the group", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
			"BADINDEX", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	    if (sortInfo.indexc == 1) {
		sortInfo.indexc = 0;
		sortInfo.indexv = NULL;
	    } else {
		sortInfo.indexc--;

		for (i = 0; i < sortInfo.indexc; i++) {
		    sortInfo.indexv[i] = sortInfo.indexv[i+1];
		}
	    }
	}
    }

    /*
     * Get the user-specified start offset.
     */

    if (startPtr) {
	result = TclGetIntForIndexM(interp, startPtr, listc-1, &start);

	if (result != TCL_OK) {
	    goto done;
	}
	if (start < 0) {
	    start = 0;
	}

	/*
	 * If the search started past the end of the list, we just return a
	 * "did not match anything at all" result straight away. [Bug 1374778]
	 */

	if (start > listc-1) {



	    if (allMatches || inlineReturn) {
		Tcl_ResetResult(interp);
	    } else {
		Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
	    }
	    goto done;
	}

	/*
	 * If start points within a group, it points to the start of the group.
	 */

	if (groupSize > 1) {
	    start -= (start % groupSize);
	}
    }

    patObj = objv[objc - 1];
    patternBytes = NULL;
    if (mode == EXACT || mode == SORTED) {
	switch ((enum datatypes) dataType) {

	/*
	 * If the data is sorted, we can do a more intelligent search. Note
	 * that there is no point in being smart when -all was specified; in
	 * that case, we have to look at all items anyway, and there is no
	 * sense in doing this when the match sense is inverted.
	 */

	/* 
	 * With -stride, lower, upper and i are kept as multiples of groupSize.
	 */

	lower = start - groupSize;
	upper = listc;
	while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) {
	    i = (lower + upper)/2;
	    i -= i % groupSize;
	    if (sortInfo.indexc != 0) {
		itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
		if (sortInfo.resultCode != TCL_OK) {
		    result = sortInfo.resultCode;
		    goto done;
		}
	    } else {
		itemPtr = listv[i+groupOffset];
	    }
	    switch ((enum datatypes) dataType) {
	    case ASCII:
		bytes = TclGetString(itemPtr);
		match = strCmpFn(patternBytes, bytes);
		break;
	    case DICTIONARY:

	 *   - our matching sense is negated
	 *   - we're building a list of all matched items
	 */

	if (allMatches) {
	    listPtr = Tcl_NewListObj(0, NULL);
	}
	for (i = start; i < listc; i += groupSize) {
	    match = 0;
	    if (sortInfo.indexc != 0) {
		itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
		if (sortInfo.resultCode != TCL_OK) {
		    if (listPtr != NULL) {
			Tcl_DecrRefCount(listPtr);
		    }
		    result = sortInfo.resultCode;
		    goto done;
		}
	    } else {
		itemPtr = listv[i+groupOffset];
	    }

	    switch (mode) {
	    case SORTED:
	    case EXACT:
		switch ((enum datatypes) dataType) {
		case ASCII:

		break;
	    } else if (inlineReturn) {
		/*
		 * Note that these appends are not expected to fail.
		 */

		if (returnSubindices && (sortInfo.indexc != 0)) {
		    itemPtr = SelectObjFromSublist(listv[i+groupOffset],
			    &sortInfo);
		    Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
		} else if (groupSize > 1) {
		    Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0,
			    groupSize, &listv[i]);
		} else {
		    itemPtr = listv[i];

		    Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
		}
	    } else if (returnSubindices) {
		int j;

		itemPtr = Tcl_NewIntObj(i+groupOffset);
		for (j=0 ; j<sortInfo.indexc ; j++) {
		    Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj(
			    TclIndexDecode(sortInfo.indexv[j], listc)));
		}
		Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
	    } else {
		Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewIntObj(i));
	    }
	}
    }

    /*
     * Return everything or a single value.
     */

    if (allMatches) {
	Tcl_SetObjResult(interp, listPtr);
    } else if (!inlineReturn) {
	if (returnSubindices) {
	    int j;

	    itemPtr = Tcl_NewIntObj(index+groupOffset);
	    for (j=0 ; j<sortInfo.indexc ; j++) {
		Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj(
			TclIndexDecode(sortInfo.indexv[j], listc)));
	    }
	    Tcl_SetObjResult(interp, itemPtr);
	} else {
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(index));
	}
    } else if (index < 0) {
	/*
	 * Is this superfluous? The result should be a blank object by
	 * default...
	 */

	Tcl_SetObjResult(interp, Tcl_NewObj());
    } else {
	if (returnSubindices) {
	    Tcl_SetObjResult(interp, SelectObjFromSublist(listv[i+groupOffset],
		    &sortInfo));
	} else if (groupSize > 1) {
	    Tcl_SetObjResult(interp, Tcl_NewListObj(groupSize, &listv[index]));
	} else {
	    Tcl_SetObjResult(interp, listv[index]);
	}
    }
    result = TCL_OK;

    /*
     * Cleanup the index list array.
     */

  done:
    if (startPtr != NULL) {
	Tcl_DecrRefCount(startPtr);
    }
    if (allocatedIndexVector) {
	TclStackFree(interp, sortInfo.indexv);
    }
    return result;
}

/*
 *----------------------------------------------------------------------

	case LSORT_DICTIONARY:
	    sortInfo.sortMode = SORTMODE_DICTIONARY;
	    break;
	case LSORT_INCREASING:
	    sortInfo.isIncreasing = 1;
	    break;
	case LSORT_INDEX: {
	    int indexc;
	    Tcl_Obj **indexv;

	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-index\" option must be followed by list index",
			-1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);

	     * we do not store the converted values here because we do not
	     * know if this is the only -index option yet and so we can't
	     * allocate any space; that happens after the scan through all the
	     * options is done.
	     */

	    for (j=0 ; j<indexc ; j++) {
		int encoded = 0;
		int result = TclIndexEncode(interp, indexv[j],
			TCL_INDEX_BEFORE, TCL_INDEX_AFTER, &encoded);

		if ((result == TCL_OK) && ((encoded == TCL_INDEX_BEFORE)
			|| (encoded == TCL_INDEX_AFTER))) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "index \"%s\" cannot select an element "
			    "from any list", Tcl_GetString(indexv[j])));
		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
			    "OUTOFRANGE", NULL);
		    result = TCL_ERROR;
		}
		if (result == TCL_ERROR) {
		    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
			    "\n    (-index option item number %d)", j));
		    sortInfo.resultCode = TCL_ERROR;
		    goto done;
		}
	    }
	    indexPtr = objv[i+1];

	default:
	    sortInfo.indexv =
		    TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
	    allocatedIndexVector = 1;	/* Cannot use indexc field, as it
					 * might be decreased by 1 later. */
	}
	for (j=0 ; j<sortInfo.indexc ; j++) {
	    /* Prescreened values, no errors or out of range possible */
	    TclIndexEncode(NULL, indexv[j], 0, 0, &sortInfo.indexv[j]);
	}
    }

    listObj = objv[objc-1];

    if (sortInfo.sortMode == SORTMODE_COMMAND) {
	Tcl_Obj *newCommandPtr, *newObjPtr;

	length = length / groupSize;
	if (sortInfo.indexc > 0) {
	    /*
	     * Use the first value in the list supplied to -index as the
	     * offset of the element within each group by which to sort.
	     */

	    groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);



	    if (groupOffset < 0 || groupOffset >= groupSize) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"when used with \"-stride\", the leading \"-index\""
			" value must be within the group", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
			"BADINDEX", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done;
	    }
	    if (sortInfo.indexc == 1) {
		sortInfo.indexc = 0;
		sortInfo.indexv = NULL;
	    } else {
		sortInfo.indexc--;

		/*
		 * Do not shrink the actual memory block used; that doesn't
		 * work with TclStackAlloc-allocated memory. [Bug 2918962]
		 * 
		 * TODO: Consider a pointer increment to replace this
		 * array shift.
		 */

		for (i = 0; i < sortInfo.indexc; i++) {
		    sortInfo.indexv[i] = sortInfo.indexv[i+1];
		}
	    }
	}

	int listLen, index;
	Tcl_Obj *currentObj;

	if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) {
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}





	index = TclIndexDecode(infoPtr->indexv[i], listLen - 1);




	if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index,
		&currentObj) != TCL_OK) {
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}
	if (currentObj == NULL) {

static int
StringRplcCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{

    int first, last, length, end;

    if (objc < 4 || objc > 5) {
	Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?");
	return TCL_ERROR;
    }

    length = Tcl_GetCharLength(objv[1]);
    end = length - 1;

    if (TclGetIntForIndexM(interp, objv[2], end, &first) != 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,
     */
    if ((last < 0) ||		/* Range ends before start of string */
	    (first > end) ||	/* Range begins after end of string */
	    (last < first)) {	/* Range begins after it starts */

	/*
	 * BUT!!! when (end < 0) -- an empty original string -- we can
	 * have (first <= end < 0 <= last) and an empty string is permitted
	 * to be replaced.
	 */
	Tcl_SetObjResult(interp, objv[1]);
    } else {
	Tcl_Obj *resultPtr;




	if (first < 0) {
	    first = 0;
	}
	if (last > end) {
	    last = end;
	}





	resultPtr = TclStringReplace(interp, objv[1], first,
		last + 1 - first, (objc == 5) ? objv[4] : NULL,
		TCL_STRING_IN_PLACE);

	Tcl_SetObjResult(interp, resultPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------

	length2 = strlen(tclDefaultTrimSet);
    } else {
	Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
	return TCL_ERROR;
    }
    string1 = TclGetStringFromObj(objv[1], &length1);

    triml = TclTrim(string1, length1, string2, length2, &trimr);


    Tcl_SetObjResult(interp,
	    Tcl_NewStringObj(string1 + triml, length1 - triml - trimr));
    return TCL_OK;
}

/*

static void		CompileReturnInternal(CompileEnv *envPtr,
			    unsigned char op, int code, int level,
			    Tcl_Obj *returnOpts);
static int		IndexTailVarIfKnown(Tcl_Interp *interp,
			    Tcl_Token *varTokenPtr, CompileEnv *envPtr);



/*
 *----------------------------------------------------------------------
 *
 * TclGetIndexFromToken --
 *
 *	Parse a token to determine if an index value is known at
 *	compile time. 

 *
 * Returns:
 *	TCL_OK if parsing succeeded, and TCL_ERROR if it failed.
 *
 * Side effects:
 *	When TCL_OK is returned, the encoded index value is written
 *	to *index.
 *
 *----------------------------------------------------------------------
 */

int
TclGetIndexFromToken(
    Tcl_Token *tokenPtr,
    int before,
    int after,
    int *indexPtr)
{
    Tcl_Obj *tmpObj = Tcl_NewObj();
    int result = TCL_ERROR;

    if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {







	result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr);
    }






    Tcl_DecrRefCount(tmpObj);





    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileGlobalCmd --

    for (i=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) {
	localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);

	if (localIndex < 0) {
	    return TCL_ERROR;
	}

	/* TODO: Consider what value can pass through the
	 * IndexTailVarIfKnown() screen.  Full CompileWord()
	 * likely does not apply here.  Push known value instead. */
	CompileWord(envPtr, varTokenPtr, interp, i);
	TclEmitInstInt4(	INST_NSUPVAR, localIndex,	envPtr);
    }

    /*

    }

    /*
     * Generate code to leave the rest of the list on the stack.
     */

    TclEmitInstInt4(		INST_LIST_RANGE_IMM, idx,	envPtr);
    TclEmitInt4(			TCL_INDEX_END,		envPtr);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *

    valTokenPtr = TokenAfter(parsePtr->tokenPtr);
    if (numWords != 3) {
	goto emitComplexLindex;
    }

    idxTokenPtr = TokenAfter(valTokenPtr);
    if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_BEFORE,
	    &idx) == TCL_OK) {
	/*

	 * The idxTokenPtr parsed as a valid index value and was
	 * encoded as expected by INST_LIST_INDEX_IMM.
	 *
	 * NOTE: that we rely on indexing before a list producing the

	 * same result as indexing after a list.
	 */

	CompileWord(envPtr, valTokenPtr, interp, 1);
	TclEmitInstInt4(	INST_LIST_INDEX_IMM, idx,	envPtr);
	return TCL_OK;
    }

     * at this point. We use an [lrange ... 0 end] for this (instead of
     * [llength], as with literals) as we must drop any string representation
     * that might be hanging around.
     */

    if (concat && numWords == 2) {
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,	envPtr);
	TclEmitInt4(			TCL_INDEX_END,	envPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *

    int idx1, idx2;

    if (parsePtr->numWords != 4) {
	return TCL_ERROR;
    }
    listTokenPtr = TokenAfter(parsePtr->tokenPtr);







    tokenPtr = TokenAfter(listTokenPtr);
    if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
	    &idx1) != TCL_OK) {
	return TCL_ERROR;
    }
    /*
     * Token was an index value, and we treat all "first" indices
     * before the list same as the start of the list.
     */

    tokenPtr = TokenAfter(tokenPtr);
    if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
	    &idx2) != TCL_OK) {
	return TCL_ERROR;
    }
    /*
     * Token was an index value, and we treat all "last" indices
     * after the list same as the end of the list.
     */

    /*
     * Issue instructions. It's not safe to skip doing the LIST_RANGE, as
     * we've not proved that the 'list' argument is really a list. Not that it
     * is worth trying to do that given current knowledge.
     */

    /*
     * Parse the index. Will only compile if it is constant and not an
     * _integer_ less than zero (since we reserve negative indices here for
     * end-relative indexing) or an end-based index greater than 'end' itself.
     */

    tokenPtr = TokenAfter(listTokenPtr);

    /*
     * NOTE: This command treats all inserts at indices before the list
     * the same as inserts at the start of the list, and all inserts
     * after the list the same as inserts at the end of the list. We
     * make that transformation here so we can use the optimized bytecode
     * as much as possible.
     */
    if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_END,
	    &idx) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * There are four main cases. If there are no values to insert, this is
     * just a confirm-listiness check. If the index is '0', this is a prepend.
     * If the index is 'end' (== TCL_INDEX_END), this is an append. Otherwise,
     * this is a splice (== split, insert values as list, concat-3).
     */

    CompileWord(envPtr, listTokenPtr, interp, 1);
    if (parsePtr->numWords == 3) {
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);
	TclEmitInt4(			TCL_INDEX_END,		envPtr);
	return TCL_OK;
    }

    for (i=3 ; i<parsePtr->numWords ; i++) {
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, i);
    }
    TclEmitInstInt4(		INST_LIST, i-3,			envPtr);

    if (idx == TCL_INDEX_START) {
	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
    } else if (idx == TCL_INDEX_END) {
	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
    } else {
	/*
	 * Here we handle two ranges for idx. First when idx > 0, we
	 * want the first half of the split to end at index idx-1 and
	 * the second half to start at index idx.
	 * Second when idx < TCL_INDEX_END, indicating "end-N" indexing,
	 * we want the first half of the split to end at index end-N and
	 * the second half to start at index end-N+1. We accomplish this
	 * with a pre-adjustment of the end-N value.
	 * The root of this is that the commands [lrange] and [linsert]
	 * differ in their interpretation of the "end" index.
	 */

	if (idx < TCL_INDEX_END) {
	    idx++;
	}
	TclEmitInstInt4(	INST_OVER, 1,			envPtr);
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);
	TclEmitInt4(			idx-1,			envPtr);
	TclEmitInstInt4(	INST_REVERSE, 3,		envPtr);
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, idx,	envPtr);
	TclEmitInt4(			TCL_INDEX_END,		envPtr);
	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
    }

    return TCL_OK;
}


				 * command. */
    Command *cmdPtr,		/* Points to defintion of command being
				 * compiled. */
    CompileEnv *envPtr)		/* Holds the resulting instructions. */
{
    Tcl_Token *tokenPtr, *listTokenPtr;
    DefineLineInformation;	/* TIP #280 */

    int idx1, idx2, i, offset, offset2;
    int emptyPrefix=1, suffixStart = 0;

    if (parsePtr->numWords < 4) {
	return TCL_ERROR;
    }
    listTokenPtr = TokenAfter(parsePtr->tokenPtr);







    tokenPtr = TokenAfter(listTokenPtr);
    if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
	    &idx1) != TCL_OK) {
	return TCL_ERROR;
    }

    tokenPtr = TokenAfter(tokenPtr);
    if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
	    &idx2) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * idx1, idx2 are the conventional encoded forms of the tokens parsed


     * as all forms of index values.  Values of idx1 that come before the


     * list are treated the same as if they were the start of the list.
     * Values of idx2 that come after the list are treated the same as if
     * they were the end of the list.
     */

    if (idx1 == TCL_INDEX_AFTER) {
	/*



	 * [lreplace] treats idx1 value end+1 differently from end+2, etc.
	 * The operand encoding cannot distinguish them, so we must bail
	 * out to direct evaluation.
	 */


	return TCL_ERROR;
    }





    /*
     * General structure of the [lreplace] result is
     *		prefix replacement suffix
     * In a few cases we can predict various parts will be empty and
     * take advantage.
     *
     * The proper suffix begins with the greater of indices idx1 or
     * idx2 + 1. If we cannot tell at compile time which is greater,
     * we must defer to direct evaluation.
     */





    if (idx2 == TCL_INDEX_BEFORE) {


	suffixStart = idx1;


    } else if (idx2 == TCL_INDEX_END) {
	suffixStart = TCL_INDEX_AFTER;
    } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END))
	    || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) {
	suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1;

    } else {


	return TCL_ERROR;
    }





    /* All paths start with computing/pushing the original value. */
    CompileWord(envPtr, listTokenPtr, interp, 1);


    /*
     * Push all the replacement values next so any errors raised in
     * creating them get raised first.
     */
    if (parsePtr->numWords > 4) {
	/* Push the replacement arguments */
	tokenPtr = TokenAfter(tokenPtr);
	for (i=4 ; i<parsePtr->numWords ; i++) {
	    CompileWord(envPtr, tokenPtr, interp, i);
	    tokenPtr = TokenAfter(tokenPtr);
	}













	/* Make a list of them... */


	TclEmitInstInt4(	INST_LIST, i - 4,		envPtr);

	emptyPrefix = 0;


    }

     

    /*

     * [lreplace] raises an error when idx1 points after the list, but
     * only when the list is not empty. This is maximum stupidity.

     *
     * TODO: TIP this nonsense away!
     */
    if (idx1 >= TCL_INDEX_START) {
	if (emptyPrefix) {
	    TclEmitOpcode(	INST_DUP,			envPtr);
	} else {
	    TclEmitInstInt4(	INST_OVER, 1,			envPtr);
	}

	TclEmitOpcode(		INST_LIST_LENGTH,		envPtr);
	TclEmitOpcode(		INST_DUP,			envPtr);


	offset = CurrentOffset(envPtr);

	TclEmitInstInt1(	INST_JUMP_FALSE1, 0,		envPtr);








	/* List is not empty */


	TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewIntObj(idx1),
							NULL),	envPtr);
	TclEmitOpcode(		INST_GT,			envPtr);
	offset2 = CurrentOffset(envPtr);
	TclEmitInstInt1(	INST_JUMP_TRUE1, 0,		envPtr);




	/* Idx1 >= list length ===> raise an error */




	TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf(
		"list doesn't contain element %d", idx1), NULL), envPtr);
	CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0,
		Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}"));
	TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset,
		envPtr->codeStart + offset + 1);
	TclEmitOpcode(		INST_POP,			envPtr);
	TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2,
		envPtr->codeStart + offset2 + 1);

    }















    if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) {



























	/*
	 * This is a "no-op". Example: [lreplace {a b c} 2 0]
	 * We still do a list operation to get list-verification
	 * and canonicalization side effects.
	 */
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);
	TclEmitInt4(			TCL_INDEX_END,		envPtr);
	return TCL_OK;
    }

    if (idx1 != TCL_INDEX_START) {
	/* Prefix may not be empty; generate bytecode to push it */
	if (emptyPrefix) {
	    TclEmitOpcode(	INST_DUP,			envPtr);
	} else {
	    TclEmitInstInt4(	INST_OVER, 1,			envPtr);
	}
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);
	TclEmitInt4(			idx1 - 1,		envPtr);
	if (!emptyPrefix) {
	    TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
	    TclEmitOpcode(	INST_LIST_CONCAT,		envPtr);
	}

	emptyPrefix = 0;

    }











    if (!emptyPrefix) {
	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
    }

    if (suffixStart == TCL_INDEX_AFTER) {
	TclEmitOpcode(		INST_POP,			envPtr);

	if (emptyPrefix) {
	    PushStringLiteral(envPtr, "");

	}
    } else {
	/* Suffix may not be empty; generate bytecode to push it */
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, suffixStart, envPtr);
	TclEmitInt4(			TCL_INDEX_END,		envPtr);

	if (!emptyPrefix) {
	    TclEmitOpcode(	INST_LIST_CONCAT,		envPtr);



	}



    }




    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileLsetCmd --

	localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);

	if (localIndex < 0) {
	    return TCL_ERROR;
	}

	/* TODO: Consider what value can pass through the
	 * IndexTailVarIfKnown() screen.  Full CompileWord()
	 * likely does not apply here.  Push known value instead. */
	CompileWord(envPtr, varTokenPtr, interp, i);
	TclEmitInstInt4(	INST_VARIABLE, localIndex,	envPtr);

	if (i+1 < numWords) {
	    /*

#define LOAD(idx) \
    if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));}
#define STORE(idx) \
    if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));}
#define INVOKE(name) \
    TclEmitInvoke(envPtr,INST_##name)






















































/*
 *----------------------------------------------------------------------
 *
 * TclCompileSetCmd --
 *
 *	Procedure called to compile the "set" command.

    if (parsePtr->numWords != 4) {
	return TCL_ERROR;
    }
    stringTokenPtr = TokenAfter(parsePtr->tokenPtr);
    fromTokenPtr = TokenAfter(stringTokenPtr);
    toTokenPtr = TokenAfter(fromTokenPtr);

    /* Every path must push the string argument */
    CompileWord(envPtr, stringTokenPtr,			interp, 1);

    /*
     * Parse the two indices.
     */

    if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
	    &idx1) != TCL_OK) {
	goto nonConstantIndices;
    }
    /*
     * Token parsed as an index expression. We treat all indices before
     * the string the same as the start of the string.
     */

    if (idx1 == TCL_INDEX_AFTER) {
	/* [string range $s end+1 $last] must be empty string */
	OP(		POP);
	PUSH(		"");
	return TCL_OK;
    }

    if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
	    &idx2) != TCL_OK) {
	goto nonConstantIndices;
    }
    /*
     * 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_BEFORE) {
	/* [string range $s $first -1] must be empty string */
	OP(		POP);
	PUSH(		"");
	return TCL_OK;
    }

    /*
     * Push the operand onto the stack and then the substring operation.
     */


    OP44(		STR_RANGE_IMM, idx1, idx2);
    return TCL_OK;

    /*
     * Push the operands onto the stack and then the substring operation.
     */

  nonConstantIndices:

    CompileWord(envPtr, fromTokenPtr,			interp, 2);
    CompileWord(envPtr, toTokenPtr,			interp, 3);
    OP(			STR_RANGE);
    return TCL_OK;
}

int
TclCompileStringReplaceCmd(
    Tcl_Interp *interp,		/* Tcl interpreter for context. */
    Tcl_Parse *parsePtr,	/* Points to a parse structure for the
				 * command. */
    Command *cmdPtr,		/* Points to defintion of command being
				 * compiled. */
    CompileEnv *envPtr)		/* Holds the resulting instructions. */
{
    Tcl_Token *tokenPtr, *valueTokenPtr;
    DefineLineInformation;	/* TIP #280 */
    int first, last;

    if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
	return TCL_ERROR;
    }
 
    /* Bytecode to compute/push string argument being replaced */
    valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
    CompileWord(envPtr, valueTokenPtr, interp, 1);

    /*
     * Check for first index known and useful at compile time. 
     */
    tokenPtr = TokenAfter(valueTokenPtr);
    if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
	    &first) != TCL_OK) {
	goto genericReplace;
    }

    /*
     * Check for last index known and useful at compile time. 



     */
    tokenPtr = TokenAfter(tokenPtr);
    if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
	    &last) != TCL_OK) {
	goto genericReplace;
    }




    /* 
     * [string replace] is an odd bird.  For many arguments it is
     * a conventional substring replacer.  However it also goes out
     * of its way to become a no-op for many cases where it would be
     * replacing an empty substring.  Precisely, it is a no-op when
     *


     *		(last < first)		OR
     *		(last < 0)		OR
     *		(end < first)
     *
     * For some compile-time values we can detect these cases, and
     * compile direct to bytecode implementing the no-op.
     */

    if ((last == TCL_INDEX_BEFORE)		/* Know (last < 0) */
	    || (first == TCL_INDEX_AFTER)	/* Know (first > end) */

	/*




	 * Tricky to determine when runtime (last < first) can be
	 * certainly known based on the encoded values. Consider the
	 * cases...
	 *
	 * (first <= TCL_INDEX_END) &&
	 *	(last == TCL_INDEX_AFTER) => cannot tell REJECT
	 *	(last <= TCL_INDEX END) && (last < first) => ACCEPT
	 *	else => cannot tell REJECT
	 */
	    || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END)
		&& (last < first))		/* Know (last < first) */
	/*
	 * (first == TCL_INDEX_BEFORE) &&
	 *	(last == TCL_INDEX_AFTER) => (first < last) REJECT
	 *	(last <= TCL_INDEX_END) => cannot tell REJECT
	 *	else		=> (first < last) REJECT
	 *
	 * else [[first >= TCL_INDEX_START]] &&
	 *	(last == TCL_INDEX_AFTER) => cannot tell REJECT
	 *	(last <= TCL_INDEX_END) => cannot tell REJECT
	 *	else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT
	 */
	    || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START)
		&& (last < first))) {		/* Know (last < first) */
	if (parsePtr->numWords == 5) {
	    tokenPtr = TokenAfter(tokenPtr);
	    CompileWord(envPtr, tokenPtr, interp, 4);
	    OP(		POP);		/* Pop newString */
	}

	/* Original string argument now on TOS as result */


	return TCL_OK;
    }

    if (parsePtr->numWords == 5) {
    /*
     * When we have a string replacement, we have to take care about



     * not replacing empty substrings that [string replace] promises
     * not to replace



     *
     * The remaining index values might be suitable for conventional
     * string replacement, but only if they cannot possibly meet the
     * conditions described above at runtime. If there's a chance they
     * might, we would have to emit bytecode to check and at that point
     * we're paying more in bytecode execution time than would make
     * things worthwhile. Trouble is we are very limited in
     * how much we can detect that at compile time. After decoding,
     * we need, first:
     *
     *		(first <= end)
     *
     * The encoded indices (first <= TCL_INDEX END) and
     * (first == TCL_INDEX_BEFORE) always meets this condition, but
     * any other encoded first index has some list for which it fails.
     *
     * We also need, second:
     *
     *		(last >= 0)
     *
     * The encoded indices (last >= TCL_INDEX_START) and
     * (last == TCL_INDEX_AFTER) always meet this condition but any
     * other encoded last index has some list for which it fails.
     *
     * Finally we need, third:
     *
     *		(first <= last)
     * 
     * Considered in combination with the constraints we already have,
     * we see that we can proceed when (first == TCL_INDEX_BEFORE)
     * or (last == TCL_INDEX_AFTER). These also permit simplification
     * of the prefix|replace|suffix construction. The other constraints,
     * though, interfere with getting a guarantee that first <= last. 
     */

    if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) {
	/* empty prefix */
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, 4);
	OP4(		REVERSE, 2);
	if (last == TCL_INDEX_AFTER) {
	    OP(		POP);		/* Pop  original */
	} else {
	    OP44(	STR_RANGE_IMM, last + 1, TCL_INDEX_END);
	    OP1(	STR_CONCAT1, 2);
	}
	return TCL_OK;
    }











    if ((last == TCL_INDEX_AFTER) && (first <= TCL_INDEX_END)) {
	OP44(		STR_RANGE_IMM, 0, first-1);
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, 4);
	OP1(		STR_CONCAT1, 2);

	return TCL_OK;
    }

	/* FLOW THROUGH TO genericReplace */

    } else {
	/* 


	 * When we have no replacement string to worry about, we may

	 * have more luck, because the forbidden empty string replacements
	 * are harmless when they are replaced by another empty string.
	 */

	if ((first == TCL_INDEX_BEFORE) || (first == TCL_INDEX_START)) {
	    /* empty prefix - build suffix only */

	    if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) {
		/* empty suffix too => empty result */
		OP(	POP);		/* Pop  original */
		PUSH	(	"");
		return TCL_OK;
	    }
	    OP44(	STR_RANGE_IMM, last + 1, TCL_INDEX_END);
	    return TCL_OK;
	} else {
	    if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) {
		/* empty suffix - build prefix only */
		OP44(	STR_RANGE_IMM, 0, first-1);
		return TCL_OK;
	    }
	    OP(		DUP);
	    OP44(	STR_RANGE_IMM, 0, first-1);
	    OP4(	REVERSE, 2);
	    OP44(	STR_RANGE_IMM, last + 1, TCL_INDEX_END);
	    OP1(	STR_CONCAT1, 2);
	    return TCL_OK;
	}
    }

    genericReplace:

	tokenPtr = TokenAfter(valueTokenPtr);
	CompileWord(envPtr, tokenPtr, interp, 2);
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, 3);
	if (parsePtr->numWords == 5) {
	    tokenPtr = TokenAfter(tokenPtr);
	    CompileWord(envPtr, tokenPtr, interp, 4);
	} else {
	    PUSH(	"");
	}
	OP(		STR_REPLACE);
	return TCL_OK;

}

int
TclCompileStringTrimLCmd(
    Tcl_Interp *interp,		/* Used for error reporting. */
    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
				 * created by Tcl_ParseCommand. */

		    Tcl_ListObjAppendElement(NULL, funcList, literal);
		} else if (Tcl_GetBooleanFromObj(NULL,literal,&b) == TCL_OK) {
		    lexeme = BOOLEAN;
		} else {
		    Tcl_DecrRefCount(literal);
		    msg = Tcl_ObjPrintf("invalid bareword \"%.*s%s\"",
			    (scanned < limit) ? (int)scanned : (int)limit - 3, start,
			    (scanned < limit) ? "" : "...");
		    post = Tcl_ObjPrintf(
			    "should be \"$%.*s%s\" or \"{%.*s%s}\"",
			    (scanned < limit) ? (int)scanned : (int)limit - 3,
			    start, (scanned < limit) ? "" : "...",
			    (scanned < limit) ? (int)scanned : (int)limit - 3,
			    start, (scanned < limit) ? "" : "...");
		    Tcl_AppendPrintfToObj(post, " or \"%.*s%s(...)\" or ...",
			    (scanned < limit) ? (int)scanned : (int)limit - 3,
			    start, (scanned < limit) ? "" : "...");
		    errCode = "BAREWORD";
		    if (start[0] == '0') {
			const char *stop;
			TclParseNumber(NULL, NULL, NULL, start, scanned,
				&stop, TCL_PARSE_NO_WHITESPACE);

	Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"",
		((start - limit) < parsePtr->string) ? "" : "...",
		((start - limit) < parsePtr->string)
			? (int) (start - parsePtr->string) : (int)limit - 3,
		((start - limit) < parsePtr->string)
			? parsePtr->string : start - limit + 3,
		(scanned < limit) ? (int)scanned : (int)limit - 3, start,
		(scanned < limit) ? "" : "...", insertMark ? mark : "",
		(start + scanned + limit > parsePtr->end)
			? (int) (parsePtr->end - start) - (int)scanned : (int)limit-3,
		start + scanned,
		(start + scanned + limit > parsePtr->end) ? "" : "...");

	/*
	 * Next, append any postscript message.
	 */

    {"jumpTrue4",	  5,   -1,         1,	{OPERAND_OFFSET4}},
	/* Jump relative to (pc + op4) if stktop expr object is true */
    {"jumpFalse1",	  2,   -1,         1,	{OPERAND_OFFSET1}},
	/* Jump relative to (pc + op1) if stktop expr object is false */
    {"jumpFalse4",	  5,   -1,         1,	{OPERAND_OFFSET4}},
	/* Jump relative to (pc + op4) if stktop expr object is false */





    {"bitor",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Bitwise or:	push (stknext | stktop) */
    {"bitxor",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Bitwise xor	push (stknext ^ stktop) */
    {"bitand",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Bitwise and:	push (stknext & stktop) */
    {"eq",		  1,   -1,         0,	{OPERAND_NONE}},

	/* Unary plus:	push +stktop */
    {"uminus",		  1,   0,          0,	{OPERAND_NONE}},
	/* Unary minus:	push -stktop */
    {"bitnot",		  1,   0,          0,	{OPERAND_NONE}},
	/* Bitwise not:	push ~stktop */
    {"not",		  1,   0,          0,	{OPERAND_NONE}},
	/* Logical not:	push !stktop */




    {"tryCvtToNumeric",	  1,   0,          0,	{OPERAND_NONE}},
	/* Try converting stktop to first int then double if possible. */

    {"break",		  1,   0,          0,	{OPERAND_NONE}},
	/* Abort closest enclosing loop; if none, return TCL_BREAK code. */
    {"continue",	  1,   0,          0,	{OPERAND_NONE}},
	/* Skip to next iteration of closest enclosing loop; if none, return
	 * TCL_CONTINUE code. */








    {"beginCatch4",	  5,   0,          1,	{OPERAND_UINT4}},
	/* Record start of catch with the operand's exception index. Push the
	 * current stack depth onto a special catch stack. */
    {"endCatch",	  1,   0,          0,	{OPERAND_NONE}},
	/* End of last catch. Pop the bytecode interpreter's catch stack. */
    {"pushResult",	  1,   +1,         0,	{OPERAND_NONE}},
	/* Push the interpreter's object result onto the stack. */

	 * indicated by op4 to hold the iterator state. The local scalar
	 * should not refer to a named variable as the value is not wholly
	 * managed correctly.
	 * Stack:  ... dict => ... value key doneBool */
    {"dictNext",	  5,	+3,	   1,	{OPERAND_LVT4}},
	/* Get the next iteration from the iterator in op4's local scalar.
	 * Stack:  ... => ... value key doneBool */



    {"dictUpdateStart",   9,    0,	   2,	{OPERAND_LVT4, OPERAND_AUX4}},
	/* Create the variables (described in the aux data referred to by the
	 * second immediate argument) to mirror the state of the dictionary in
	 * the variable referred to by the first immediate argument. The list
	 * of keys (top of the stack, not popped) must be the same length as
	 * the list of variables.
	 * Stack:  ... keyList => ... keyList */

    int numBytes,		/* Number of bytes in source string. */
    const CmdFrame *invoker,	/* Location context invoking the bcc */
    int word)			/* Index of the word in that context getting
				 * compiled */
{
    Interp *iPtr = (Interp *) interp;

    assert(tclInstructionTable[LAST_INST_OPCODE].name == NULL);

    envPtr->iPtr = iPtr;
    envPtr->source = stringPtr;
    envPtr->numSrcBytes = numBytes;
    envPtr->procPtr = iPtr->compiledProcPtr;
    iPtr->compiledProcPtr = NULL;
    envPtr->numCommands = 0;

#endif /* TCL_COMPILE_STATS */
} ByteCode;

/*
 * Opcodes for the Tcl bytecode instructions. These must correspond to the
 * entries in the table of instruction descriptions, tclInstructionTable, in
 * tclCompile.c. Also, the order and number of the expression opcodes (e.g.,
 * INST_BITOR) must match the entries in the array operatorStrings in
 * tclExecute.c.
 */

enum TclInstruction {

    /* Opcodes 0 to 9 */
    INST_DONE = 0,
    INST_PUSH1,
    INST_PUSH4,
    INST_POP,
    INST_DUP,
    INST_STR_CONCAT1,
    INST_INVOKE_STK1,
    INST_INVOKE_STK4,
    INST_EVAL_STK,
    INST_EXPR_STK,

    /* Opcodes 10 to 23 */
    INST_LOAD_SCALAR1,
    INST_LOAD_SCALAR4,
    INST_LOAD_SCALAR_STK,
    INST_LOAD_ARRAY1,
    INST_LOAD_ARRAY4,
    INST_LOAD_ARRAY_STK,
    INST_LOAD_STK,
    INST_STORE_SCALAR1,
    INST_STORE_SCALAR4,
    INST_STORE_SCALAR_STK,
    INST_STORE_ARRAY1,
    INST_STORE_ARRAY4,
    INST_STORE_ARRAY_STK,
    INST_STORE_STK,

    /* Opcodes 24 to 33 */
    INST_INCR_SCALAR1,
    INST_INCR_SCALAR_STK,
    INST_INCR_ARRAY1,
    INST_INCR_ARRAY_STK,
    INST_INCR_STK,
    INST_INCR_SCALAR1_IMM,
    INST_INCR_SCALAR_STK_IMM,
    INST_INCR_ARRAY1_IMM,
    INST_INCR_ARRAY_STK_IMM,
    INST_INCR_STK_IMM,

    /* Opcodes 34 to 39 */
    INST_JUMP1,
    INST_JUMP4,
    INST_JUMP_TRUE1,
    INST_JUMP_TRUE4,
    INST_JUMP_FALSE1,
    INST_JUMP_FALSE4,

    /* Opcodes 42 to 64 */


    INST_BITOR,
    INST_BITXOR,
    INST_BITAND,
    INST_EQ,
    INST_NEQ,
    INST_LT,
    INST_GT,
    INST_LE,
    INST_GE,
    INST_LSHIFT,
    INST_RSHIFT,
    INST_ADD,
    INST_SUB,
    INST_MULT,
    INST_DIV,
    INST_MOD,
    INST_UPLUS,
    INST_UMINUS,
    INST_BITNOT,
    INST_LNOT,
    INST_TRY_CVT_TO_NUMERIC,

    /* Opcodes 65 to 66 */
    INST_BREAK,
    INST_CONTINUE,





    /* Opcodes 69 to 72 */
    INST_BEGIN_CATCH4,
    INST_END_CATCH,
    INST_PUSH_RESULT,
    INST_PUSH_RETURN_CODE,

    /* Opcodes 73 to 78 */
    INST_STR_EQ,
    INST_STR_NEQ,
    INST_STR_CMP,
    INST_STR_LEN,
    INST_STR_INDEX,
    INST_STR_MATCH,

    /* Opcodes 79 to 81 */
    INST_LIST,
    INST_LIST_INDEX,
    INST_LIST_LENGTH,

    /* Opcodes 82 to 87 */
    INST_APPEND_SCALAR1,
    INST_APPEND_SCALAR4,
    INST_APPEND_ARRAY1,
    INST_APPEND_ARRAY4,
    INST_APPEND_ARRAY_STK,
    INST_APPEND_STK,

    /* Opcodes 88 to 93 */
    INST_LAPPEND_SCALAR1,
    INST_LAPPEND_SCALAR4,
    INST_LAPPEND_ARRAY1,
    INST_LAPPEND_ARRAY4,
    INST_LAPPEND_ARRAY_STK,
    INST_LAPPEND_STK,

    /* TIP #22 - LINDEX operator with flat arg list */

    INST_LIST_INDEX_MULTI,

    /*
     * TIP #33 - 'lset' command. Code gen also required a Forth-like
     *	     OVER operation.
     */

    INST_OVER,
    INST_LSET_LIST,
    INST_LSET_FLAT,

    /* TIP#90 - 'return' command. */

    INST_RETURN_IMM,

    /* TIP#123 - exponentiation operator. */

    INST_EXPON,

    /* TIP #157 - {*}... (word expansion) language syntax support. */

    INST_EXPAND_START,
    INST_EXPAND_STKTOP,
    INST_INVOKE_EXPANDED,

    /*
     * TIP #57 - 'lassign' command. Code generation requires immediate
     *	     LINDEX and LRANGE operators.
     */

    INST_LIST_INDEX_IMM,
    INST_LIST_RANGE_IMM,

    INST_START_CMD,

    INST_LIST_IN,
    INST_LIST_NOT_IN,

    INST_PUSH_RETURN_OPTIONS,
    INST_RETURN_STK,

    /*
     * Dictionary (TIP#111) related commands.
     */

    INST_DICT_GET,
    INST_DICT_SET,
    INST_DICT_UNSET,
    INST_DICT_INCR_IMM,
    INST_DICT_APPEND,
    INST_DICT_LAPPEND,
    INST_DICT_FIRST,
    INST_DICT_NEXT,

    INST_DICT_UPDATE_START,
    INST_DICT_UPDATE_END,

    /*
     * Instruction to support jumps defined by tables (instead of the classic
     * [switch] technique of chained comparisons).
     */

    INST_JUMP_TABLE,

    /*
     * Instructions to support compilation of global, variable, upvar and
     * [namespace upvar].
     */

    INST_UPVAR,
    INST_NSUPVAR,
    INST_VARIABLE,

    /* Instruction to support compiling syntax error to bytecode */

    INST_SYNTAX,

    /* Instruction to reverse N items on top of stack */

    INST_REVERSE,

    /* regexp instruction */

    INST_REGEXP,

    /* For [info exists] compilation */
    INST_EXIST_SCALAR,
    INST_EXIST_ARRAY,
    INST_EXIST_ARRAY_STK,
    INST_EXIST_STK,

    /* For [subst] compilation */
    INST_NOP,
    INST_RETURN_CODE_BRANCH,

    /* For [unset] compilation */
    INST_UNSET_SCALAR,
    INST_UNSET_ARRAY,
    INST_UNSET_ARRAY_STK,
    INST_UNSET_STK,

    /* For [dict with], [dict exists], [dict create] and [dict merge] */
    INST_DICT_EXPAND,
    INST_DICT_RECOMBINE_STK,
    INST_DICT_RECOMBINE_IMM,
    INST_DICT_EXISTS,
    INST_DICT_VERIFY,

    /* For [string map] and [regsub] compilation */
    INST_STR_MAP,
    INST_STR_FIND,
    INST_STR_FIND_LAST,
    INST_STR_RANGE_IMM,
    INST_STR_RANGE,

    /* For operations to do with coroutines and other NRE-manipulators */
    INST_YIELD,
    INST_COROUTINE_NAME,
    INST_TAILCALL,

    /* For compilation of basic information operations */
    INST_NS_CURRENT,
    INST_INFO_LEVEL_NUM,
    INST_INFO_LEVEL_ARGS,
    INST_RESOLVE_COMMAND,

    /* For compilation relating to TclOO */
    INST_TCLOO_SELF,
    INST_TCLOO_CLASS,
    INST_TCLOO_NS,
    INST_TCLOO_IS_OBJECT,

    /* For compilation of [array] subcommands */
    INST_ARRAY_EXISTS_STK,
    INST_ARRAY_EXISTS_IMM,
    INST_ARRAY_MAKE_STK,
    INST_ARRAY_MAKE_IMM,

    INST_INVOKE_REPLACE,

    INST_LIST_CONCAT,

    INST_EXPAND_DROP,

    /* New foreach implementation */
    INST_FOREACH_START,
    INST_FOREACH_STEP,
    INST_FOREACH_END,
    INST_LMAP_COLLECT,

    /* For compilation of [string trim] and related */
    INST_STR_TRIM,
    INST_STR_TRIM_LEFT,
    INST_STR_TRIM_RIGHT,

    INST_CONCAT_STK,

    INST_STR_UPPER,
    INST_STR_LOWER,
    INST_STR_TITLE,
    INST_STR_REPLACE,

    INST_ORIGIN_COMMAND,

    INST_TCLOO_NEXT,
    INST_TCLOO_NEXT_CLASS,

    INST_YIELD_TO_INVOKE,

    INST_NUM_TYPE,
    INST_TRY_CVT_TO_BOOLEAN,
    INST_STR_CLASS,

    INST_LAPPEND_LIST,
    INST_LAPPEND_LIST_ARRAY,
    INST_LAPPEND_LIST_ARRAY_STK,
    INST_LAPPEND_LIST_STK,

    INST_CLOCK_READ,

    /* The last opcode */
    LAST_INST_OPCODE
};


/*
 * Table describing the Tcl bytecode instructions: their name (for displaying
 * code), total number of code bytes required (including operand bytes), and a
 * description of the type of each operand. These operand types include signed
 * and unsigned integers of length one and four bytes. The unsigned integers
 * are used for indexes or for, e.g., the count of objects to push in a "push"

MODULE_SCOPE int	TclFindCompiledLocal(const char *name, int nameChars,
			    int create, CompileEnv *envPtr);
MODULE_SCOPE int	TclFixupForwardJump(CompileEnv *envPtr,
			    JumpFixup *jumpFixupPtr, int jumpDist,
			    int distThreshold);
MODULE_SCOPE void	TclFreeCompileEnv(CompileEnv *envPtr);
MODULE_SCOPE void	TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE int	TclGetIndexFromToken(Tcl_Token *tokenPtr,
			    int before, int after, int *indexPtr);
MODULE_SCOPE ByteCode *	TclInitByteCode(CompileEnv *envPtr);
MODULE_SCOPE ByteCode *	TclInitByteCodeObj(Tcl_Obj *objPtr,
			    const Tcl_ObjType *typePtr, CompileEnv *envPtr);
MODULE_SCOPE void	TclInitCompileEnv(Tcl_Interp *interp,
			    CompileEnv *envPtr, const char *string,
			    int numBytes, const CmdFrame *invoker, int word);
MODULE_SCOPE void	TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr);

static void
UpdateStringOfInstName(
    Tcl_Obj *objPtr)
{
    size_t len, inst = (size_t)objPtr->internalRep.wideValue;
    char *s, buf[TCL_INTEGER_SPACE + 5];

    if (inst >= LAST_INST_OPCODE) {
        sprintf(buf, "inst_%" TCL_Z_MODIFIER "d", inst);
        s = buf;
    } else {
        s = (char *) tclInstructionTable[inst].name;
    }
    len = strlen(s);
    /* assert (len < UINT_MAX) */

 * expression opcodes (e.g., INST_LOR) in tclCompile.h.
 *
 * Does not include the string for INST_EXPON (and beyond), as that is
 * disjoint for backward-compatibility reasons.
 */

static const char *const operatorStrings[] = {
    "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
    "+", "-", "*", "/", "%", "+", "-", "~", "!"
};

/*
 * Mapping from Tcl result codes to strings; used for error and debugging
 * messages.
 */

	TRACE_APPEND(("OK\n"));
	NEXT_INST_V(2, cleanup, 0);

    errorInUnset:
	CACHE_STACK_INFO();
	TRACE_ERROR(interp);
	goto gotError;























    }

    /*
     *	   End of INST_UNSET instructions.
     * -----------------------------------------------------------------
     *	   Start of INST_ARRAY instructions.
     */

	    NEXT_INST_F(jumpOffset, 1, 0);
	} else {
	    TRACE_APPEND(("not found in table\n"));
	    NEXT_INST_F(5, 1, 0);
	}
    }













































    /*
     * -----------------------------------------------------------------
     *	   Start of general introspector instructions.
     */

    case INST_NS_CURRENT: {
	Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);

	 */

	if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
	    TRACE_ERROR(interp);
	    goto gotError;
	}



	/* Decode end-offset index values. */





	index = TclIndexDecode(opnd, objc - 1);

	pcAdjustment = 5;

    lindexFastPath:
	if (index >= 0 && index < objc) {
	    objResultPtr = objv[index];
	} else {
	    TclNewObj(objResultPtr);

	valuePtr = OBJ_AT_TOS;
	fromIdx = TclGetInt4AtPtr(pc+1);
	toIdx = TclGetInt4AtPtr(pc+5);
	TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1),
		TclGetInt4AtPtr(pc+5)));

	/*
	 * Get the length of the list, making sure that it really is a list
	 * in the process.
	 */

	if (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) {
	    TRACE_ERROR(interp);
	    goto gotError;
	}

	/*
	 * Skip a lot of work if we're about to throw the result away (common
	 * with uses of [lassign]).
	 */

#ifndef TCL_COMPILE_DEBUG
	if (*(pc+9) == INST_POP) {
	    NEXT_INST_F(10, 1, 0);
	}
#endif




	/* Every range of an empty list is an empty list */
	if (objc == 0) {



	    TRACE_APPEND(("\n"));
	    NEXT_INST_F(9, 0, 0);
	}







	/* Decode index value operands. */


	/* 
	assert ( toIdx != TCL_INDEX_AFTER);

	 *



	 * Extra safety for legacy bytecodes:
	 */
	if (toIdx == TCL_INDEX_AFTER) {


	    toIdx = TCL_INDEX_END;
	}



	if ((toIdx == TCL_INDEX_BEFORE) || (fromIdx == TCL_INDEX_AFTER)) {
	emptyList:

	    objResultPtr = Tcl_NewObj();
	    TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
	    NEXT_INST_F(9, 1, 1);
	}
	toIdx = TclIndexDecode(toIdx, objc - 1);
	if (toIdx < 0) {
	    goto emptyList;
	} else if (toIdx >= objc) {
	    toIdx = objc - 1;
	}

	assert ( toIdx >= 0 && toIdx < objc);
	/*
	assert ( fromIdx != TCL_INDEX_BEFORE );
	 *
	 * Extra safety for legacy bytecodes:
	 */
	if (fromIdx == TCL_INDEX_BEFORE) {
	    fromIdx = TCL_INDEX_START;
	}

	fromIdx = TclIndexDecode(fromIdx, objc - 1);

	objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx);

	TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
	NEXT_INST_F(9, 1, 1);

    case INST_LIST_IN:
    case INST_LIST_NOT_IN:	/* Basic list containment operators. */
	value2Ptr = OBJ_AT_TOS;

    case INST_STR_RANGE_IMM:
	valuePtr = OBJ_AT_TOS;
	fromIdx = TclGetInt4AtPtr(pc+1);
	toIdx = TclGetInt4AtPtr(pc+5);
	length = Tcl_GetCharLength(valuePtr);
	TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx));

	/* Every range of an empty value is an empty value */
	if (length == 0) {
	    TRACE_APPEND(("\n"));
	    NEXT_INST_F(9, 0, 0);
	}

	/* Decode index operands. */

	/*

	assert ( toIdx != TCL_INDEX_BEFORE );
	assert ( toIdx != TCL_INDEX_AFTER);
	 *
	 * Extra safety for legacy bytecodes:
	 */
	if (toIdx == TCL_INDEX_BEFORE) {
	    goto emptyRange;
	}
	if (toIdx == TCL_INDEX_AFTER) {


	    toIdx = TCL_INDEX_END;
	}



	toIdx = TclIndexDecode(toIdx, length - 1);
	if (toIdx < 0) {
	    goto emptyRange;
	} else if (toIdx >= length) {
	    toIdx = length - 1;
	}

	assert ( toIdx >= 0 && toIdx < length );

	/*
	assert ( fromIdx != TCL_INDEX_BEFORE );
	assert ( fromIdx != TCL_INDEX_AFTER);
	 *
	 * Extra safety for legacy bytecodes:
	 */
	if (fromIdx == TCL_INDEX_BEFORE) {
	    fromIdx = TCL_INDEX_START;
	}
	if (fromIdx == TCL_INDEX_AFTER) {
	    goto emptyRange;
	}

	fromIdx = TclIndexDecode(fromIdx, length - 1);
	if (fromIdx < 0) {
	    fromIdx = 0;
	}

	if (fromIdx <= toIdx) {
	    objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx);
	} else {
	emptyRange:
	    TclNewObj(objResultPtr);
	}
	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	NEXT_INST_F(9, 1, 1);

    {
	Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
	int length3, endIdx;
	Tcl_Obj *value3Ptr;

    case INST_STR_REPLACE:
	value3Ptr = POP_OBJECT();
	valuePtr = OBJ_AT_DEPTH(2);
	endIdx = Tcl_GetCharLength(valuePtr) - 1;
	TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr),
		O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr)));
	if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx,
		    &fromIdx) != TCL_OK
	    || TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx,
		    &toIdx) != TCL_OK) {
	    TclDecrRefCount(value3Ptr);
	    TRACE_ERROR(interp);
	    goto gotError;
	}
	TclDecrRefCount(OBJ_AT_TOS);
	(void) POP_OBJECT();
	TclDecrRefCount(OBJ_AT_TOS);
	(void) POP_OBJECT();



	if ((toIdx < 0) ||
		(fromIdx > endIdx) ||
		(toIdx < fromIdx)) {
	    TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
	    TclDecrRefCount(value3Ptr);
	    NEXT_INST_F(1, 0, 0);
	}

	if (fromIdx < 0) {
	    fromIdx = 0;
	}

	if (toIdx > endIdx) {
	    toIdx = endIdx;
	}

	if (fromIdx == 0 && toIdx == endIdx) {
	    TclDecrRefCount(OBJ_AT_TOS);
	    OBJ_AT_TOS = value3Ptr;
	    TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
	    NEXT_INST_F(1, 0, 0);
	}















	objResultPtr = TclStringReplace(interp, valuePtr, fromIdx,





















		toIdx - fromIdx + 1, value3Ptr, TCL_STRING_IN_PLACE);







































	if (objResultPtr == value3Ptr) {
	    /* See [Bug 82e7f67325] */
	    TclDecrRefCount(OBJ_AT_TOS);
	    OBJ_AT_TOS = value3Ptr;
	    TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
	    NEXT_INST_F(1, 0, 0);
	}

	trim1 = 0;
	goto createTrimmedString;
    case INST_STR_TRIM:
	valuePtr = OBJ_UNDER_TOS;	/* String */
	value2Ptr = OBJ_AT_TOS;		/* TrimSet */
	string2 = TclGetStringFromObj(value2Ptr, &length2);
	string1 = TclGetStringFromObj(valuePtr, &length);
	trim1 = TclTrim(string1, length, string2, length2, &trim2);





    createTrimmedString:
	/*
	 * Careful here; trim set often contains non-ASCII characters so we
	 * take care when printing. [Bug 971cb4f1db]
	 */

#ifdef TCL_COMPILE_DEBUG

	int type1, type2;
	Tcl_WideInt w1, w2, wResult;

    case INST_NUM_TYPE:
	if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
	    type1 = 0;
	} else if (type1 == TCL_NUMBER_WIDE) {
	    /* value is between LLONG_MIN and LLONG_MAX */
	    /* [string is integer] is -UINT_MAX to UINT_MAX range */
	    /* [string is wideinteger] is -ULLONG_MAX to ULLONG_MAX range */
	    int i;

	    if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) {
		type1 = TCL_NUMBER_LONG;
	    }
	} else if (type1 == TCL_NUMBER_BIG) {
	    /* value is an integer outside the LLONG_MIN to LLONG_MAX range */
	    /* [string is wideinteger] is -ULLONG_MAX to ULLONG_MAX range */
	    Tcl_WideInt w;

	    if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) {
		type1 = TCL_NUMBER_WIDE;
	    }
	}
	TclNewIntObj(objResultPtr, type1);

#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
		    goto gotError;
		} else if (w1 == 0) {
		    TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
		    objResultPtr = TCONST(0);
		    TRACE(("%s\n", O2S(objResultPtr)));
		    NEXT_INST_F(1, 2, 1);
		} else if (w2 > INT_MAX) {
		    /*
		     * Technically, we could hold the value (1 << (INT_MAX+1))
		     * in an mp_int, but since we're using mp_mul_2d() to do
		     * the work, and it takes only an int argument, that's a
		     * good place to draw the line.
		     */

	    case INST_DIV:
		if (w2 == 0) {
		    TRACE(("%s %s => DIVIDE BY ZERO\n",
			    O2S(valuePtr), O2S(value2Ptr)));
		    goto divideByZero;
		} else if ((w1 == LLONG_MIN) && (w2 == -1)) {
		    /*
		     * Can't represent (-LLONG_MIN) as a Tcl_WideInt.
		     */

		    goto overflow;
		}
		wResult = w1 / w2;

		/*
		 * Force Tcl's integer division rules.
		 * TODO: examine for logic simplification
		 */

		if (((wResult < 0) || ((wResult == 0) &&
			((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
			((wResult * w2) != w1)) {
		    wResult -= 1;
		}
		goto wideResultOfArithmetic;

	    case INST_MULT:
		if (((sizeof(Tcl_WideInt) >= 2*sizeof(int))
			&& (w1 <= INT_MAX) && (w1 >= INT_MIN)
			&& (w2 <= INT_MAX) && (w2 >= INT_MIN))
			|| ((sizeof(Tcl_WideInt) >= 2*sizeof(short))
			&& (w1 <= SHRT_MAX) && (w1 >= SHRT_MIN)
			&& (w2 <= SHRT_MAX) && (w2 >= SHRT_MIN))) {
		    wResult = w1 * w2;
		    goto wideResultOfArithmetic;
		}
	    }

	CACHE_STACK_INFO();
	*/
	result = TCL_CONTINUE;
	cleanup = 0;
	TRACE(("=> CONTINUE!\n"));
	goto processExceptionReturn;





































































































































































    {
	ForeachInfo *infoPtr;
	Tcl_Obj *listPtr, **elements, *tmpPtr;
	ForeachVarList *varListPtr;
	int numLists, listLen, numVars;
	int listTmpDepth;
	size_t iterNum, iterMax, iterTmp;

	     *
	     * BEWARE! Can't use Tcl_GetIntFromObj() here because that
	     * converts values in the (unsigned) range to their signed int
	     * counterparts, leading to incorrect results.
	     */

	    if ((type2 != TCL_NUMBER_WIDE)
		    || (*((const Tcl_WideInt *)ptr2) > INT_MAX)) {
		/*
		 * Technically, we could hold the value (1 << (INT_MAX+1)) in
		 * an mp_int, but since we're using mp_mul_2d() to do the
		 * work, and it takes only an int argument, that's a good
		 * place to draw the line.
		 */

	     *	  expr 20000000000000003 < 20000000000000004.0
	     * right. Converting the first argument to double will yield two
	     * double values that are equivalent within double precision.
	     * Converting the double to an integer gets done exactly, then
	     * integer comparison can tell the difference.
	     */

	    if (d2 < (double)LLONG_MIN) {
		return MP_GT;
	    }
	    if (d2 > (double)LLONG_MAX) {
		return MP_LT;
	    }
	    w2 = (Tcl_WideInt) d2;
	    goto wideCompare;
	case TCL_NUMBER_BIG:
	    Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
	    if (mp_isneg(&big2)) {

	    w1 = (Tcl_WideInt) d1;
	    goto wideCompare;
	case TCL_NUMBER_BIG:
	    if (TclIsInfinite(d1)) {
		return (d1 > 0.0) ? MP_GT : MP_LT;
	    }
	    Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
	    if ((d1 < (double)LLONG_MAX) && (d1 > (double)LLONG_MIN)) {
		if (mp_isneg(&big2)) {
		    compare = MP_GT;
		} else {
		    compare = MP_LT;
		}
		mp_clear(&big2);
		return compare;

	case TCL_NUMBER_DOUBLE:
	    d2 = *((const double *)ptr2);
	    if (TclIsInfinite(d2)) {
		compare = (d2 > 0.0) ? MP_LT : MP_GT;
		mp_clear(&big1);
		return compare;
	    }
	    if ((d2 < (double)LLONG_MAX) && (d2 > (double)LLONG_MIN)) {
		compare = mp_cmp_d(&big1, 0);
		mp_clear(&big1);
		return compare;
	    }
	    if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
		    && modf(d2, &tmp) != 0.0) {
		d1 = TclBignumToDouble(&big1);

	    (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
	    (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),
	    (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)),
	    codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
    if (procPtr != NULL) {
	fprintf(stdout,
		"  Proc 0x%p, refCt %zd, args %d, compiled locals %d\n",
		procPtr, procPtr->refCount, procPtr->numArgs,
		procPtr->numCompiledLocals);
    }
}
#endif /* TCL_COMPILE_DEBUG */

/*

    unsigned char opCode = *pc;

    if (((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) {
	fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n",
		pc);
	Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc");
    }
    if ((unsigned) opCode >= LAST_INST_OPCODE) {
	fprintf(stderr, "\nBad opcode %d at pc %u in TclNRExecuteByteCode\n",
		(unsigned) opCode, relativePc);
	Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
    }
    if (checkStack &&
	    ((stackTop < 0) || (stackTop > stackUpperBound))) {
	int numChars;

    int type;
    const unsigned char opcode = *pc;
    const char *description, *operator = "unknown";

    if (opcode == INST_EXPON) {
	operator = "**";
    } else if (opcode <= INST_LNOT) {
	operator = operatorStrings[opcode - INST_BITOR];
    }

    if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
	description = "non-numeric string";
    } else if (type == TCL_NUMBER_NAN) {
	description = "non-numeric floating-point value";
    } else if (type == TCL_NUMBER_DOUBLE) {

    }

    /*
     * Instruction counts.
     */

    Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n");
    for (i = 0;  i < LAST_INST_OPCODE;  i++) {
	Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ",
		tclInstructionTable[i].name, statsPtr->instructionCount[i]);
	if (statsPtr->instructionCount[i]) {
	    Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n",
		    Percent(statsPtr->instructionCount[i], numInstructions));
	} else {
	    Tcl_AppendPrintfToObj(objPtr, "0\n");

void
Tcl_SetStdChannel(
    Tcl_Channel channel,
    int type)			/* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    int init = channel ? 1 : -1;
    switch (type) {
    case TCL_STDIN:
	tsdPtr->stdinInitialized = init;
	tsdPtr->stdinChannel = channel;
	break;
    case TCL_STDOUT:
	tsdPtr->stdoutInitialized = init;
	tsdPtr->stdoutChannel = channel;
	break;
    case TCL_STDERR:
	tsdPtr->stderrInitialized = init;
	tsdPtr->stderrChannel = channel;
	break;
    }
}

/*
 *----------------------------------------------------------------------

     * If the channels were not created yet, create them now and store them in
     * the static variables.
     */

    switch (type) {
    case TCL_STDIN:
	if (!tsdPtr->stdinInitialized) {
	    tsdPtr->stdinInitialized = -1;
	    tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN);


	    /*
	     * Artificially bump the refcount to ensure that the channel is
	     * only closed on exit.
	     *
	     * NOTE: Must only do this if stdinChannel is not NULL. It can be
	     * NULL in situations where Tcl is unable to connect to the
	     * standard input.
	     */

	    if (tsdPtr->stdinChannel != NULL) {
		tsdPtr->stdinInitialized = 1;
		Tcl_RegisterChannel(NULL, tsdPtr->stdinChannel);
	    }
	}
	channel = tsdPtr->stdinChannel;
	break;
    case TCL_STDOUT:
	if (!tsdPtr->stdoutInitialized) {
	    tsdPtr->stdoutInitialized = -1;
	    tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT);

	    if (tsdPtr->stdoutChannel != NULL) {
		tsdPtr->stdoutInitialized = 1;
		Tcl_RegisterChannel(NULL, tsdPtr->stdoutChannel);
	    }
	}
	channel = tsdPtr->stdoutChannel;
	break;
    case TCL_STDERR:
	if (!tsdPtr->stderrInitialized) {
	    tsdPtr->stderrInitialized = -1;
	    tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR);

	    if (tsdPtr->stderrChannel != NULL) {
		tsdPtr->stderrInitialized = 1;
		Tcl_RegisterChannel(NULL, tsdPtr->stderrChannel);
	    }
	}
	channel = tsdPtr->stderrChannel;
	break;
    }
    return channel;

static void
CheckForStdChannelsBeingClosed(
    Tcl_Channel chan)
{
    ChannelState *statePtr = ((Channel *) chan)->state;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->stdinInitialized == 1
	    && tsdPtr->stdinChannel != NULL
	    && statePtr == ((Channel *)tsdPtr->stdinChannel)->state) {
	if (statePtr->refCount < 2) {
	    statePtr->refCount = 0;
	    tsdPtr->stdinChannel = NULL;
	    return;
	}
    } else if (tsdPtr->stdoutInitialized == 1
	    && tsdPtr->stdoutChannel != NULL
	    && statePtr == ((Channel *)tsdPtr->stdoutChannel)->state) {
	if (statePtr->refCount < 2) {
	    statePtr->refCount = 0;
	    tsdPtr->stdoutChannel = NULL;
	    return;
	}
    } else if (tsdPtr->stderrInitialized == 1
	    && tsdPtr->stderrChannel != NULL
	    && statePtr == ((Channel *)tsdPtr->stderrChannel)->state) {
	if (statePtr->refCount < 2) {
	    statePtr->refCount = 0;
	    tsdPtr->stderrChannel = NULL;
	    return;
	}

			    Tcl_Obj *listPtr, Tcl_Obj *argPtr);
MODULE_SCOPE Tcl_Obj *	TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    int indexCount, Tcl_Obj *const indexArray[]);
/* TIP #280 */
MODULE_SCOPE void	TclListLines(Tcl_Obj *listObj, int line, int n,
			    int *lines, Tcl_Obj *const *elems);
MODULE_SCOPE Tcl_Obj *	TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr);
MODULE_SCOPE Tcl_Obj *	TclListObjRange(Tcl_Obj *listPtr, int fromIdx,
			    int toIdx);
MODULE_SCOPE Tcl_Obj *	TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    Tcl_Obj *indexPtr, Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Obj *	TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    int indexCount, Tcl_Obj *const indexArray[],
			    Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name,
			    const EnsembleImplMap map[]);

			    Tcl_Obj *const opts[], int *flagPtr);
MODULE_SCOPE void	TclSubstParse(Tcl_Interp *interp, const char *bytes,
			    int numBytes, int flags, Tcl_Parse *parsePtr,
			    Tcl_InterpState *statePtr);
MODULE_SCOPE int	TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
			    int count, int *tokensLeftPtr, int line,
			    int *clNextOuter, const char *outerScript);
MODULE_SCOPE int	TclTrim(const char *bytes, int numBytes,
			    const char *trim, int numTrim, int *trimRight);
MODULE_SCOPE int	TclTrimLeft(const char *bytes, int numBytes,
			    const char *trim, int numTrim);
MODULE_SCOPE int	TclTrimRight(const char *bytes, int numBytes,
			    const char *trim, int numTrim);
MODULE_SCOPE int	TclUtfCmp(const char *cs, const char *ct);
MODULE_SCOPE int	TclUtfCasecmp(const char *cs, const char *ct);
MODULE_SCOPE int	TclUtfCount(int ch);

			    Tcl_Obj *const objv[], int flags);
MODULE_SCOPE int	TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack,
			    int start);
MODULE_SCOPE int	TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack,
			    int last);
MODULE_SCOPE Tcl_Obj *	TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    int count, int flags);
MODULE_SCOPE Tcl_Obj *	TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    int first, int count, Tcl_Obj *insertPtr,
			    int flags);
MODULE_SCOPE Tcl_Obj *	TclStringReverse(Tcl_Obj *objPtr, int flags);

/* Flag values for the [string] ensemble functions. */

#define TCL_STRING_MATCH_NOCASE TCL_MATCH_NOCASE /* (1<<0) in tcl.h */
#define TCL_STRING_IN_PLACE (1<<1)

MODULE_SCOPE int	TclCompareObjKeys(CONST90 void *keyPtr, Tcl_HashEntry *hPtr);
MODULE_SCOPE void	TclFreeObjEntry(Tcl_HashEntry *hPtr);
MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, CONST90 void *keyPtr);

MODULE_SCOPE int	TclFullFinalizationRequested(void);

/*
 * TIP #462.
 */

/*
 * The following enum values give the status of a spawned process.
 */

typedef enum TclProcessWaitStatus {
    TCL_PROCESS_ERROR = -1,	/* Error waiting for process to exit */
    TCL_PROCESS_UNCHANGED = 0,	/* No change since the last call. */
    TCL_PROCESS_EXITED = 1,	/* Process has exited. */
    TCL_PROCESS_SIGNALED = 2,	/* Child killed because of a signal. */
    TCL_PROCESS_STOPPED = 3,	/* Child suspended because of a signal. */
    TCL_PROCESS_UNKNOWN_STATUS = 4 
				/* Child wait status didn't make sense. */
} TclProcessWaitStatus;

MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp);
MODULE_SCOPE void	TclProcessCreated(Tcl_Pid pid);
MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options,
			    int *codePtr, Tcl_Obj **msgObjPtr,
			    Tcl_Obj **errorObjPtr);

/*
 * Utility routines for encoding index values as integers. Used by both
 * some of the command compilers and by [lsort] and [lsearch].
 */

MODULE_SCOPE int	TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    int before, int after, int *indexPtr);
MODULE_SCOPE int	TclIndexDecode(int encoded, int endValue);

/* Constants used in index value encoding routines. */
#define TCL_INDEX_END           (-2)
#define TCL_INDEX_BEFORE        (-1)
#define TCL_INDEX_START         (0)
#define TCL_INDEX_AFTER         (INT_MAX)

/*
 *----------------------------------------------------------------
 * Macros used by the Tcl core to create and release Tcl objects.
 * TclNewObj(objPtr) creates a new object denoting an empty string.
 * TclDecrRefCount(objPtr) decrements the object's reference count, and frees
 * the object if its reference count is zero. These macros are inline versions
 * of Tcl_NewObj() and Tcl_DecrRefCount(). Notice that the names differ in not

    DupListInternalRep(listPtr, copyPtr);
    return copyPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclListObjRange --
 *
 *	Makes a slice of a list value.
 *      *listPtr must be known to be a valid list.
 *
 * Results:
 *	Returns a pointer to the sliced list.
 *      This may be a new object or the same object if not shared.
 *
 * Side effects:
 *	The possible conversion of the object referenced by listPtr
 *	to a list object.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclListObjRange(
    Tcl_Obj *listPtr,		/* List object to take a range from. */
    int fromIdx,		/* Index of first element to include. */
    int toIdx)			/* Index of last element to include. */
{
    Tcl_Obj **elemPtrs;
    int listLen, i, newLen;
    List *listRepPtr;

    TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs);

    if (fromIdx < 0) {
	fromIdx = 0;
    }
    if (toIdx >= listLen) {
	toIdx = listLen-1;
    }
    if (fromIdx > toIdx) {
	return Tcl_NewObj();
    }

    newLen = toIdx - fromIdx + 1;

    if (Tcl_IsShared(listPtr) ||
	    ((ListRepPtr(listPtr)->refCount > 1))) {
	return Tcl_NewListObj(newLen, &elemPtrs[fromIdx]);
    }

    /*
     * In-place is possible.
     */

    /*
     * Even if nothing below cause any changes, we still want the
     * string-canonizing effect of [lrange 0 end].
     */

    TclInvalidateStringRep(listPtr);

    /*
     * Delete elements that should not be included.
     */

    for (i = 0; i < fromIdx; i++) {
	TclDecrRefCount(elemPtrs[i]);
    }
    for (i = toIdx + 1; i < listLen; i++) {
	TclDecrRefCount(elemPtrs[i]);
    }

    if (fromIdx > 0) {
	memmove(elemPtrs, &elemPtrs[fromIdx],
		(size_t) newLen * sizeof(Tcl_Obj*));
    }

    listRepPtr = ListRepPtr(listPtr);
    listRepPtr->elemCount = newLen;

    return listPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjGetElements --
 *
 *	Retreive the elements in a list 'Tcl_Obj'.
 *
 * Value
 *
 *	TCL_OK

	 * argPtr designates something that is neither an index nor a
	 * well-formed list. Report the error via TclLindexFlat.
	 */

	return TclLindexFlat(interp, listPtr, 1, &argPtr);
    }



    {



	int indexCount = -1;		/* Size of the array of list indices. */
	Tcl_Obj **indices = NULL; 	/* Array of list indices. */


	TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
	listPtr = TclLindexFlat(interp, listPtr, indexCount, indices);
    }
    Tcl_DecrRefCount(indexListCopy);
    return listPtr;
}

/*

    /*
     * Test for whether the initialization failed. If so, transfer the error
     * from the target interpreter to the originating one.
     */

    if (code != TCL_OK) {
	Interp *iPtr = (Interp *) target;
	if (iPtr->legacyResult && *(iPtr->legacyResult) && !iPtr->legacyFreeProc) {
	    /*
	     * A call to Tcl_InitStubs() determined the caller extension and
	     * this interp are incompatible in their stubs mechanisms, and
	     * recorded the error in the oldest legacy place we have to do so.
	     */
	    Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->legacyResult, -1));
	    iPtr->legacyResult = NULL;

InitClassSystemRoots(
    Tcl_Interp *interp,
    Foundation *fPtr)
{
    Class fakeCls;
    Object fakeObject;


    /* Stand up a phony class for bootstrapping. */


    fPtr->objectCls = &fakeCls;


    /* referenced in AllocClass to increment the refCount. */


    fakeCls.thisPtr = &fakeObject;

    fPtr->objectCls = AllocClass(interp,
	    AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));


    /* Corresponding TclOODecrRefCount in KillFoudation */

    AddRef(fPtr->objectCls->thisPtr);


    /* This is why it is unnecessary in this routine to replace the
     * incremented reference count of fPtr->objectCls that was swallowed by

     * fakeObject. */
    fPtr->objectCls->superclasses.num = 0;
    ckfree(fPtr->objectCls->superclasses.list);

    fPtr->objectCls->superclasses.list = NULL;


    /* special initialization for the primordial objects */


    fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
    fPtr->objectCls->flags |= ROOT_OBJECT;

    fPtr->classCls = AllocClass(interp,
	    AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
    /* Corresponding TclOODecrRefCount in KillFoudation */
    AddRef(fPtr->classCls->thisPtr);

    /*

     * Increment reference counts for each reference because these
     * relationships can be dynamically changed.
     *
     * Corresponding TclOODecrRefCount for all incremented refcounts is in
     * KillFoundation.
     */

    /* Rewire bootstrapped objects. */
    fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
    AddRef(fPtr->classCls->thisPtr);
    TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);

    fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
    AddRef(fPtr->classCls->thisPtr);
    TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);

    fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
    fPtr->classCls->flags |= ROOT_CLASS;


    /* Standard initialization for new Objects */




    TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);

    /*
     * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING.
     * Everything else is careful to prohibit looping.
     */
}

    Foundation *fPtr = GetFoundation(interp);

    TclDecrRefCount(fPtr->unknownMethodNameObj);
    TclDecrRefCount(fPtr->constructorName);
    TclDecrRefCount(fPtr->destructorName);
    TclDecrRefCount(fPtr->clonedName);
    TclDecrRefCount(fPtr->defineName);
    TclOODecrRefCount(fPtr->objectCls->thisPtr);
    TclOODecrRefCount(fPtr->classCls->thisPtr);

    ckfree(fPtr);
}

/*
 * ----------------------------------------------------------------------
 *
 * AllocObject --

	 * have to get rid of the error message from Tcl_CreateNamespace,
	 * since that's something that should not be exposed to the user.
	 */

	Tcl_ResetResult(interp);
    }


  configNamespace:

    ((Namespace *)oPtr->namespacePtr)->refCount++;

    /*
     * Make the namespace know about the helper commands. This grants access
     * to the [self] and [next] commands.
     */


    if (fPtr->helpersNs != NULL) {
	TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
    }
    TclOOSetupVariableResolver(oPtr->namespacePtr);

    /*
     * Suppress use of compiled versions of the commands in this object's

    TclOODecrRefCount(oPtr);
    return;
}

/*
 * ----------------------------------------------------------------------
 *
 * DeleteDescendants --
 *
 *	Delete all descendants of a particular class.

 *
 * ----------------------------------------------------------------------
 */

static void
DeleteDescendants(
    Tcl_Interp *interp,		/* The interpreter containing the class. */
    Object *oPtr)		/* The object representing the class. */
{
    Class *clsPtr = oPtr->classPtr, *subclassPtr, *mixinSubclassPtr;
    Object *instancePtr;


    /*
     * Squelch classes that this class has been mixed into.
     */

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

	    if (!Deleted(mixinSubclassPtr->thisPtr)) {
		Tcl_DeleteCommandFromToken(interp,
			mixinSubclassPtr->thisPtr->command);
	    }
	    TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
	}
    }
    if (clsPtr->mixinSubs.size > 0) {
	ckfree(clsPtr->mixinSubs.list);
	clsPtr->mixinSubs.size = 0;
    }

    /*
     * Squelch subclasses of this class.
     */

    if (clsPtr->subclasses.num > 0) {
	while (clsPtr->subclasses.num > 0) {
	    subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1];
	    if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)) {
		Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
	    }
	    TclOORemoveFromSubclasses(subclassPtr, clsPtr);
	}
    }
    if (clsPtr->subclasses.size > 0) {
	ckfree(clsPtr->subclasses.list);
	clsPtr->subclasses.list = NULL;
	clsPtr->subclasses.size = 0;
    }

    /*
     * Squelch instances of this class (includes objects we're mixed into).
     */

    if (clsPtr->instances.num > 0) {
	while (clsPtr->instances.num > 0) {
	    instancePtr = clsPtr->instances.list[clsPtr->instances.num-1];
	    /*
	     * This condition also covers the case where instancePtr == oPtr
	     */

	    if (!Deleted(instancePtr) && !IsRoot(instancePtr)) {
		Tcl_DeleteCommandFromToken(interp, instancePtr->command);
	    }
	    TclOORemoveFromInstances(instancePtr, clsPtr);
	}
    }
    if (clsPtr->instances.size > 0) {
	ckfree(clsPtr->instances.list);
	clsPtr->instances.list = NULL;
	clsPtr->instances.size = 0;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * ReleaseClassContents --
 *
 *	Tear down the special class data structure, including deleting all
 *	dependent classes and objects.
 *
 * ----------------------------------------------------------------------
 */

static void
ReleaseClassContents(
    Tcl_Interp *interp,		/* The interpreter containing the class. */
    Object *oPtr)		/* The object representing the class. */
{
    FOREACH_HASH_DECLS;

    if (clsPtr->filters.num) {
	Tcl_Obj *filterObj;

	FOREACH(filterObj, clsPtr->filters) {
	    TclDecrRefCount(filterObj);
	}
	ckfree(clsPtr->filters.list);
	clsPtr->filters.list = NULL;
	clsPtr->filters.num = 0;
    }

    /*
     * Squelch our metadata.
     */

    if (clsPtr->metadataPtr != NULL) {
	Tcl_ObjectMetadataType *metadataTypePtr;
	ClientData value;

	FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
	    metadataTypePtr->deleteProc(value);
	}
	Tcl_DeleteHashTable(clsPtr->metadataPtr);
	ckfree(clsPtr->metadataPtr);
	clsPtr->metadataPtr = NULL;
    }

    if (clsPtr->mixins.num) {
	FOREACH(tmpClsPtr, clsPtr->mixins) {
	    TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr);
	    TclOODecrRefCount(tmpClsPtr->thisPtr);
	}
	ckfree(clsPtr->mixins.list);
	clsPtr->mixins.list = NULL;
	clsPtr->mixins.num = 0;
    }

    if (clsPtr->superclasses.num > 0) {
	FOREACH(tmpClsPtr, clsPtr->superclasses) {
	    TclOORemoveFromSubclasses(clsPtr, tmpClsPtr);
	    TclOODecrRefCount(tmpClsPtr->thisPtr);
	}
	ckfree(clsPtr->superclasses.list);
	clsPtr->superclasses.num = 0;
	clsPtr->superclasses.list = NULL;
    }

    FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
	TclOODelMethodRef(mPtr);
    }
    Tcl_DeleteHashTable(&clsPtr->classMethods);
    TclOODelMethodRef(clsPtr->constructorPtr);

    /*
     * TODO: Should this be protected with a * !IsRoot() condition?
     */

    TclOORemoveFromInstances(oPtr, oPtr->selfCls);

    if (oPtr->mixins.num > 0) {
	FOREACH(mixinPtr, oPtr->mixins) {
	    TclOORemoveFromInstances(oPtr, mixinPtr);
	    TclOODecrRefCount(mixinPtr->thisPtr);
	}

	ckfree(oPtr->mixins.list);
    }

    FOREACH(filterObj, oPtr->filters) {
	TclDecrRefCount(filterObj);
    }
    if (i) {

	ReleaseClassContents(interp, oPtr);
    }

    /*
     * Delete the object structure itself.
     */

    TclNsDecrRefCount((Namespace *)oPtr->namespacePtr);
    oPtr->namespacePtr = NULL;
    TclOODecrRefCount(oPtr->selfCls->thisPtr);
    oPtr->selfCls = NULL;
    TclOODecrRefCount(oPtr);
    return;
}

/*
 * ----------------------------------------------------------------------

 */

int
TclOODecrRefCount(
    Object *oPtr)
{
    if (oPtr->refCount-- <= 1) {


	if (oPtr->classPtr != NULL) {





	    ckfree(oPtr->classPtr);
	}
	ckfree(oPtr);
	return 1;
    }
    return 0;
}

    Object *oPtr,		/* The instance to remove. */
    Class *clsPtr)		/* The class (possibly) containing the
				 * reference to the instance. */
{
    int i, res = 0;
    Object *instPtr;





    FOREACH(instPtr, clsPtr->instances) {
	if (oPtr == instPtr) {
	    RemoveItem(Object, clsPtr->instances, i);
	    TclOODecrRefCount(oPtr);
	    res++;
	    break;
	}

    Class *subPtr,		/* The subclass to remove. */
    Class *superPtr)		/* The superclass to possibly remove the
				 * subclass reference from. */
{
    int i, res = 0;
    Class *subclsPtr;





    FOREACH(subclsPtr, superPtr->subclasses) {
	if (subPtr == subclsPtr) {
	    RemoveItem(Class, superPtr->subclasses, i);
	    TclOODecrRefCount(subPtr->thisPtr);
	    res++;
	}
    }

    Class *subPtr,		/* The subclass to remove. */
    Class *superPtr)		/* The superclass to possibly remove the
				 * subclass reference from. */
{
    int i, res = 0;
    Class *subclsPtr;





    FOREACH(subclsPtr, superPtr->mixinSubs) {
	if (subPtr == subclsPtr) {
	    RemoveItem(Class, superPtr->mixinSubs, i);
	    TclOODecrRefCount(subPtr->thisPtr);
	    res++;
	    break;
	}

    /*
     * Create the object.
     */

    oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
    oPtr->selfCls = classPtr;
    AddRef(classPtr->thisPtr);
    TclOOAddToInstances(oPtr, classPtr);

    /*
     * Check to see if we're really creating a class. If so, allocate the
     * class structure as well.
     */

	}
    }

    /*
     * Copy the object's mixin references to the new object.
     */

    if (o2Ptr->mixins.num != 0) {
	FOREACH(mixinPtr, o2Ptr->mixins) {
	    if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
		TclOORemoveFromInstances(o2Ptr, mixinPtr);
	    }
	    TclOODecrRefCount(mixinPtr->thisPtr);
	}
	ckfree(o2Ptr->mixins.list);
    }
    DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
    FOREACH(mixinPtr, o2Ptr->mixins) {
	if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
	    TclOOAddToInstances(o2Ptr, mixinPtr);
	}
	/* For the reference just created in DUPLICATE */
	AddRef(mixinPtr->thisPtr);
    }

    /*
     * Copy the object's filter list to the new object.
     */

    DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *);

	/*
	 * Ensure that the new class's superclass structure is the same as the
	 * old class's.
	 */

	FOREACH(superPtr, cls2Ptr->superclasses) {
	    TclOORemoveFromSubclasses(cls2Ptr, superPtr);
	    TclOODecrRefCount(superPtr->thisPtr);
	}
	if (cls2Ptr->superclasses.num) {
	    cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list,
		    sizeof(Class *) * clsPtr->superclasses.num);
	} else {
	    cls2Ptr->superclasses.list =
		    ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
	}
	memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
		sizeof(Class *) * clsPtr->superclasses.num);
	cls2Ptr->superclasses.num = clsPtr->superclasses.num;
	FOREACH(superPtr, cls2Ptr->superclasses) {
	    TclOOAddToSubclasses(cls2Ptr, superPtr);

	    /* For the new item in cls2Ptr->superclasses that memcpy just
	     * created
	     */
	    AddRef(superPtr->thisPtr);
	}

	/*
	 * Duplicate the source class's filters.
	 */

	DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *);

	}

	/*
	 * Duplicate the source class's mixins (which cannot be circular
	 * references to the duplicate).
	 */

	if (cls2Ptr->mixins.num != 0) {
	    FOREACH(mixinPtr, cls2Ptr->mixins) {
		TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }

	    ckfree(clsPtr->mixins.list);
	}
	DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
	FOREACH(mixinPtr, cls2Ptr->mixins) {
	    TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
	    /* For the copy just created in DUPLICATE */
	    AddRef(mixinPtr->thisPtr);
	}

	/*
	 * Duplicate the source class's methods, constructor and destructor.
	 */

	FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) {

    Class *mixinPtr;
    int i;

    if (numMixins == 0) {
	if (oPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, oPtr->mixins) {
		TclOORemoveFromInstances(oPtr, mixinPtr);
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }
	    ckfree(oPtr->mixins.list);
	    oPtr->mixins.num = 0;
	}
	RecomputeClassCacheFlag(oPtr);
    } else {
	if (oPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, oPtr->mixins) {
		if (mixinPtr && mixinPtr != oPtr->selfCls) {
		    TclOORemoveFromInstances(oPtr, mixinPtr);
		}
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }
	    oPtr->mixins.list = ckrealloc(oPtr->mixins.list,
		    sizeof(Class *) * numMixins);
	} else {
	    oPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
	    oPtr->flags &= ~USE_CLASS_CACHE;
	}
	oPtr->mixins.num = numMixins;
	memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
	FOREACH(mixinPtr, oPtr->mixins) {
	    if (mixinPtr != oPtr->selfCls) {
		TclOOAddToInstances(oPtr, mixinPtr);
		/* For the new copy created by memcpy */





		AddRef(mixinPtr->thisPtr);
	    }
	}
    }
    oPtr->epoch++;
}

/*

    Class *mixinPtr;
    int i;

    if (numMixins == 0) {
	if (classPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, classPtr->mixins) {
		TclOORemoveFromMixinSubs(classPtr, mixinPtr);
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }
	    ckfree(classPtr->mixins.list);
	    classPtr->mixins.num = 0;
	}
    } else {
	if (classPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, classPtr->mixins) {
		TclOORemoveFromMixinSubs(classPtr, mixinPtr);
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }
	    classPtr->mixins.list = ckrealloc(classPtr->mixins.list,
		    sizeof(Class *) * numMixins);
	} else {
	    classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
	}
	classPtr->mixins.num = numMixins;
	memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
	FOREACH(mixinPtr, classPtr->mixins) {
	    TclOOAddToMixinSubs(classPtr, mixinPtr);
	    /* For the new copy created by memcpy */





	    AddRef(mixinPtr->thisPtr);
	}
    }
    BumpGlobalEpoch(interp, classPtr);
}

/*
 * ----------------------------------------------------------------------

    /*
     * Set the object's class.
     */

    if (oPtr->selfCls != clsPtr) {
	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
	TclOODecrRefCount(oPtr->selfCls->thisPtr);




	oPtr->selfCls = clsPtr;
	AddRef(oPtr->selfCls->thisPtr);
	TclOOAddToInstances(oPtr, oPtr->selfCls);

	if (oPtr->classPtr != NULL) {
	    BumpGlobalEpoch(interp, oPtr->classPtr);
	} else {
	    oPtr->epoch++;
	}
    }
    return TCL_OK;

	if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "may not mix a class into itself", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
	    goto freeAndError;
	}
	mixins[i-1] = clsPtr;







    }

    if (isInstanceMixin) {
	TclOOObjectSetMixins(oPtr, objc-1, mixins);
    } else {
	TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins);
    }

    TclStackFree(interp, mixins);
    return TCL_OK;

  freeAndError:



    TclStackFree(interp, mixins);
    return TCL_ERROR;
}

/*
 * ----------------------------------------------------------------------
 *

	}
	if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "may not mix a class into itself", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
	    goto freeAndError;
	}







    }

    TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
    TclStackFree(interp, mixins);
    return TCL_OK;

  freeAndError:



    TclStackFree(interp, mixins);
    return TCL_ERROR;
}

/*
 * ----------------------------------------------------------------------
 *

	superclasses = ckrealloc(superclasses, sizeof(Class *));
	if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) {
	    superclasses[0] = oPtr->fPtr->classCls;
	} else {
	    superclasses[0] = oPtr->fPtr->objectCls;
	}
	superc = 1;





	AddRef(superclasses[0]->thisPtr);
    } else {
	for (i=0 ; i<superc ; i++) {
	    superclasses[i] = GetClassInOuterContext(interp, superv[i],
		    "only a class can be a superclass");
	    if (superclasses[i] == NULL) {
		i--;

     * it used to be a member of and splicing it into the new superclasses'
     * subclass list.
     */

    if (oPtr->classPtr->superclasses.num != 0) {
	FOREACH(superPtr, oPtr->classPtr->superclasses) {
	    TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
	    TclOODecrRefCount(superPtr->thisPtr);
	}
	ckfree(oPtr->classPtr->superclasses.list);
    }
    oPtr->classPtr->superclasses.list = superclasses;
    oPtr->classPtr->superclasses.num = superc;
    FOREACH(superPtr, oPtr->classPtr->superclasses) {
	TclOOAddToSubclasses(oPtr->classPtr, superPtr);






    }
    BumpGlobalEpoch(interp, oPtr->classPtr);

    return TCL_OK;
}

/*

    mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);

    for (i=0 ; i<mixinc ; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {



	    TclStackFree(interp, mixins);
	    return TCL_ERROR;
	}







    }

    TclOOObjectSetMixins(oPtr, mixinc, mixins);
    TclStackFree(interp, mixins);
    return TCL_OK;
}


	    case INST_JUMP_FALSE1:
	    case INST_JUMP_FALSE4:
	    case INST_INCR_SCALAR1:
	    case INST_INCR_ARRAY1:
	    case INST_INCR_ARRAY_STK:
	    case INST_INCR_SCALAR_STK:
	    case INST_INCR_STK:


	    case INST_EQ:
	    case INST_NEQ:
	    case INST_LT:
	    case INST_LE:
	    case INST_GT:
	    case INST_GE:
	    case INST_MOD:

 */

void
Tcl_ReapDetachedProcs(void)
{
    register Detached *detPtr;
    Detached *nextPtr, *prevPtr;
    int status, code;


    Tcl_MutexLock(&pipeMutex);
    for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) {
	status = TclProcessWait(detPtr->pid, WNOHANG, &code, NULL, NULL);
	if (status == TCL_PROCESS_UNCHANGED || (status == TCL_PROCESS_ERROR
		&& code != ECHILD)) {
	    prevPtr = detPtr;
	    detPtr = detPtr->nextPtr;
	    continue;
	}
	nextPtr = detPtr->nextPtr;
	if (prevPtr == NULL) {
	    detList = detPtr->nextPtr;

    Tcl_Pid *pidPtr,		/* Array of process ids of children. */
    Tcl_Channel errorChan)	/* Channel for file containing stderr output
				 * from pipeline. NULL means there isn't any
				 * stderr output. */
{
    int result = TCL_OK;
    int i, abnormalExit, anyErrorInfo;

    TclProcessWaitStatus waitStatus;
    int code;
    Tcl_Obj *msg, *error;


    abnormalExit = 0;
    for (i = 0; i < numPids; i++) {





	waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error);

	if (waitStatus == TCL_PROCESS_ERROR) {

	    result = TCL_ERROR;
	    if (interp != NULL) {







		Tcl_SetObjErrorCode(interp, error);



		Tcl_SetObjResult(interp, msg);

	    }
	    Tcl_DecrRefCount(error);
	    Tcl_DecrRefCount(msg);
	    continue;
	}

	/*
	 * Create error messages for unusual process exits. An extra newline
	 * gets appended to each error message, but it gets removed below (in
	 * the same fashion that an extra newline in the command's output is
	 * removed).
	 */



	if (waitStatus != TCL_PROCESS_EXITED || code != 0) {
	    result = TCL_ERROR;

	    if (waitStatus == TCL_PROCESS_EXITED) {
		if (interp != NULL) {

		    Tcl_SetObjErrorCode(interp, error);
		}
		abnormalExit = 1;
	    } else if (interp != NULL) {










		Tcl_SetObjErrorCode(interp, error);

		Tcl_SetObjResult(interp, msg);






	    }

	    Tcl_DecrRefCount(error);
	    Tcl_DecrRefCount(msg);
	}
    }

    /*
     * Read the standard error file. If there's anything there, then return an
     * error and add the file's contents to the result string.
     */

	if (result != TCL_OK) {
	    goto error;
	}
	Tcl_DStringFree(&execBuffer);

	pidPtr[numPids] = pid;
	numPids++;
	TclProcessCreated(pid);

	/*
	 * Close off our copies of file descriptors that were set up for this
	 * child, then set up the input for the next child.
	 */

	if ((curInFile != NULL) && (curInFile != inputFile)) {

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

	char *versionToProvide = bestPtr->version;
	PkgFiles *pkgFiles;
	PkgName *pkgName;

	Tcl_Preserve(versionToProvide);
	pkgPtr->clientData = versionToProvide;

	pkgFiles = TclInitPkgFiles(interp);
	/* Push "ifneeded" package name in "tclPkgFiles" assocdata. */
	pkgName = ckalloc(sizeof(PkgName) + strlen(name));
	pkgName->nextPtr = pkgFiles->names;
	strcpy(pkgName->name, name);
	pkgFiles->names = pkgName;
	if (bestPtr->pkgIndex) {
	    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);
    }
    return TCL_OK;
}

static int
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*/
    PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
    PkgName *pkgName = pkgFiles->names;









    pkgFiles->names = pkgName->nextPtr;
    ckfree(pkgName);

    reqPtr->pkgPtr = FindPackage(interp, name);
    if (result == TCL_OK) {
	Tcl_ResetResult(interp);
	if (reqPtr->pkgPtr->version == NULL) {

	    }

	    /*
	     * Create a new-style requirement for the exact version.
	     */

	    ov = Tcl_NewStringObj(version, -1);

	    Tcl_AppendStringsToObj(ov, "-", version, NULL);
	    version = NULL;
	    argv3 = TclGetString(objv[3]);
	    Tcl_IncrRefCount(objv[3]);

	    objvListPtr = Tcl_NewListObj(0, NULL);
	    Tcl_IncrRefCount(objvListPtr);

/*
 * tclProcess.c --
 *
 *	This file implements the "tcl::process" ensemble for subprocess 
 *	management as defined by TIP #462.
 *
 * Copyright (c) 2017 Frederic Bonnet.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"

/*
 * Autopurge flag. Process-global because of the way Tcl manages child 
 * processes (see tclPipe.c).
 */

static int autopurge = 1;	/* Autopurge flag. */

/*
 * Hash tables that keeps track of all child process statuses. Keys are the 
 * child process ids and resolved pids, values are (ProcessInfo *).
 */

typedef struct ProcessInfo {
    Tcl_Pid pid;		/* Process id. */
    int resolvedPid;		/* Resolved process id. */
    int purge;			/* Purge eventualy. */
    TclProcessWaitStatus status;/* Process status. */
    int code;			/* Error code, exit status or signal 
				   number. */
    Tcl_Obj *msg;		/* Error message. */
    Tcl_Obj *error;		/* Error code. */
} ProcessInfo;
static Tcl_HashTable infoTablePerPid;
static Tcl_HashTable infoTablePerResolvedPid;
static int infoTablesInitialized = 0;	/* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(infoTablesMutex)

 /*
 * Prototypes for functions defined later in this file:
 */

static void		InitProcessInfo(ProcessInfo *info, Tcl_Pid pid,
			    int resolvedPid);
static void		FreeProcessInfo(ProcessInfo *info);
static int		RefreshProcessInfo(ProcessInfo *info, int options);
static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, 
			    int options, int *codePtr, Tcl_Obj **msgPtr,
			    Tcl_Obj **errorObjPtr);
static Tcl_Obj *	BuildProcessStatusObj(ProcessInfo *info);
static int		ProcessListObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		ProcessStatusObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		ProcessPurgeObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		ProcessAutopurgeObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);

/*
 *----------------------------------------------------------------------
 *
 * InitProcessInfo --
 *
 *	Initializes the ProcessInfo structure.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory written.
 *
 *----------------------------------------------------------------------
 */

void
InitProcessInfo(
    ProcessInfo *info,		/* Structure to initialize. */
    Tcl_Pid pid,		/* Process id. */
    int resolvedPid)		/* Resolved process id. */
{
    info->pid = pid;
    info->resolvedPid = resolvedPid;
    info->purge = 0;
    info->status = TCL_PROCESS_UNCHANGED;
    info->code = 0;
    info->msg = NULL;
    info->error = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeProcessInfo --
 *
 *	Free the ProcessInfo structure.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory deallocated, Tcl_Obj refcount decreased.
 *
 *----------------------------------------------------------------------
 */

void
FreeProcessInfo(
    ProcessInfo *info)		/* Structure to free. */
{
    /*
     * Free stored Tcl_Objs.
     */

    if (info->msg) {
	Tcl_DecrRefCount(info->msg);
    }
    if (info->error) {
	Tcl_DecrRefCount(info->error);
    }

    /*
     * Free allocated structure.
     */

    ckfree(info);
}

/*
 *----------------------------------------------------------------------
 *
 * RefreshProcessInfo --
 *
 *	Refresh process info.
 *
 * Results:
 *	Nonzero if state changed, else zero.
 *
 * Side effects:
 *	May call WaitProcessStatus, which can block if WNOHANG option is set.
 *
 *----------------------------------------------------------------------
 */

int
RefreshProcessInfo(
    ProcessInfo *info,		/* Structure to refresh. */
    int options			/* Options passed to WaitProcessStatus. */
)
{
    if (info->status == TCL_PROCESS_UNCHANGED) {
	/*
	 * Refresh & store status.
	 */

	info->status = WaitProcessStatus(info->pid, info->resolvedPid, 
		options, &info->code, &info->msg, &info->error);
	if (info->msg) Tcl_IncrRefCount(info->msg);
	if (info->error) Tcl_IncrRefCount(info->error);
	return (info->status != TCL_PROCESS_UNCHANGED);
    } else {
	/*
	 * No change.
	 */

	return 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * WaitProcessStatus --
 *
 *	Wait for process status to change.
 *
 * Results:
 *	TclProcessWaitStatus enum value.
 *
 * Side effects:
 *	May call WaitProcessStatus, which can block if WNOHANG option is set.
 *
 *----------------------------------------------------------------------
 */

TclProcessWaitStatus
WaitProcessStatus(
    Tcl_Pid pid,		/* Process id. */
    int resolvedPid,		/* Resolved process id. */
    int options,		/* Options passed to Tcl_WaitPid. */
    int *codePtr,		/* If non-NULL, will receive either:
				 *  - 0 for normal exit.
				 *  - errno in case of error.
				 *  - non-zero exit code for abormal exit.
				 *  - signal number if killed or suspended.
				 *  - Tcl_WaitPid status in all other cases.
				 */
    Tcl_Obj **msgObjPtr,	/* If non-NULL, will receive error message. */
    Tcl_Obj **errorObjPtr)	/* If non-NULL, will receive error code. */
{
    int waitStatus;
    Tcl_Obj *errorStrings[5];
    const char *msg;

    pid = Tcl_WaitPid(pid, &waitStatus, options);
    if (pid == 0) {
	/*
	 * No change.
	 */
	
	return TCL_PROCESS_UNCHANGED;
    }

    /*
     * Get process status.
     */

    if (pid == (Tcl_Pid) -1) {
	/*
	 * POSIX errName msg
	 */

	msg = Tcl_ErrnoMsg(errno);
	if (errno == ECHILD) {
	    /*
	     * This changeup in message suggested by Mark Diekhans to
	     * remind people that ECHILD errors can occur on some
	     * systems if SIGCHLD isn't in its default state.
	     */

	    msg = "child process lost (is SIGCHLD ignored or trapped?)";
	}
	if (codePtr) *codePtr = errno;
	if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
		"error waiting for process to exit: %s", msg);
	if (errorObjPtr) {
	    errorStrings[0] = Tcl_NewStringObj("POSIX", -1);
	    errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1);
	    errorStrings[2] = Tcl_NewStringObj(msg, -1);
	    *errorObjPtr = Tcl_NewListObj(3, errorStrings);
	}
	return TCL_PROCESS_ERROR;
    } else if (WIFEXITED(waitStatus)) {
	if (codePtr) *codePtr = WEXITSTATUS(waitStatus);
	if (!WEXITSTATUS(waitStatus)) {
	    /*
	     * Normal exit.
	     */

	    if (msgObjPtr) *msgObjPtr = NULL;
	    if (errorObjPtr) *errorObjPtr = NULL;
	} else {
	    /*
	     * CHILDSTATUS pid code
	     *
	     * Child exited with a non-zero exit status.
	     */

	    if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
		    "child process exited abnormally", -1);
	    if (errorObjPtr) {
		errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1);
		errorStrings[1] = Tcl_NewIntObj(resolvedPid);
		errorStrings[2] = Tcl_NewIntObj(WEXITSTATUS(waitStatus));
		*errorObjPtr = Tcl_NewListObj(3, errorStrings);
	    }
	}
	return TCL_PROCESS_EXITED;
    } else if (WIFSIGNALED(waitStatus)) {
	/*
	 * CHILDKILLED pid sigName msg
	 *
	 * Child killed because of a signal.
	 */

	msg = Tcl_SignalMsg(WTERMSIG(waitStatus));
	if (codePtr) *codePtr = WTERMSIG(waitStatus);
	if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
		"child killed: %s", msg);
	if (errorObjPtr) {
	    errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1);
	    errorStrings[1] = Tcl_NewIntObj(resolvedPid);
	    errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1);
	    errorStrings[3] = Tcl_NewStringObj(msg, -1);
	    *errorObjPtr = Tcl_NewListObj(4, errorStrings);
	}
	return TCL_PROCESS_SIGNALED;
    } else if (WIFSTOPPED(waitStatus)) {
	/*
	 * CHILDSUSP pid sigName msg
	 *
	 * Child suspended because of a signal.
	 */

	msg = Tcl_SignalMsg(WSTOPSIG(waitStatus));
	if (codePtr) *codePtr = WSTOPSIG(waitStatus);
	if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
		"child suspended: %s", msg);
	if (errorObjPtr) {
	    errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1);
	    errorStrings[1] = Tcl_NewIntObj(resolvedPid);
	    errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1);
	    errorStrings[3] = Tcl_NewStringObj(msg, -1);
	    *errorObjPtr = Tcl_NewListObj(4, errorStrings);
	}
	return TCL_PROCESS_STOPPED;
    } else {
	/*
	 * TCL OPERATION EXEC ODDWAITRESULT
	 *
	 * Child wait status didn't make sense.
	 */

	if (codePtr) *codePtr = waitStatus;
	if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
		"child wait status didn't make sense\n", -1);
	if (errorObjPtr) {
	    errorStrings[0] = Tcl_NewStringObj("TCL", -1);
	    errorStrings[1] = Tcl_NewStringObj("OPERATION", -1);
	    errorStrings[2] = Tcl_NewStringObj("EXEC", -1);
	    errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1);
	    errorStrings[4] = Tcl_NewIntObj(resolvedPid);
	    *errorObjPtr = Tcl_NewListObj(5, errorStrings);
	}
	return TCL_PROCESS_UNKNOWN_STATUS;
    }
}


/*
 *----------------------------------------------------------------------
 *
 * BuildProcessStatusObj --
 *
 *	Build a list object with process status. The first element is always
 *	a standard Tcl return value, which can be either TCL_OK or TCL_ERROR.
 *	In the latter case, the second element is the error message and the
 *	third element is a Tcl error code (see tclvars).
 *
 * Results:
 *	A list object.
 *
 * Side effects:
 *	Tcl_Objs are created.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
BuildProcessStatusObj(
    ProcessInfo *info)
{
    Tcl_Obj *resultObjs[3];

    if (info->status == TCL_PROCESS_UNCHANGED) {
	/*
	 * Process still running, return empty obj.
	 */

	return Tcl_NewObj();
    }
    if (info->status == TCL_PROCESS_EXITED && info->code == 0) {
	/*
	 * Normal exit, return TCL_OK.
	 */
	
	return Tcl_NewIntObj(TCL_OK);
    }

    /*
     * Abnormal exit, return {TCL_ERROR msg error}
     */

    resultObjs[0] = Tcl_NewIntObj(TCL_ERROR);
    resultObjs[1] = info->msg;
    resultObjs[2] = info->error;
    return Tcl_NewListObj(3, resultObjs);
}

/*----------------------------------------------------------------------
 *
 * ProcessListObjCmd --
 *
 *	This function implements the 'tcl::process list' Tcl command. 
 *	Refer to the user documentation for details on what it does.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Access to the internal structures is protected by infoTablesMutex.
 *
 *----------------------------------------------------------------------
 */

static int
ProcessListObjCmd(
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *list;
    Tcl_HashEntry *entry;
    Tcl_HashSearch search;
    ProcessInfo *info;

    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }

    /*
     * Return the list of all chid process ids.
     */

    list = Tcl_NewListObj(0, NULL);
    Tcl_MutexLock(&infoTablesMutex);
    for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); 
	    entry != NULL; entry = Tcl_NextHashEntry(&search)) {
	info = (ProcessInfo *) Tcl_GetHashValue(entry);
	Tcl_ListObjAppendElement(interp, list, 
		Tcl_NewIntObj(info->resolvedPid));
    }
    Tcl_MutexUnlock(&infoTablesMutex);
    Tcl_SetObjResult(interp, list);
    return TCL_OK;
}

/*----------------------------------------------------------------------
 *
 * ProcessStatusObjCmd --
 *
 *	This function implements the 'tcl::process status' Tcl command. 
 *	Refer to the user documentation for details on what it does.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Access to the internal structures is protected by infoTablesMutex.
 *	Calls RefreshProcessInfo, which can block if -wait switch is given.
 *
 *----------------------------------------------------------------------
 */

static int
ProcessStatusObjCmd(
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *dict;
    int index, options = WNOHANG;
    Tcl_HashEntry *entry;
    Tcl_HashSearch search;
    ProcessInfo *info;
    int numPids;
    Tcl_Obj **pidObjs;
    int result;
    int i;
    int pid;
    Tcl_Obj *const *savedobjv = objv;
    static const char *const switches[] = {
	"-wait", "--", NULL
    };
    enum switches {
	STATUS_WAIT, STATUS_LAST
    };

    while (objc > 1) {
	if (TclGetString(objv[1])[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0,
		&index) != TCL_OK) {
	    return TCL_ERROR;
	}
	++objv; --objc;
	if (STATUS_WAIT == (enum switches) index) {
	    options = 0;
	} else {
	    break;
	}
    }

    if (objc != 1 && objc != 2) {
	Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?");
	return TCL_ERROR;
    }

    if (objc == 1) {
	/*
	* Return a dict with all child process statuses.
	*/

	dict = Tcl_NewDictObj();
	Tcl_MutexLock(&infoTablesMutex);
	for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); 
		entry != NULL; entry = Tcl_NextHashEntry(&search)) {
	    info = (ProcessInfo *) Tcl_GetHashValue(entry);
	    RefreshProcessInfo(info, options);

	    if (info->purge && autopurge) {
		/*
		 * Purge entry.
		 */
		
		Tcl_DeleteHashEntry(entry);
		entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
		Tcl_DeleteHashEntry(entry);
		FreeProcessInfo(info);
	    } else {
		/*
		 * Add to result.
		 */

		Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), 
			BuildProcessStatusObj(info));
	    }
	}
	Tcl_MutexUnlock(&infoTablesMutex);
    } else {
	/*
	 * Only return statuses of provided processes.
	 */
	
	result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
	if (result != TCL_OK) {
	    return result;
	}
	dict = Tcl_NewDictObj();
	Tcl_MutexLock(&infoTablesMutex);
	for (i = 0; i < numPids; i++) {
	    result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid);
	    if (result != TCL_OK) {
		Tcl_MutexUnlock(&infoTablesMutex);
		Tcl_DecrRefCount(dict);
		return result;
	    }

	    entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));
	    if (!entry) {
		/*
		 * Skip unknown process.
		 */
		
		continue;
	    }
	    
	    info = (ProcessInfo *) Tcl_GetHashValue(entry);
	    RefreshProcessInfo(info, options);

	    if (info->purge && autopurge) {
		/*
		 * Purge entry.
		 */
		
		Tcl_DeleteHashEntry(entry);
		entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
		Tcl_DeleteHashEntry(entry);
		FreeProcessInfo(info);
	    } else {
		/*
		 * Add to result.
		 */

		Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), 
			BuildProcessStatusObj(info));
	    }
	}
	Tcl_MutexUnlock(&infoTablesMutex);
    }
    Tcl_SetObjResult(interp, dict);
    return TCL_OK;
}

/*----------------------------------------------------------------------
 *
 * ProcessPurgeObjCmd --
 *
 *	This function implements the 'tcl::process purge' Tcl command. 
 *	Refer to the user documentation for details on what it does.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Frees all ProcessInfo structures with their purge flag set.
 *
 *----------------------------------------------------------------------
 */

static int
ProcessPurgeObjCmd(
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_HashEntry *entry;
    Tcl_HashSearch search;
    ProcessInfo *info;
    int numPids;
    Tcl_Obj **pidObjs;
    int result;
    int i;
    int pid;

    if (objc != 1 && objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?pids?");
	return TCL_ERROR;
    }

    /*
     * First reap detached procs so that their purge flag is up-to-date.
     */

    Tcl_ReapDetachedProcs();

    if (objc == 1) {
	/*
	 * Purge all terminated processes.
	 */

	Tcl_MutexLock(&infoTablesMutex);
	for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); 
		entry != NULL; entry = Tcl_NextHashEntry(&search)) {
	    info = (ProcessInfo *) Tcl_GetHashValue(entry);
	    if (info->purge) {
		Tcl_DeleteHashEntry(entry);
		entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
		Tcl_DeleteHashEntry(entry);
		FreeProcessInfo(info);
	    }
	}
	Tcl_MutexUnlock(&infoTablesMutex);
    } else {
	/*
	 * Purge only provided processes.
	 */
	
	result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
	if (result != TCL_OK) {
	    return result;
	}
	Tcl_MutexLock(&infoTablesMutex);
	for (i = 0; i < numPids; i++) {
	    result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid);
	    if (result != TCL_OK) {
		Tcl_MutexUnlock(&infoTablesMutex);
		return result;
	    }

	    entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));
	    if (!entry) {
		/*
		 * Skip unknown process.
		 */
		
		continue;
	    }

	    info = (ProcessInfo *) Tcl_GetHashValue(entry);
	    if (info->purge) {
		Tcl_DeleteHashEntry(entry);
		entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
		Tcl_DeleteHashEntry(entry);
		FreeProcessInfo(info);
	    }
	}
	Tcl_MutexUnlock(&infoTablesMutex);
    }

    return TCL_OK;
}

/*----------------------------------------------------------------------
 *
 * ProcessAutopurgeObjCmd --
 *
 *	This function implements the 'tcl::process autopurge' Tcl command. 
 *	Refer to the user documentation for details on what it does.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Alters detached process handling by Tcl_ReapDetachedProcs().
 *
 *----------------------------------------------------------------------
 */

static int
ProcessAutopurgeObjCmd(
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    if (objc != 1 && objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?flag?");
	return TCL_ERROR;
    }

    if (objc == 2) {
	/*
	 * Set given value.
	 */
	
	int flag;
	int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag);
	if (result != TCL_OK) {
	    return result;
	}

	autopurge = !!flag;
    }

    /* 
     * Return current value. 
     */

    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitProcessCmd --
 *
 *	This procedure creates the "tcl::process" Tcl command. See the user
 *	documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
TclInitProcessCmd(
    Tcl_Interp *interp)		/* Current interpreter. */
{
    static const EnsembleImplMap processImplMap[] = {
	{"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
	{"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
	{"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
	{"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
	{NULL, NULL, NULL, NULL, NULL, 0}
    };
    Tcl_Command processCmd;

    if (infoTablesInitialized == 0) {
	Tcl_MutexLock(&infoTablesMutex);
	if (infoTablesInitialized == 0) {
	    Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS);
	    Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS);
	    infoTablesInitialized = 1;
	}
	Tcl_MutexUnlock(&infoTablesMutex);
    }

    processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap);
    Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0),
	    "process", 0);
    return processCmd;
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcessCreated --
 *
 *	Called when a child process has been created by Tcl.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Internal structures are updated with a new ProcessInfo.
 *
 *----------------------------------------------------------------------
 */

void
TclProcessCreated(
    Tcl_Pid pid)		/* Process id. */
{
    int resolvedPid;
    Tcl_HashEntry *entry, *entry2;
    int isNew;
    ProcessInfo *info;

    /*
     * Get resolved pid first.
     */

    resolvedPid = TclpGetPid(pid);

    Tcl_MutexLock(&infoTablesMutex);

    /*
     * Create entry in pid table.
     */

    entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew);
    if (!isNew) {
	/*
	 * Pid was reused, free old info and reuse structure.
	 */
	
	info = (ProcessInfo *) Tcl_GetHashValue(entry);
	entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, 
		INT2PTR(resolvedPid));
	if (entry2) Tcl_DeleteHashEntry(entry2);
	FreeProcessInfo(info);
    }

    /*
     * Allocate and initialize info structure.
     */

    info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo));
    InitProcessInfo(info, pid, resolvedPid);

    /*
     * Add entry to tables.
     */

    Tcl_SetHashValue(entry, info);
    entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid),
	    &isNew);
    Tcl_SetHashValue(entry, info);

    Tcl_MutexUnlock(&infoTablesMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcessWait --
 *
 *	Wait for process status to change.
 *
 * Results:
 *	TclProcessWaitStatus enum value.
 *
 * Side effects:
 *	Completed process info structures are purged immediately (autopurge on)
 *	or eventually (autopurge off).
 *
 *----------------------------------------------------------------------
 */

TclProcessWaitStatus
TclProcessWait(
    Tcl_Pid pid,		/* Process id. */
    int options,		/* Options passed to WaitProcessStatus. */
    int *codePtr,		/* If non-NULL, will receive either:
				 *  - 0 for normal exit.
				 *  - errno in case of error.
				 *  - non-zero exit code for abormal exit.
				 *  - signal number if killed or suspended.
				 *  - Tcl_WaitPid status in all other cases.
				 */
    Tcl_Obj **msgObjPtr,	/* If non-NULL, will receive error message. */
    Tcl_Obj **errorObjPtr)	/* If non-NULL, will receive error code. */
{
    Tcl_HashEntry *entry;
    ProcessInfo *info;
    TclProcessWaitStatus result;

    /*
     * First search for pid in table.
     */

    Tcl_MutexLock(&infoTablesMutex);
    entry = Tcl_FindHashEntry(&infoTablePerPid, pid);
    if (!entry) {
	/*
	 * Unknown process, just call WaitProcessStatus and return.
	 */
	
	result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, 
		msgObjPtr, errorObjPtr);
	if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr);
	if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr);
    Tcl_MutexUnlock(&infoTablesMutex);
	return result;
    }

    info = (ProcessInfo *) Tcl_GetHashValue(entry);
    if (info->purge) {
	/*
	 * Process has completed but TclProcessWait has already been called,
	 * so report no change.
	 */
    Tcl_MutexUnlock(&infoTablesMutex);
	
	return TCL_PROCESS_UNCHANGED;
    }

    RefreshProcessInfo(info, options);
    if (info->status == TCL_PROCESS_UNCHANGED) {
	/*
	 * No change, stop there.
	 */
    Tcl_MutexUnlock(&infoTablesMutex);
	
	return TCL_PROCESS_UNCHANGED;
    }

    /*
     * Set return values.
     */

    result = info->status;
    if (codePtr) *codePtr = info->code;
    if (msgObjPtr) *msgObjPtr = info->msg;
    if (errorObjPtr) *errorObjPtr = info->error;
    if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr);
    if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr);

    if (autopurge) {
	/*
	 * Purge now.
	 */

	Tcl_DeleteHashEntry(entry);
	entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, 
		INT2PTR(info->resolvedPid));
	Tcl_DeleteHashEntry(entry);
	FreeProcessInfo(info);
    } else {
	/*
	 * Eventually purge. Subsequent calls will return
	 * TCL_PROCESS_UNCHANGED.
	 */

	info->purge = 1;
    }
    Tcl_MutexUnlock(&infoTablesMutex);
    return result;
}