2012-09-19  Jan Nijtmans  <nijtmans@users.sf.net>

	* generic/tcl.h:  Make Tcl_Interp a fully opaque structure if
	TCL_NO_DEPRECATED is set (TIP 330 and 336).
	* win/nmakehlp.c: Let "nmakehlp -V" start searching digits after the
	found match (suggested by Harald Oehlmann).

2012-09-19  Harald Oehlmann  <oehhar@users.sf.net>

	IMPLEMENTATION OF TIP#412.

	* library/msgcat/msgcat.tcl:	dynamic locale change with mc file
	* library/clock.tcl:            load on locale change.
	clock uses new msgcat features.

2012-09-07  Harald Oehlmann  <oehhar@users.sf.net>

	*** 8.6b3 TAGGED FOR RELEASE ***

	IMPLEMENTATION OF TIP#404.

2015-02-20 (bug)[32b615] Fix compiled [lreplace] (lreplace-4.[345]) (aspect)

2015-03-10 (enhancement) Revise OS X notifier for better Cocoa (walzer)
        *** POTENTIAL INCOMPATIBILITY ***

--- Released 8.6.4, March 12, 2015 --- http://core.tcl.tk/tcl/ for details

2015-06-25 (TIP 412) msgcat dynamic locale change and package private locale (oehlmann)
=> msgcat 1.6.0

.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
msgcat \- Tcl message catalog
.SH SYNOPSIS
\fBpackage require Tcl 8.5\fR
.sp
\fBpackage require msgcat 1.6\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
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
.sp
\fB::msgcat::mcpreferences\fR
.sp
.VS "TIP 412"
\fB::msgcat::mcloadedlocales subcommand\fR ?\fIlocale\fR?
.VE "TIP 412"
.sp
\fB::msgcat::mcload \fIdirname\fR
.sp
\fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR?
.sp
\fB::msgcat::mcmset \fIlocale src-trans-list\fR
.sp

\fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR?
.sp
\fB::msgcat::mcflmset \fIsrc-trans-list\fR

.sp
\fB::msgcat::mcunknown \fIlocale src-string\fR ?\fIarg arg ...\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"
.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"
which is independent from the application, and
which can be edited or localized without modifying
the application source code.  New languages
or locales may be provided by adding a new file to
the message catalog.
.PP
\fBmsgcat\fR distinguises packages by its namespace.
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.
.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
additional arguments in the translation of \fIsrc-string\fR.
.RS
.PP
\fB::msgcat::mc\fR will search the messages defined
in the current namespace for a translation of \fIsrc-string\fR; if
none is found, it will search in the parent of the current namespace,

.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
\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR
.
.VS "TIP 412"
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).
.RE
.VE "TIP 412"
.TP
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
.
This function sets the locale to \fInewLocale\fR.  If \fInewLocale\fR
is omitted, the current locale is returned, otherwise the current locale
is set to \fInewLocale\fR.  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.
.RS
.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
.
Returns an ordered list of the locales preferred by
the user, based on the user's language specification.
The list is ordered from most specific to least
preference.  The list is derived from the current
locale set in msgcat by \fB::msgcat::mclocale\fR, and
cannot be set independently.  For example, if the
current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR
returns \fB{en_us_funky en_us en {}}\fR.
.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.
.PP
The subcommand \fBpresent\fR requires the argument \fIlocale\fR and returns true, if this locale is loaded.
.PP
The subcommand \fBclear\fR removes all locales and their data, which are not in the current preference list.
.RE
.TP
\fB::msgcat::mcload \fIdirname\fR
.
.VS "TIP 412"
Searches the specified directory for files that match
the language specifications returned by \fB::msgcat::mcloadedlocales get\fR
(or \fBmsgcat::mcpackagelocale preferences\fR if a package locale is set) (note that these are all lowercase), extended by the file extension
.QW .msg .
Each matching file is
read in order, assuming a UTF-8 encoding.  The file contents are
then evaluated as a Tcl script.  This means that Unicode characters
may be present in the message file either directly in their UTF-8
encoded form, or by use of the backslash-u quoting recognized by Tcl
evaluation.  The number of message files which matched the specification
and were loaded is returned.
.RS
.PP
In addition, the given folder is stored in the \fBmsgcat\fR package configuration option \fImcfolder\fR to eventually load message catalog files required by a locale change.
.VE "TIP 412"
.RE
.TP
\fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR?
.
Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR
in the specified \fIlocale\fR and the current namespace.  If
\fItranslate-string\fR is not specified, \fIsrc-string\fR is used
for both.  The function returns \fItranslate-string\fR.
.TP
\fB::msgcat::mcmset \fIlocale src-trans-list\fR
.
Sets the translation for multiple source strings in
\fIsrc-trans-list\fR in the specified \fIlocale\fR and the current
namespace.
\fIsrc-trans-list\fR must have an even number of elements and is in
the form {\fIsrc-string translate-string\fR ?\fIsrc-string
translate-string ...\fR?} \fB::msgcat::mcmset\fR can be significantly
faster than multiple invocations of \fB::msgcat::mcset\fR. The function
returns the number of translations set.
.TP
\fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR?

Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the
current namespace for the locale implied by the name of the message catalog
being loaded via \fB::msgcat::mcload\fR.  If \fItranslate-string\fR is not
specified, \fIsrc-string\fR is used for both.  The function returns
\fItranslate-string\fR.

.TP
\fB::msgcat::mcflmset \fIsrc-trans-list\fR

Sets the translation for multiple source strings in \fIsrc-trans-list\fR in
the current namespace for the locale implied by the name of the message
catalog being loaded via \fB::msgcat::mcload\fR. \fIsrc-trans-list\fR must
have an even number of elements and is in the form {\fIsrc-string
translate-string\fR ?\fIsrc-string translate-string ...\fR?}
\fB::msgcat::mcflmset\fR can be significantly faster than multiple invocations
of \fB::msgcat::mcflset\fR. The function returns the number of translations set.

.TP
\fB::msgcat::mcunknown \fIlocale src-string\fR ?\fIarg arg ...\fR?
.
This routine is called by \fB::msgcat::mc\fR in the case when
a translation for \fIsrc-string\fR is not defined in the
current locale.  The default action is to return
\fIsrc-string\fR passed by format if there are any arguments.  This
procedure can be redefined by the
application, for example to log error messages for each unknown
string.  The \fB::msgcat::mcunknown\fR procedure is invoked at the
same stack context as the call to \fB::msgcat::mc\fR.  The return value
of \fB::msgcat::mcunknown\fR is used as the return value for the call
to \fB::msgcat::mc\fR.
.VS "TIP 412"
.RS
.PP
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
.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
system-specific code, each separated by

.QW C .
.PP
When a locale is specified by the user, a
.QW "best match"
search is performed during string translation.  For example, if a user
specifies
en_GB_Funky, the locales
.QW en_gb_funky ,
.QW en_gb ,
.QW en
and
.MT
(the empty string)
are searched in order until a matching translation
string is found.  If no translation string is available, then
the unknown handler is called.
.SH "NAMESPACES AND MESSAGE CATALOGS"
.PP
Strings stored in the message catalog are stored relative
to the namespace from which they were added.  This allows
multiple packages to use the same strings without fear
of collisions with other packages.  It also allows the
source string to be shorter and less prone to typographical

formatting substitution is done directly.
.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 action is controled by the following ensemble:
.TP
\fB::msgcat::mcpackagelocale set\fR ?\fIlocale\fR?
.
Set or change a package private locale.
The package private locale is set to the given \fIlocale\fR if the \fIlocale\fR is given.
If the option \fIlocale\fR is not given, the package is set to package private locale mode, but no locale is changed (e.g. if the global locale was valid for the package before, it is copied to the package private locale).
.PP
.RS
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
.
Return the package private preferences or the global preferences,
if no package private locale is set.
.TP
\fB::msgcat::mcpackagelocale loaded\fR
.
Return the list of locales loaded for this package.
.TP
\fB::msgcat::mcpackagelocale isset\fR
.
Returns true, if a package private locale is set.
.TP
\fB::msgcat::mcpackagelocale unset\fR
.
Unset the package private locale and use the globale locale.
Load and remove locales to adjust the list of loaded locales for the
package to the global loaded locales list.
.TP
\fB::msgcat::mcpackagelocale present\fR \fIlocale\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
.
Return the current value of the given \fIoption\fR.
This call returns an error if the option is not set for the package.
.TP
\fB::msgcat::mcpackageconfig isset\fR \fIoption\fR
.
Returns 1, if the given \fIoption\fR is set for the package, 0 otherwise.
.TP
\fB::msgcat::mcpackageconfig set\fR \fIoption\fR \fIvalue\fR
.
Set the given \fIoption\fR to the given \fIvalue\fR.
This may invoke additional actions in dependency of the \fIoption\fR.
The return value is 0 or the number of loaded packages for the option \fBmcfolder\fR.
.TP
\fB::msgcat::mcpackageconfig unset\fR \fIoption\fR
.
Unsets the given \fIoption\fR for the package.
No action is taken if the \fIoption\fR is not set for the package.
The empty string is returned.
.SS Package options
.PP
The following package options are available for each package:
.TP
\fBmcfolder\fR
.
This is the message folder of the package. This option is set by mcload and by the subcommand set. Both are identical and both return the number of loaded message catalog files.
.RS
.PP
Setting or changing this value will load all locales contained in the preferences valid for the package. This implies also to invoke any set loadcmd (see below).
.PP
Unsetting this value will disable message file load for the package.
.RE
.TP
\fBloadcmd\fR
.
This callback is invoked before a set of message catalog files are loaded for the package which has this property set.
.PP
.RS
This callback may be used to do any preparation work for message file load or to get the message data from another source like a data base. In this case, no message files are used (mcfolder is unset).
.PP
See section \fBcallback invocation\fR below.
The parameter list appended to this callback is the list of locales to load.
.PP
If this callback is changed, it is called with the preferences valid for the package.
.RE
.TP
\fBchangecmd\fR
.
This callback is invoked when a default local change was performed. Its purpose is to allow a package to update any dependency on the default locale like showing the GUI in another language.
.PP
.RS
See the callback invocation section below.
The parameter list appended to this callback is \fBmcpreferences\fR.
The registered callbacks are invoked in no particular order.
.RE
.TP
\fBunknowncmd\fR
.
Use a package locale mcunknown procedure instead of the standard version supplied by the msgcat package (msgcat::mcunknown).
.PP
.RS
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
.SS 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
.SS 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 {
        puts "New locale is '[lindex $args 0]'."
    }
}
% msgcat::mclocale fr
fr
% New locale is 'fr'.
.CE
.PP
If locales (or additional locales) are contained in another source like a data base, a package may use the load callback and not mcload:
.CS
namespace eval db {
    msgcat::mcpackageconfig loadcmd loadMessages

    proc loadMessages args {
        foreach locale $args {
            if {[LocaleInDB $locale]} {
                msgcat::mcmset $locale [GetLocaleList $locale]
            }
        }
    }
}
.CE
.PP
The \fBclock\fR command implementation uses \fBmsgcat\fR with a package locale to implement the command line parameter \fB-locale\fR.
Here are some sketches of the implementation:
.PP
First, a package locale is initialized and the generic unknown function is desactivated:
.CS
msgcat::mcpackagelocale set
msgcat::mcpackageconfig unknowncmd ""
.CE
As an example, the user requires the week day in a certain locale as follows:
.CS
clock format clock seconds -format %A -locale fr
.CE
\fBclock\fR sets the package locale to \fBfr\fR and looks for the day name as follows:
.CS
msgcat::mcpackagelocale set $locale
return [lindex [msgcat::mc DAYS_OF_WEEK_FULL] $day]
### Returns "mercredi"
.CE
Within \fBclock\fR, some message-catalog items are heavy in computation and thus are dynamically cached using:
.CS
proc ::tcl::clock::LocalizeFormat { locale format } {
    set key FORMAT_$format
    if { [::msgcat::mcexists -exactlocale -exactnamespace $key] } {
        return [mc $key]
    }
    #...expensive computation of format clipped...
    mcset $locale $key $format
    return $format
}
.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)
.SH KEYWORDS
internationalization, i18n, localization, l10n, message, text, translation
.\" Local Variables:
.\" mode: nroff
.\" End:

    const Tcl_ObjType *typePtr;	/* Denotes the object's type. Always
				 * corresponds to the type of the object's
				 * internal rep. NULL indicates the object has
				 * no internal rep (has no type). */
    union {			/* The internal representation: */
	long longValue;		/*   - an long integer value. */
	double doubleValue;	/*   - a double-precision floating value. */
	void *otherValuePtr;	/*   - another, type-specific value,
	                       not used internally any more. */
	Tcl_WideInt wideValue;	/*   - a long long value. */
	struct {		/*   - internal rep as two pointers.
				 *     the main use of which is a bignum's
				 *     tightly packed fields, where the alloc,
				 *     used and signum flags are packed into
				 *     ptr2 with everything else hung off ptr1. */
	    void *ptr1;
	    void *ptr2;
	} twoPtrValue;
	struct {		/*   - internal rep as a pointer and a long,




	                       not used internally any more. */
	    void *ptr;
	    unsigned long value;
	} ptrAndLongRep;
    } internalRep;
} Tcl_Obj;

/*

     * Decrement refCount AFTER checking it for 0 or 1 (<2), because
     * we cannot assume anymore that refCount is a signed type; In
     * Tcl8 it was but in Tcl9 it is subject to change.
     */
#   define Tcl_DecrRefCount(objPtr) \
	do { \
	    Tcl_Obj *_objPtr = (objPtr); \
	    if ((_objPtr)->refCount-- <= 1) { \
		TclFreeObj(_objPtr); \
	    } \
	} while(0)
#   define Tcl_IsShared(objPtr) \
	((objPtr)->refCount > 1)
#endif

    TclInvalidateNsPath(nsPtr);
    if (!isNew) {
	cmdPtr = Tcl_GetHashValue(hPtr);

	/* Command already exists. */

	/*
	 * [***] This is wrong.  See Tcl Bug a16752c252.
	 * However, this buggy behavior is kept under particular
	 * circumstances to accommodate deployed binaries of the
	 * "tclcompiler" program. http://sourceforge.net/projects/tclpro/
	 * that crash if the bug is fixed.
	 */

	if (cmdPtr->objProc == TclInvokeStringCommand

	 * Now delete these traces.
	 */

	tracePtr = cmdPtr->tracePtr;
	while (tracePtr != NULL) {
	    CommandTrace *nextPtr = tracePtr->nextPtr;

	    if (tracePtr->refCount-- <= 1) {
		ckfree(tracePtr);
	    }
	    tracePtr = nextPtr;
	}
	cmdPtr->tracePtr = NULL;
    }

	tracePtr->refCount++;
	if (state == NULL) {
	    state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, TCL_OK);
	}
	tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr,
		oldName, newName, flags);
	cmdPtr->flags &= ~tracePtr->flags;
	if (tracePtr->refCount-- <= 1) {
	    ckfree(tracePtr);
	}
    }

    if (state) {
	Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state);
    }

{
    Interp *iPtr = (Interp *) interp;

    /*
     * data[1] stores a marker for use by tailcalls; it will be set to 1 by
     * command redirectors (imports, alias, ensembles) so that tailcall skips
     * this callback (that marks the end of the target command) and goes back
     * to the end of the source command.
     */

    if (iPtr->deferredCallbacks) {
        iPtr->deferredCallbacks = NULL;
    } else {
	TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
    }

    Command *cmdPtr = NULL, *preCmdPtr = data[0];
    int flags = PTR2INT(data[1]);
    int objc = PTR2INT(data[2]);
    Tcl_Obj **objv = data[3];
    Interp *iPtr = (Interp *) interp;
    Namespace *lookupNsPtr = NULL;
    int enterTracesDone = 0;

    /*
     * Push records for task to be done on return, in INVERSE order. First, if
     * needed, the exception handlers (as they should happen last).
     */

    if (!(flags & TCL_EVAL_NOERR)) {
	TEOV_PushExceptionHandlers(interp, objc, objv, flags);

	    if (cmdPtr == NULL) {
		enterTracesDone = 1;
		Tcl_DecrRefCount(commandPtr);
		goto reresolve;
	    }
	}

	/*
	 * Schedule leave traces.  Raise the refCount on the resolved
	 * cmdPtr, so that when it passes to the leave traces we know
	 * it's still valid.
	 */

	cmdPtr->refCount++;
	TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc),

    Interp *iPtr = (Interp *) interp;

    iPtr->numLevels--;

     /*
      * If there is a tailcall, schedule it next
      */

    if (data[1] && (data[1] != INT2PTR(1))) {
        TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL);
    }

    /* OPT ??
     * Do not interrupt a series of cleanups with async or limit checks:
     * just check at the end?

     *
     * objc is the number of elements getting invoked.
     *
     * If they are not the same, we arrived here by compiling an
     * ensemble dispatch.  Ensemble subcommands that lead to script
     * evaluation are not supposed to get compiled, because a command
     * such as [info level] in the script can expose some of the dispatch
     * shenanigans.  This means that we don't have to tend to the
     * housekeeping, and can escape now.
     */

    if (ePtr->nline != objc) {
        return;
    }

    /*
     * Having disposed of the ensemble cases, we can state...
     * A few truths ...

 *
 *	Execute Tcl commands stored in a Tcl object. These commands are
 *	compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is
 *	specified.
 *
 *	If the flag TCL_EVAL_DIRECT is passed in, the value of invoker
 *	must be NULL.  Support for non-NULL invokers in that mode has
 *	been removed since it was unused and untested.  Failure to
 *	follow this limitation will lead to an assertion panic.
 *
 * Results:
 *	The return value is one of the return codes defined in tcl.h (such as
 *	TCL_OK), and the interpreter's result contains a value to supplement
 *	the return code.
 *

 *   will execute. There are functions whose purpose is to help define the
 *   precise spot:
 *     TclMarkTailcall: if the NEXT command to be pushed tailcalls, execution
 *         should continue right here
 *     TclSkipTailcall:  if the NEXT command to be pushed tailcalls, execution
 *         should continue after the CURRENT command is fully returned ("skip
 *         the next command: we are redirecting to it, tailcalls should run
 *         after WE return")
 *     TclPushTailcallPoint: the search for a tailcalling spot cannot traverse
 *         this point. This is special for OO, as some of the oo constructs
 *         that behave like commands may not push an NRCommand callback.
 */

void
TclMarkTailcall(

    if (objc > 1) {
        Tcl_Obj *listPtr, *nsObjPtr;
        Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
        Tcl_Namespace *ns1Ptr;

        /* The tailcall data is in a Tcl list: the first element is the
         * namespace, the rest the command to be tailcalled. */

        listPtr = Tcl_NewListObj(objc, objv);

        nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
        if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
                || (nsPtr != ns1Ptr)) {
            Tcl_Panic("Tailcall failed to find the proper namespace");
        }
 	TclListObjSetElement(interp, listPtr, 0, nsObjPtr);

        iPtr->varFramePtr->tailcallPtr = listPtr;
    }
    return TCL_RETURN;
}


/*

{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *listPtr = data[0], *nsObjPtr;
    Tcl_Namespace *nsPtr;
    int objc;
    Tcl_Obj **objv;

    Tcl_ListObjGetElements(interp, listPtr, &objc, &objv);
    nsObjPtr = objv[0];

    if (result == TCL_OK) {
	result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
    }

    if (result != TCL_OK) {
        /*
         * Tailcall execution was preempted, eg by an intervening catch or by

static void
FreeByteCodeInternalRep(
    register Tcl_Obj *objPtr)	/* Object whose internal rep to free. */
{
    register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;

    objPtr->typePtr = NULL;

    if (codePtr->refCount-- <= 1) {
	TclCleanupByteCode(codePtr);
    }
}

/*
 *----------------------------------------------------------------------
 *

	if (hePtr) {
	    ReleaseCmdWordData(Tcl_GetHashValue(hePtr));
	    Tcl_DeleteHashEntry(hePtr);
	}
    }

    if (codePtr->localCachePtr && (codePtr->localCachePtr->refCount-- <= 1)) {
	TclFreeLocalCache(interp, codePtr->localCachePtr);
    }

    TclHandleRelease(codePtr->interpHandle);
    ckfree(codePtr);
}


{
    Interp *iPtr = (Interp *) interp;
    ByteCode *codePtr = NULL;

    if (objPtr->typePtr == &substCodeType) {
	Namespace *nsPtr = iPtr->varFramePtr->nsPtr;

	codePtr = objPtr->internalRep.twoPtrValue.ptr1;
	if (flags != PTR2INT(objPtr->internalRep.twoPtrValue.ptr2)
		|| ((Interp *) *codePtr->interpHandle != iPtr)
		|| (codePtr->compileEpoch != iPtr->compileEpoch)
		|| (codePtr->nsPtr != nsPtr)
		|| (codePtr->nsEpoch != nsPtr->resolverEpoch)
		|| (codePtr->localCachePtr !=
		iPtr->varFramePtr->localCachePtr)) {
	    FreeSubstCodeInternalRep(objPtr);

	TclEmitOpcode(INST_DONE, &compEnv);
	TclInitByteCodeObj(objPtr, &compEnv);
	objPtr->typePtr = &substCodeType;
	TclFreeCompileEnv(&compEnv);

	codePtr = objPtr->internalRep.twoPtrValue.ptr1;
	objPtr->internalRep.twoPtrValue.ptr1 = codePtr;
	objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(flags);
	if (iPtr->varFramePtr->localCachePtr) {
	    codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
	    codePtr->localCachePtr->refCount++;
	}
#ifdef TCL_COMPILE_DEBUG
	if (tclTraceCompile >= 2) {
	    TclPrintByteCodeObj(interp, objPtr);

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

static void
FreeSubstCodeInternalRep(
    register Tcl_Obj *objPtr)	/* Object whose internal rep to free. */
{
    register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;

    objPtr->typePtr = NULL;

    if (codePtr->refCount-- <= 1) {
	TclCleanupByteCode(codePtr);
    }
}

static void
ReleaseCmdWordData(
    ExtCmdLoc *eclPtr)

    register CompileEnv *envPtr)/* Points to the CompileEnv structure. */
{
    if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets){
	ckfree(envPtr->localLitTable.buckets);
	envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets;
    }
    if (envPtr->iPtr) {
	/*
	 * We never converted to Bytecode, so free the things we would
	 * have transferred to it.
	 */

	int i;
	LiteralEntry *entryPtr = envPtr->literalArrayPtr;
	AuxData *auxDataPtr = envPtr->auxDataArrayPtr;

    Tcl_Obj *cmdObj,
    int numWords,
    CompileEnv *envPtr)
{
    int wordIdx = 0;
    DefineLineInformation;
    int depth = TclGetStackDepth(envPtr);

    StartExpanding(envPtr);
    if (cmdObj) {
	CompileCmdLiteral(interp, cmdObj, envPtr);
	wordIdx = 1;
	tokenPtr = TokenAfter(tokenPtr);
    }

     * prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general.
     */

    TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx);
    TclCheckStackDepth(depth+1, envPtr);
}

static int
CompileCmdCompileProc(
    Tcl_Interp *interp,
    Tcl_Parse *parsePtr,
    Command *cmdPtr,
    CompileEnv *envPtr)
{
    int unwind = 0, incrOffset = -1;

    int cmdKnown, expand = -1;
    int *wlines, wlineat;
    int cmdLine = envPtr->line;
    int *clNext = envPtr->clNext;
    int cmdIdx = envPtr->numCommands;
    int startCodeOffset = envPtr->codeNext - envPtr->codeStart;
    int depth = TclGetStackDepth(envPtr);

    assert (parsePtr->numWords > 0);

    /* Pre-Compile */

    envPtr->numCommands++;
    EnterCmdStartData(envPtr, cmdIdx,
	    parsePtr->commandStart - envPtr->source, startCodeOffset);

{
    va_list argList;
    ExceptionRange *rangePtr;
    ExceptionAux *auxBreakPtr, *auxContinuePtr;
    int arg1, arg2, wordCount = 0, expandCount = 0;
    int loopRange = 0, breakRange = 0, continueRange = 0;
    int cleanup, depth = TclGetStackDepth(envPtr);

    /*
     * Parse the arguments.
     */

    va_start(argList, opcode);
    switch (opcode) {
    case INST_INVOKE_STK1:

		ckfree(errPtr);
	    }
	} else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) {
	    Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);

	    if (errChannel != NULL) {
		Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
		Tcl_Obj *keyPtr, *valuePtr = NULL;

		TclNewLiteralStringObj(keyPtr, "-errorinfo");
		Tcl_IncrRefCount(keyPtr);
		Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
		Tcl_DecrRefCount(keyPtr);

		Tcl_WriteChars(errChannel,

    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *keyPtr, *valuePtr;
    Tcl_Obj *tempObjv[2];
    int result, code, level;
    Tcl_InterpState saved;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "msg options");
	return TCL_ERROR;
    }

    /*
     * Check for a valid return options dictionary.
     */

    TclNewLiteralStringObj(keyPtr, "-level");
    Tcl_IncrRefCount(keyPtr);
    result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
    Tcl_DecrRefCount(keyPtr);
    if (result != TCL_OK || valuePtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"missing return option \"-level\"", -1));
	Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
	return TCL_ERROR;
    }
    if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) {
	return TCL_ERROR;
    }
    TclNewLiteralStringObj(keyPtr, "-code");
    Tcl_IncrRefCount(keyPtr);
    result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
    Tcl_DecrRefCount(keyPtr);
    if (result != TCL_OK || valuePtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"missing return option \"-code\"", -1));
	Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
	return TCL_ERROR;
    }
    if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) {
	return TCL_ERROR;

    if (code != TCL_ERROR) {
	Tcl_SetObjResult(interp, tempObjv[1]);
    }

    TclNewLiteralStringObj(keyPtr, "-errorcode");
    Tcl_IncrRefCount(keyPtr);
    result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
    Tcl_DecrRefCount(keyPtr);
    if (result == TCL_OK && valuePtr != NULL) {
	Tcl_SetObjErrorCode(interp, valuePtr);
    }

    TclNewLiteralStringObj(keyPtr, "-errorinfo");
    Tcl_IncrRefCount(keyPtr);
    result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
    Tcl_DecrRefCount(keyPtr);
    if (result == TCL_OK && valuePtr != NULL) {
	Tcl_AppendObjToErrorInfo(interp, valuePtr);
    }

    if (code == TCL_ERROR) {
	Tcl_SetObjResult(interp, tempObjv[1]);
    }

    } while (0)

#define PUSH_TAUX_OBJ(objPtr) \
    do {							\
	if (auxObjList) {					\
	    objPtr->length += auxObjList->length;		\
	}							\
	objPtr->internalRep.twoPtrValue.ptr1 = auxObjList;	\
	auxObjList = objPtr;					\
    } while (0)

#define POP_TAUX_OBJ() \
    do {							\
	tmpPtr = auxObjList;					\
	auxObjList = tmpPtr->internalRep.twoPtrValue.ptr1;	\
	Tcl_DecrRefCount(tmpPtr);				\
    } while (0)

/*
 * These variable-access macros have to coincide with those in tclVar.c
 */

     */

    if (move) {
	moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1;
    }
    needed = growth + moveWords + WALLOCALIGN;


    /*
     * Check if there is enough room in the next stack (if there is one, it
     * should be both empty and the last one!)
     */

    if (esPtr->nextPtr) {
	oldPtr = esPtr;

    newElems = 2*currElems;
    while (needed > newElems) {
	newElems *= 2;
    }
#else
    newElems = needed;
#endif

    newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);

    oldPtr = esPtr;
    esPtr = ckalloc(newBytes);

    oldPtr->nextPtr = esPtr;
    esPtr->prevPtr = oldPtr;

static void
FreeExprCodeInternalRep(
    Tcl_Obj *objPtr)
{
    ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;

    objPtr->typePtr = NULL;

    if (codePtr->refCount-- <= 1) {
	TclCleanupByteCode(codePtr);
    }
}

/*
 *----------------------------------------------------------------------
 *

     */

    Tcl_Obj **tosPtr;		/* Cached pointer to top of evaluation
				 * stack. */
    const unsigned char *pc = data[1];
                                /* The current program counter. */
    unsigned char inst;         /* The currently running instruction */

    /*
     * Transfer variables - needed only between opcodes, but not while
     * executing an instruction.
     */

    int cleanup = PTR2INT(data[2]);
    Tcl_Obj *objResultPtr;

     * [http://www.cs.toronto.edu/syslab/pubs/tcl2005-vitale-zaleski.pdf]
     * Resolving them before the switch reduces the cost of branch
     * mispredictions, seems to improve runtime by 5% to 15%, and (amazingly!)
     * reduces total obj size.
     */

    inst = *pc;

    peepholeStart:
#ifdef TCL_COMPILE_STATS
    iPtr->stats.instructionCount[*pc]++;
#endif

#ifdef TCL_COMPILE_DEBUG
    /*
     * Skip the stack depth check if an expansion is in progress.
     */

    CHECK_STACK();
    if (traceInstructions) {
	fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH);
	TclPrintInstruction(codePtr, pc);
	fflush(stdout);
    }
#endif /* TCL_COMPILE_DEBUG */

    TCL_DTRACE_INST_NEXT();

    if (inst == INST_LOAD_SCALAR1) {
	goto instLoadScalar1;
    } else if (inst == INST_PUSH1) {
	PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
	TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc+1)), OBJ_AT_TOS);
	inst = *(pc += 2);
	goto peepholeStart;
    } else if (inst == INST_START_CMD) {
	/*
	 * Peephole: do not run INST_START_CMD, just skip it
	 */

	iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
	if (checkInterp) {
	    checkInterp = 0;
	    if (((codePtr->compileEpoch != iPtr->compileEpoch) ||
		 (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) &&
		!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
		goto instStartCmdFailed;
	    }
	}
	inst = *(pc += 9);
	goto peepholeStart;
    } else if (inst == INST_NOP) {
#ifndef TCL_COMPILE_DEBUG
	while (inst == INST_NOP)
#endif
	{
	    inst = *++pc;
	}
	goto peepholeStart;
    }

    switch (inst) {
    case INST_SYNTAX:
    case INST_RETURN_IMM: {
	int code = TclGetInt4AtPtr(pc+1);
	int level = TclGetUInt4AtPtr(pc+5);

	/*

	iPtr->execEnvPtr = corPtr->eePtr;
	yieldParameter = (PTR2INT(NULL)+1);	/*==CORO_ACTIVATE_YIELDM*/

    doYield:
	/* TIP #280: Record the last piece of info needed by
	 * 'TclGetSrcInfoForPc', and push the frame.
	 */

	bcFramePtr->data.tebc.pc = (char *) pc;
	iPtr->cmdFramePtr = bcFramePtr;

	if (iPtr->flags & INTERP_DEBUG_FRAME) {
	    ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
	}

	 * we do not define a special tclObjType for it. It is not dangerous
	 * as the obj is never passed anywhere, so that all manipulations are
	 * performed here and in INST_INVOKE_EXPANDED (in case of an expansion
	 * error, also in INST_EXPAND_STKTOP).
	 */

	TclNewObj(objPtr);
	objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(CURR_DEPTH);
	objPtr->length = 0;
	PUSH_TAUX_OBJ(objPtr);
	TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH));
	NEXT_INST_F(1, 0, 0);

    case INST_EXPAND_DROP:
	/*
	 * Drops an element of the auxObjList, popping stack elements to
	 * restore the stack to the state before the point where the aux
	 * element was created.
	 */

	CLANG_ASSERT(auxObjList);
	objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2);
	POP_TAUX_OBJ();
#ifdef TCL_COMPILE_DEBUG
	/* Ugly abuse! */
	starting = 1;
#endif
	TRACE(("=> drop %d items\n", objc));
	NEXT_INST_V(1, objc, 0);

	cleanup = 1;
	pc += 1;
	TEBC_YIELD();
	return TclNREvalObjEx(interp, OBJ_AT_TOS, 0, NULL, 0);

    case INST_INVOKE_EXPANDED:
	CLANG_ASSERT(auxObjList);
	objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2);
	POP_TAUX_OBJ();
	if (objc) {
	    pcAdjustment = 1;
	    goto doInvocation;
	}

	/*

		     * refers to the about-to-be-invalidated UTF-8 rep. This
		     * sets the 'allocated' field of the String structure to 0
		     * to indicate that a new buffer needs to be allocated.
		     * This is safe; we know we've got a tclStringTypePtr set
		     * at this point (post Tcl_GetUnicodeFromObj).
		     */

		    ((int *) objResultPtr->internalRep.twoPtrValue.ptr1)[1] = 0;
		}
		Tcl_InvalidateStringRep(objResultPtr);
		TclDecrRefCount(value3Ptr);
		TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
		NEXT_INST_F(1, 1, 1);
	    } else {
		if (TclIsPureByteArray(valuePtr)

		     * refers to the about-to-be-invalidated UTF-8 rep. This
		     * sets the 'allocated' field of the String structure to 0
		     * to indicate that a new buffer needs to be allocated.
		     * This is safe; we know we've got a tclStringTypePtr set
		     * at this point (post Tcl_GetUnicodeFromObj).
		     */

		    ((int *) objResultPtr->internalRep.twoPtrValue.ptr1)[1] = 0;
		}
		Tcl_InvalidateStringRep(valuePtr);
		TclDecrRefCount(value3Ptr);
		TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
		NEXT_INST_F(1, 0, 0);
	    }
	}

	/*
	 * Store a pointer to the ForeachInfo struct; same dirty trick
	 * as above
	 */

	TclNewObj(tmpPtr);
	tmpPtr->internalRep.twoPtrValue.ptr1 = infoPtr;
	PUSH_OBJECT(tmpPtr); /* infoPtr object */
	TRACE_APPEND(("jump to loop step\n"));

	/*
	 * Jump directly to the INST_FOREACH_STEP instruction; the C code just
	 * falls through.
	 */

	pc += 5 - infoPtr->loopCtTemp;

    case INST_FOREACH_STEP:
	/*
	 * "Step" a foreach loop (i.e., begin its next iteration) by assigning
	 * the next value list element to each loop var.
	 */

	tmpPtr = OBJ_AT_TOS;
	infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1;
	numLists = infoPtr->numLists;
	TRACE(("=> "));

	tmpPtr = OBJ_AT_DEPTH(1);
	iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1);
	iterMax = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr2);

	 */
	pc++;
#endif

    case INST_FOREACH_END:
	/* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */
	tmpPtr = OBJ_AT_TOS;
	infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1;
	numLists = infoPtr->numLists;
	TRACE(("=> loop terminated\n"));
	NEXT_INST_V(1, numLists+2, 0);

    case INST_LMAP_COLLECT:
	/*
	 * This instruction is only issued by lmap. The stack is:
	 *   - result
	 *   - infoPtr
	 *   - loop counters
	 *   - valLists
	 *   - collecting obj (unshared)
	 * The instruction lappends the result to the collecting obj.
	 */

	tmpPtr = OBJ_AT_DEPTH(1);
	infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1;
	numLists = infoPtr->numLists;
	TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists));

	objPtr = OBJ_AT_DEPTH(3 + numLists);
	Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS);
	NEXT_INST_F(1, 1, 0);
    }

    case INST_BEGIN_CATCH4:
	/*

	 * Clear all expansions that may have started after the last
	 * INST_BEGIN_CATCH.
	 */

	while (auxObjList) {
	    if ((catchTop != initCatchTop)
		    && (*catchTop > (ptrdiff_t)
			auxObjList->internalRep.twoPtrValue.ptr2)) {
		break;
	    }
	    POP_TAUX_OBJ();
	}

	/*
	 * We must not catch if the script in progress has been canceled with

		    (unsigned) CURR_DEPTH, (unsigned) 0);
	    Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top");
	}
	CLANG_ASSERT(bcFramePtr);
    }

    iPtr->cmdFramePtr = bcFramePtr->nextPtr;
    if (codePtr->refCount-- <= 1) {
	TclCleanupByteCode(codePtr);
    }
    TclStackFree(interp, TD);	/* free my stack */

    return result;

    /*

	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;
	const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL);

	fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)",
		stackTop, relativePc, stackUpperBound);
	if (cmd != NULL) {

    int *lengthPtr,		/* If non-NULL, the location where the length
				 * of the command's source should be stored.
				 * If NULL, no length is stored. */
    const unsigned char **pcBeg,/* If non-NULL, the bytecode location
				 * where the current instruction starts.
				 * If NULL; no pointer is stored. */
    int *cmdIdxPtr)		/* If non-NULL, the location where the index
				 * of the command containing the pc should
				 * be stored. */
{
    register int pcOffset = (pc - codePtr->codeStart);
    int numCmds = codePtr->numCommands;
    unsigned char *codeDeltaNext, *codeLengthNext;
    unsigned char *srcDeltaNext, *srcLengthNext;
    int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;

	 * Tcl_GetAssocData to get the channel table, which might already be
	 * inaccessible from the interpreter structure. Instead, we emulate
	 * the behavior of Tcl_UnregisterChannel directly here.
	 */

	Tcl_DeleteHashEntry(hPtr);
	SetFlag(statePtr, CHANNEL_TAINTED);

	if (statePtr->refCount-- <= 1) {
	    if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
		(void) Tcl_Close(interp, (Tcl_Channel) chanPtr);
	    }
	}

    }
    Tcl_DeleteHashTable(hTblPtr);

    Tcl_Channel chan)
{
    Channel *chanPtr = (Channel *) chan;

    if (chanPtr->refCount == 0) {
	Tcl_Panic("Channel released more than preserved");
    }
    if (chanPtr->refCount-- > 1) {
	return;
    }
    if (chanPtr->typePtr == NULL) {
	ckfree(chanPtr);
    }
}

    bufPtr->refCount++;
}

static void
ReleaseChannelBuffer(
    ChannelBuffer *bufPtr)
{
    if (bufPtr->refCount-- > 1) {
	return;
    }
    ckfree(bufPtr);
}

static int
IsShared(

     * First check that there are bytes in it.  If so then...
     * If the output queue is empty, then yes, trusting the caller called
     * us only when written bytes ought to be flushed.
     * If the current output buffer is full, then yes, so we can meet
     * the post-condition that on a successful return to caller we've
     * left space in the current output buffer for more writing (the flush
     * call was to make new room).
     * If the channel is blocking, then yes, so we guarantee that
     * blocking flushes actually flush all pending data.
     * Otherwise, no.  Keep the current output buffer where it is so more
     * can be written to it, possibly filling it, to promote more efficient
     * buffer usage.
     */

    bufPtr = statePtr->curOutPtr;

	    ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
	    ChanWatch(chanPtr, statePtr->interestMask);
	} else {

	    /*
	     * When we are calledFromAsyncFlush, that means a writable
	     * state on the channel triggered the call, so we should be
	     * able to write something.  Either we did write something
	     * and wroteSome should be set, or there was nothing left to
	     * write in this call, and we've completed the BG flush.
	     * These are the two cases above.  If we get here, that means
	     * there is some kind failure in the writable event machinery.
	     *
	     * The tls extension indeed suffers from flaws in its channel
	     * event mgmt.  See http://core.tcl.tk/tcl/info/c31ca233ca.

	ChannelBuffer *bufPtr;
	char *dst, safe[BUFFER_PADDING];
	int result, srcRead, dstLen, dstWrote, srcLimit = srcLen;

	if (nextNewLine) {
	    srcLimit = nextNewLine - src;
	}

	/* Get space to write into */
	bufPtr = statePtr->curOutPtr;
	if (bufPtr == NULL) {
	    bufPtr = AllocChannelBuffer(statePtr->bufSize);
	    statePtr->curOutPtr = bufPtr;
	}
	if (saved) {

	result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit,
		statePtr->outputEncodingFlags,
		&statePtr->outputEncodingState, dst,
		dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);

	/* See chan-io-1.[89]. Tcl Bug 506297. */
	statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;

	if ((result != TCL_OK) && (srcRead + dstWrote == 0)) {
	    /* We're reading from invalid/incomplete UTF-8 */
	    ReleaseChannelBuffer(bufPtr);
	    if (total == 0) {
		Tcl_SetErrno(EINVAL);
		return -1;
	    }

		nl = crln;
		nlLen = 2;
		break;
	    default:
		Tcl_Panic("unknown output translation requested");
		break;
	    }

	    result |= Tcl_UtfToExternal(NULL, encoding, nl, nlLen,
		statePtr->outputEncodingFlags,
		&statePtr->outputEncodingState, dst,
		dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);

	    assert (srcRead == nlLen);

    int copied, copiedNow, result;
    Tcl_Encoding encoding = statePtr->encoding;
    int binaryMode;
#define UTF_EXPANSION_FACTOR	1024
    int factor = UTF_EXPANSION_FACTOR;

    binaryMode = (encoding == NULL)
	    && (statePtr->inputTranslation == TCL_TRANSLATE_LF)
	    && (statePtr->inEofChar == '\0');

    if (appendFlag == 0) {
	if (binaryMode) {
	    Tcl_SetByteArrayLength(objPtr, 0);
	} else {
	    Tcl_SetObjLength(objPtr, 0);

    int toRead = ((charsToRead<0)||(charsToRead > srcLen)) ? srcLen : charsToRead;

    /*
     * 'factor' is how much we guess that the bytes in the source buffer will
     * expand when converted to UTF-8 chars. This guess comes from analyzing
     * how many characters were produced by the previous pass.
     */

    int factor = *factorPtr;
    int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR;

    (void) TclGetStringFromObj(objPtr, &numBytes);
    Tcl_AppendToObj(objPtr, NULL, dstLimit);
    if (toRead == srcLen) {
	unsigned int size;

     * perform transformations and copies multiple times to achieve
     * a consistent set of results.  This takes the shape of a loop.
     */

    while (1) {
	int dstDecoded, dstRead, dstWrote, srcRead, numChars, code;
	int flags = statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE;

	if (charsToRead > 0) {
	    flags |= TCL_ENCODING_CHAR_LIMIT;
	    numChars = charsToRead;
	}

	/*
	 * Perform the encoding transformation.  Read no more than

	     * next.  So why do we only have the one decoded char?
	     */

	    if (code != TCL_OK) {
		char buffer[TCL_UTF_MAX + 1];
		int read, decoded, count;

		/*
		 * Didn't get everything the buffer could offer
		 */

		statePtr->flags = savedFlags;
		statePtr->inputEncodingFlags = savedIEFlags;
		statePtr->inputEncodingState = savedState;

	     */

	    dstRead = numChars;

	    /* FALL THROUGH - get more data (dstWrote == 0) */
	}

	/*
	 * The translation transformation can only reduce the number
	 * of chars when it converts \r\n into \n.  The reduction in
	 * the number of chars is the difference in bytes read and written.
	 */

	numChars -= (dstRead - dstWrote);

	if (charsToRead > 0 && numChars > charsToRead) {

	    /*
	     * TODO: This cannot happen anymore.
	     *
	     * We read more chars than allowed.  Reset limits to
	     * prevent that and try again.  Don't forget the extra
	     * padding of TCL_UTF_MAX bytes demanded by the
	     * Tcl_ExternalToUtf() call!
	     */

	if (dstWrote == 0) {
	    ChannelBuffer *nextPtr;

	    /* We were not able to read any chars. */

	    assert (numChars == 0);

	    /*
	     * There is one situation where this is the correct final
	     * result.  If the src buffer contains only a single \n
	     * byte, and we are in TCL_TRANSLATE_AUTO mode, and
	     * when the translation pass was made the INPUT_SAW_CR
	     * flag was set on the channel.  In that case, the
	     * correct behavior is to consume that \n and produce the
	     * empty string.

 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static void
TranslateInputEOL(
    ChannelState *statePtr,	/* Channel being read, for EOL translation and
				 * EOF character. */
    char *dstStart,		/* Output buffer filled with chars by applying
				 * appropriate EOL translation to source
				 * characters. */
    const char *srcStart,	/* Source characters. */

	goto done;
    }
    statePtr->flags = flags;

    /*
     * Clear the EOF flags, and clear the BLOCKED bit.
     */

    if (GotFlag(statePtr, CHANNEL_EOF)) {
	statePtr->inputEncodingFlags |= TCL_ENCODING_START;
    }
    ResetFlag(statePtr,
	    CHANNEL_BLOCKED | CHANNEL_STICKY_EOF | CHANNEL_EOF | INPUT_SAW_CR);
    statePtr->inputEncodingFlags &= ~TCL_ENCODING_END;

    int toRead;			/* How much to read? */
    int result;			/* Of calling driver. */
    int nread;			/* How much was read from channel? */
    ChannelBuffer *bufPtr;	/* New buffer to add to input queue. */
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */

    /*
     * Verify that all callers know better than to call us when
     * it's recorded that the next char waiting to be read is the
     * eofchar.
     */

    assert( !GotFlag(statePtr, CHANNEL_STICKY_EOF) );

	    /* Successful read -- set up to write the bytes we read */
	    Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, MBEvent, csPtr);
	}
    }
}

static int
MBRead(
    CopyState *csPtr)
{
    ChannelState *inStatePtr = csPtr->readPtr->state;
    ChannelBuffer *bufPtr = inStatePtr->inQueueHead;
    int code;

    if (bufPtr && BytesLeft(bufPtr) > 0) {
	return TCL_OK;
    }

    code = GetInput(inStatePtr->topChanPtr);
    if (code == 0 || GotFlag(inStatePtr, CHANNEL_BLOCKED)) {
	return TCL_OK;
    } else {
	MBError(csPtr, TCL_READABLE, code);
	return TCL_ERROR;
    }
}

static int
MBWrite(
    CopyState *csPtr)
{
    ChannelState *inStatePtr = csPtr->readPtr->state;
    ChannelState *outStatePtr = csPtr->writePtr->state;
    ChannelBuffer *bufPtr = inStatePtr->inQueueHead;
    ChannelBuffer *tail = NULL;


/*
 *----------------------------------------------------------------------
 *
 * DoRead --
 *
 *	Stores up to "bytesToRead" bytes in memory pointed to by "dst".
 *	These bytes come from reading the channel "chanPtr" and
 *	performing the configured translations.  No encoding conversions
 *	are applied to the bytes being read.
 *
 * Results:
 *	The number of bytes actually stored (<= bytesToRead),
 * 	or -1 if there is an error in reading the channel.  Use
 * 	Tcl_GetErrno() to retrieve the error code for the error

	UpdateInterest(chanPtr);
	return 0;
    }

    TclChannelPreserve((Tcl_Channel)chanPtr);
    while (bytesToRead) {
	/*
	 * Each pass through the loop is intended to process up to
	 * one channel buffer.
	 */

	int bytesRead, bytesWritten;
	ChannelBuffer *bufPtr = statePtr->inQueueHead;

	/*
	 * Don't read more data if we have what we need.
	 */

	while (!bufPtr ||			/* We got no buffer!   OR */
		(!IsBufferFull(bufPtr) && 	/* Our buffer has room AND */
		(BytesLeft(bufPtr) < bytesToRead) ) ) {
						/* Not enough bytes in it
						 * yet to fill the dst */
	    int code;

	moreData:
	    code = GetInput(chanPtr);
	    bufPtr = statePtr->inQueueHead;

    dataPtr->refCount++;
}

static void
ReleaseData(
    TransformChannelData *dataPtr)
{
    if (dataPtr->refCount-- > 1) {
	return;
    }
    ResultClear(&dataPtr->result);
    Tcl_DecrRefCount(dataPtr->command);
    ckfree(dataPtr);
}


	    break;
	}
	if (dataPtr->eofPending) {
	    /*
	     * Already saw EOF from downChan; don't ask again.
	     * NOTE: Could move this up to avoid the last maxRead
	     * execution.  Believe this would still be correct behavior,
	     * but the test suite tests the whole command callback
	     * sequence, so leave it unchanged for now.
	     */

	    break;
	}

	/*

 * we cannot assume anymore that refCount is a signed type; In
 * Tcl8 it was but in Tcl9 it is subject to change.
 */

# define TclDecrRefCount(objPtr) \
    do { \
	Tcl_Obj *_objPtr = (objPtr); \
	if (_objPtr->refCount-- <= 1) { \
	    if (!_objPtr->typePtr || !_objPtr->typePtr->freeIntRepProc) { \
		TCL_DTRACE_OBJ_FREE(_objPtr); \
		if (_objPtr->bytes \
			&& (_objPtr->bytes != tclEmptyStringRep)) { \
		    ckfree((char *) _objPtr->bytes); \
		} \
		_objPtr->length = -1; \

/*
 *----------------------------------------------------------------
 * Inline version of TclCleanupCommand; still need the function as it is in
 * the internal stubs, but the core can use the macro instead.
 */

#define TclCleanupCommandMacro(cmdPtr) \
    if ((cmdPtr)->refCount-- <= 1) { \
	ckfree((char *) (cmdPtr));\
    }

/*
 *----------------------------------------------------------------
 * Inline versions of Tcl_LimitReady() and Tcl_LimitExceeded to limit number
 * of calls out of the critical path. Note that this code isn't particularly

 *----------------------------------------------------------------------
 *
 * AttemptNewList --
 *
 *	Creates a list internal rep with space for objc elements.  objc
 *	must be > 0.  If objv!=NULL, initializes with the first objc values
 *	in that array.  If objv==NULL, initalize list internal rep to have
 *	0 elements, with space to add objc more.
 *
 * Results:
 *	A new List struct with refCount 0 is returned. If some failure
 *	prevents this then NULL is returned, and an error message is left
 *	in the interp result, unless interp is NULL.
 *
 * Side effects:

static void
FreeListInternalRep(
    Tcl_Obj *listPtr)		/* List object with internal rep to free. */
{
    List *listRepPtr = ListRepPtr(listPtr);

    if (listRepPtr->refCount-- <= 1) {
	Tcl_Obj **elemPtrs = &listRepPtr->elements;
	int i, numElems = listRepPtr->elemCount;

	for (i = 0;  i < numElems;  i++) {
	    Tcl_DecrRefCount(elemPtrs[i]);
	}
	ckfree(listRepPtr);

    if (framePtr->varTablePtr != NULL) {
	TclDeleteVars(iPtr, framePtr->varTablePtr);
	ckfree(framePtr->varTablePtr);
	framePtr->varTablePtr = NULL;
    }
    if (framePtr->numCompiledLocals > 0) {
	TclDeleteCompiledLocalVars(iPtr, framePtr);
	if (framePtr->localCachePtr->refCount-- <= 1) {
	    TclFreeLocalCache(interp, framePtr->localCachePtr);
	}
	framePtr->localCachePtr = NULL;
    }

    /*
     * Decrement the namespace's count of active call frames. If the namespace

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

void
TclOODeleteChain(
    CallChain *callPtr)
{
    if (callPtr == NULL || callPtr->refCount-- > 1) {
	return;
    }
    if (callPtr->chain != callPtr->staticChain) {
	ckfree(callPtr->chain);
    }
    ckfree(callPtr);
}

/*
 * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release.
 */

#define AddRef(ptr) ((ptr)->refCount++)
#define DelRef(ptr) do {			\
	if ((ptr)->refCount-- <= 1) {		\
	    ckfree((char *) (ptr));		\
	}					\
    } while(0)

#endif /* TCL_OO_INTERNAL_H */

/*

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

void
TclOODelMethodRef(
    Method *mPtr)
{
    if ((mPtr != NULL) && (mPtr->refCount-- <= 1)) {
	if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
	    mPtr->typePtr->deleteProc(mPtr->clientData);
	}
	if (mPtr->namePtr != NULL) {
	    Tcl_DecrRefCount(mPtr->namePtr);
	}

	     * won't crash on us. [Bug 3001438]
	     */

	    pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr;

	    Tcl_PopCallFrame(interp);
	    TclStackFree(interp, fdPtr->framePtr);
	    if (pmPtr->refCount-- <= 1) {
		DeleteProcedureMethodRecord(pmPtr);
	    }
	    TclStackFree(interp, fdPtr);
	    return result;
	}
    }

    /*
     * Scrap the special frame data now that we're done with it. Note that we
     * are inlining DeleteProcedureMethod() here; this location is highly
     * sensitive when it comes to performance!
     */

    if (pmPtr->refCount-- <= 1) {
	DeleteProcedureMethodRecord(pmPtr);
    }
    TclStackFree(interp, fdPtr);
    return result;
}

static int

    const char *varName,
    Tcl_Namespace *contextNs,
    int flags,
    Tcl_Var *varPtr)
{
    int result;
    Tcl_ResolvedVarInfo *rPtr = NULL;

    result = ProcedureMethodCompiledVarResolver(interp, varName,
	    strlen(varName), contextNs, &rPtr);

    if (result != TCL_OK) {
	return result;
    }

static void
DeleteProcedureMethod(
    ClientData clientData)
{
    register ProcedureMethod *pmPtr = clientData;

    if (pmPtr->refCount-- <= 1) {
	DeleteProcedureMethodRecord(pmPtr);
    }
}

static int
CloneProcedureMethod(
    Tcl_Interp *interp,

static int
FinalizeForwardCall(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj **argObjs = data[0];

    TclStackFree(interp, argObjs);
    return result;
}

/*
 * ----------------------------------------------------------------------
 *

 * Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep
 */

#define PACK_BIGNUM(bignum, objPtr) \
    if ((bignum).used > 0x7fff) {                                       \
	mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int));     \
	*temp = bignum;                                                 \
	(objPtr)->internalRep.twoPtrValue.ptr1 = temp;                 \
	(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \
    } else {                                                            \
	if ((bignum).alloc > 0x7fff) {                                  \
	    mp_shrink(&(bignum));                                       \
	}                                                               \
	(objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (bignum).dp; \
	(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \
		| ((bignum).alloc << 15) | ((bignum).used));            \
    }

#define UNPACK_BIGNUM(objPtr, bignum) \
    if ((objPtr)->internalRep.twoPtrValue.ptr2 == INT2PTR(-1)) { \
	(bignum) = *((mp_int *) ((objPtr)->internalRep.twoPtrValue.ptr1)); \
    } else {                                                            \
	(bignum).dp = (objPtr)->internalRep.twoPtrValue.ptr1;          \
	(bignum).sign = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 30; \
	(bignum).alloc =                                                \
		(PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 15) & 0x7fff; \
	(bignum).used = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) & 0x7fff; \
    }

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

static int		ParseBoolean(Tcl_Obj *objPtr);

FreeBignum(
    Tcl_Obj *objPtr)
{
    mp_int toFree;		/* Bignum to free */

    UNPACK_BIGNUM(objPtr, toFree);
    mp_clear(&toFree);
    if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) {
	ckfree(objPtr->internalRep.twoPtrValue.ptr1);
    }
    objPtr->typePtr = NULL;
}

/*
 *----------------------------------------------------------------------
 *

	    if (copy || Tcl_IsShared(objPtr)) {
		mp_int temp;

		UNPACK_BIGNUM(objPtr, temp);
		mp_init_copy(bignumValue, &temp);
	    } else {
		UNPACK_BIGNUM(objPtr, *bignumValue);
		objPtr->internalRep.twoPtrValue.ptr1 = NULL;
		objPtr->internalRep.twoPtrValue.ptr2 = NULL;
		objPtr->typePtr = NULL;
		if (objPtr->bytes == NULL) {
		    TclInitStringRep(objPtr, tclEmptyStringRep, 0);
		}
	    }
	    return TCL_OK;
	}

	    Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
                    "decr ref count");
	}
    }
# endif /* TCL_THREADS */
#endif /* TCL_MEM_DEBUG */

    if (objPtr->refCount-- <= 1) {
	TclFreeObj(objPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *

    if (resPtr != NULL) {
	/*
	 * Decrement the reference count of the ResolvedCmdName structure. If
	 * there are no more uses, free the ResolvedCmdName structure.
	 */


	if (resPtr->refCount-- <= 1) {
	    /*
	     * Now free the cached command, unless it is still in its hash
	     * table or if there are other references to it from other cmdName
	     * objects.
	     */

	    Command *cmdPtr = resPtr->cmdPtr;

		&& resPtr && (resPtr->refCount == 1)) {
	    /*
	     * Reuse the old ResolvedCmdName struct instead of freeing it
	     */

	    Command *oldCmdPtr = resPtr->cmdPtr;

	    if (oldCmdPtr->refCount-- <= 1) {
		TclCleanupCommandMacro(oldCmdPtr);
	    }
	} else {
	    TclFreeIntRep(objPtr);
	    resPtr = ckalloc(sizeof(ResolvedCmdName));
	    resPtr->refCount = 1;
	    objPtr->internalRep.twoPtrValue.ptr1 = resPtr;

	int mustFree;
	Tcl_FreeProc *freeProc;

	if (refPtr->clientData != clientData) {
	    continue;
	}

	if (refPtr->refCount-- > 1) {
	    Tcl_MutexUnlock(&preserveMutex);
	    return;
	}

	/*
	 * Must remove information from the slot before calling freeProc to
	 * avoid reentrancy problems if the freeProc calls Tcl_Preserve on the

	Tcl_Panic("using previously disposed TclHandle %p", handlePtr);
    }
    if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) {
	Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p",
		handlePtr, handlePtr->ptr2, handlePtr->ptr);
    }
#endif

    if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) {
	ckfree(handlePtr);
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

				 * Tcl_GetStringFromObj should panic
				 * instead. */
    NULL			/* SetFromAny function; Tcl_ConvertToType
				 * should panic instead. */
};

/*
 * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field,
 * encoding the type of level reference in ptr and the actual parsed out
 * offset in ptr2.
 *
 * Uses the default behaviour throughout, and never disposes of the string
 * rep; it's just a cache type.
 */

static const Tcl_ObjType levelReferenceType = {
    "levelReference",

    if (objPtr == NULL) {
	name = "1";
	goto haveLevel1;
    }

    name = TclGetString(objPtr);
    if (objPtr->typePtr == &levelReferenceType) {
	if (objPtr->internalRep.twoPtrValue.ptr1) {
	    level = curLevel - PTR2INT(objPtr->internalRep.twoPtrValue.ptr2);
	} else {
	    level = PTR2INT(objPtr->internalRep.twoPtrValue.ptr2);
	}
	if (level < 0) {
	    goto levelError;
	}
	/* TODO: Consider skipping the typePtr checks */
    } else if (objPtr->typePtr == &tclIntType
#ifndef TCL_WIDE_INT_IS_LONG

    } else if (*name == '#') {
	if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) {
	    goto levelError;
	}

	/*
	 * Cache for future reference.


	 */

	TclFreeIntRep(objPtr);
	objPtr->typePtr = &levelReferenceType;
	objPtr->internalRep.twoPtrValue.ptr1 = (void *) 0;
	objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level);
    } else if (isdigit(UCHAR(*name))) { /* INTL: digit */
	if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
	    return -1;
	}

	/*
	 * Cache for future reference.


	 */

	TclFreeIntRep(objPtr);
	objPtr->typePtr = &levelReferenceType;
	objPtr->internalRep.twoPtrValue.ptr1 = (void *) 1;
	objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level);
	level = curLevel - level;
    } else {
	/*
	 * Don't cache as the object *isn't* a level reference (might even be
	 * NULL...)
	 */

    if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
	int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;

	TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ?
		TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result);
    }
    if (procPtr->refCount-- <= 1) {
	TclProcCleanupProc(procPtr);
    }

    /*
     * Free the stack-allocated compiled locals and CallFrame. It is important
     * to pop the call frame without freeing it first: the compiledLocals
     * cannot be freed before the frame is popped, as the local variables must

void
TclProcDeleteProc(
    ClientData clientData)	/* Procedure to be deleted. */
{
    Proc *procPtr = clientData;


    if (procPtr->refCount-- <= 1) {
	TclProcCleanupProc(procPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *

static void
ProcBodyFree(
    Tcl_Obj *objPtr)		/* The object to clean up. */
{
    Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;

    if (procPtr->refCount-- <= 1) {
	TclProcCleanupProc(procPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *

FreeLambdaInternalRep(
    register Tcl_Obj *objPtr)	/* CmdName object with internal representation
				 * to free. */
{
    Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
    Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2;


    if (procPtr->refCount-- <= 1) {
	TclProcCleanupProc(procPtr);
    }
    TclDecrRefCount(nsObjPtr);
    objPtr->typePtr = NULL;
}

static int

{
    TclRegexp *regexpRepPtr = objPtr->internalRep.twoPtrValue.ptr1;

    /*
     * If this is the last reference to the regexp, free it.
     */

    if (regexpRepPtr->refCount-- <= 1) {
	FreeRegexp(regexpRepPtr);
    }
    objPtr->typePtr = NULL;
}

/*
 *----------------------------------------------------------------------

     * Free the last regexp, if necessary, and make room at the head of the
     * list for the new regexp.
     */

    if (tsdPtr->patterns[NUM_REGEXPS-1] != NULL) {
	TclRegexp *oldRegexpPtr = tsdPtr->regexps[NUM_REGEXPS-1];

	if (oldRegexpPtr->refCount-- <= 1) {
	    FreeRegexp(oldRegexpPtr);
	}
	ckfree(tsdPtr->patterns[NUM_REGEXPS-1]);
    }
    for (i = NUM_REGEXPS - 2; i >= 0; i--) {
	tsdPtr->patterns[i+1] = tsdPtr->patterns[i];
	tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i];

{
    int i;
    TclRegexp *regexpPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
	regexpPtr = tsdPtr->regexps[i];
	if (regexpPtr->refCount-- <= 1) {
	    FreeRegexp(regexpPtr);
	}
	ckfree(tsdPtr->patterns[i]);
	tsdPtr->patterns[i] = NULL;
    }

    /*

		    if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
			/*
			 * Postpone deletion.
			 */

			tcmdPtr->flags = 0;
		    }
		    if (tcmdPtr->refCount-- <= 1) {
			ckfree(tcmdPtr);
		    }
		    break;
		}
	    }
	}
	break;

		if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags)
			&& (strncmp(command, tcmdPtr->command,
				(size_t) length) == 0)) {
		    Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE,
			    TraceCommandProc, clientData);
		    tcmdPtr->flags |= TCL_TRACE_DESTROYED;
		    if (tcmdPtr->refCount-- <= 1) {
			ckfree(tcmdPtr);
		    }
		    break;
		}
	    }
	}
	break;

    tracePtr->nextPtr = cmdPtr->tracePtr;
    tracePtr->refCount = 1;
    cmdPtr->tracePtr = tracePtr;
    if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
	/*
	 * Bug 3484621: up the interp's epoch if this is a BC'ed command
	 */

	if ((cmdPtr->compileProc != NULL) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)){
	    Interp *iPtr = (Interp *) interp;
	    iPtr->compileEpoch++;
	}
	cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
    }


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

    if (prevPtr == NULL) {
	cmdPtr->tracePtr = tracePtr->nextPtr;
    } else {
	prevPtr->nextPtr = tracePtr->nextPtr;
    }
    tracePtr->flags = 0;

    if (tracePtr->refCount-- <= 1) {
	ckfree(tracePtr);
    }

    if (hasExecTraces) {
	for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ;
		prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
	    if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {

	 */

	cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;

        /*
	 * Bug 3484621: up the interp's epoch if this is a BC'ed command
	 */

	if (cmdPtr->compileProc != NULL) {
	    Interp *iPtr = (Interp *) interp;
	    iPtr->compileEpoch++;
	}
    }
}


	state = Tcl_SaveInterpState(interp, TCL_OK);
	Tcl_UntraceCommand(interp, oldName, untraceFlags,
		TraceCommandProc, clientData);
	Tcl_RestoreInterpState(interp, state);
	tcmdPtr->refCount--;
    }
    if (tcmdPtr->refCount-- <= 1) {
	ckfree(tcmdPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *

		tcmdPtr->curCode  = code;
		tcmdPtr->refCount++;
		if (state == NULL) {
		    state = Tcl_SaveInterpState(interp, code);
		}
		traceCode = TraceExecutionProc(tcmdPtr, interp, curLevel,
			command, (Tcl_Command) cmdPtr, objc, objv);
		if (tcmdPtr->refCount-- <= 1) {
		    ckfree(tcmdPtr);
		}
	    }
	}
	if (active.nextTracePtr) {
	    lastTracePtr = active.nextTracePtr->nextPtr;
	}

static void
CommandObjTraceDeleted(
    ClientData clientData)
{
    TraceCommandInfo *tcmdPtr = clientData;

    if (tcmdPtr->refCount-- <= 1) {
	ckfree(tcmdPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *

	    tcmdPtr->stepTrace = NULL;
	    if (tcmdPtr->startCmd != NULL) {
		ckfree(tcmdPtr->startCmd);
	    }
	}
    }
    if (call) {
	if (tcmdPtr->refCount-- <= 1) {
	    ckfree(tcmdPtr);
	}
    }
    return traceCode;
}

/*

static Tcl_UpdateStringProc	PanicOnUpdateVarName;
static Tcl_SetFromAnyProc	PanicOnSetVarName;

/*
 * Types of Tcl_Objs used to cache variable lookups.
 *
 * localVarName - INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1:   pointer to name obj in varFramePtr->localCache
 *			  or NULL if it is this same obj
 *   twoPtrValue.ptr2: index into locals table
 *
 * nsVarName - INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1:	pointer to the namespace containing the reference
 *   twoPtrValue.ptr2:	pointer to the corresponding Var
 *
 * parsedVarName - INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1:	pointer to the array name Tcl_Obj, or NULL if it is a
 *			scalar variable
 *   twoPtrValue.ptr2:	pointer to the element name string (owned by this
 *			Tcl_Obj), or NULL if it is a scalar variable
 */

static const Tcl_ObjType localVarNameType = {
    "localVarName",
    FreeLocalVarName, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName
};




















static const Tcl_ObjType tclParsedVarNameType = {
    "parsedVarName",
    FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName
};

/*
 * Type of Tcl_Objs used to speed up array searches.

    const char *part1;
    int index, len1, len2;
    int parsed = 0;
    Tcl_Obj *objPtr;
    const Tcl_ObjType *typePtr = part1Ptr->typePtr;
    const char *errMsg = NULL;
    CallFrame *varFramePtr = iPtr->varFramePtr;



    const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL;
    char *newPart2 = NULL;

    *arrayPtrPtr = NULL;














    if (typePtr == &localVarNameType) {
	int localIndex;

    localVarNameTypeHandling:
	localIndex = PTR2INT(part1Ptr->internalRep.twoPtrValue.ptr2);
	if (HasLocalVars(varFramePtr)
		&& !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
		&& (localIndex < varFramePtr->numCompiledLocals)) {
	    /*
	     * Use the cached index if the names coincide.
	     */

	    Tcl_Obj *namePtr = part1Ptr->internalRep.twoPtrValue.ptr1;
	    Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex);

	    if ((!namePtr && (checkNamePtr == part1Ptr)) ||
		    (namePtr && (checkNamePtr == namePtr))) {
		varPtr = (Var *) &(varFramePtr->compiledLocals[localIndex]);
		goto donePart1;
	    }
	}
	goto doneParsing;






































    }

    /*
     * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed
     * parts.
     */

    if (index >= 0) {
	/*
	 * An indexed local variable.
	 */

	part1Ptr->typePtr = &localVarNameType;
	if (part1Ptr != localName(iPtr->varFramePtr, index)) {
	    part1Ptr->internalRep.twoPtrValue.ptr1 =
		    localName(iPtr->varFramePtr, index);
	    Tcl_IncrRefCount((Tcl_Obj *)
		    part1Ptr->internalRep.twoPtrValue.ptr1);
	} else {
	    part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
	}












	part1Ptr->internalRep.twoPtrValue.ptr2 = INT2PTR(index);


    } else {
	/*
	 * At least mark part1Ptr as already parsed.
	 */

	part1Ptr->typePtr = &tclParsedVarNameType;
	part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
	part1Ptr->internalRep.twoPtrValue.ptr2 = NULL;
    }

  donePart1:












    while (TclIsVarLink(varPtr)) {
	varPtr = varPtr->value.linkPtr;
    }

    if (part2Ptr != NULL) {
	/*
	 * Array element sought: look it up.

     */

    oldValuePtr = varPtr->value.objPtr;
    if (flags & TCL_LIST_ELEMENT && !(flags & TCL_APPEND_VALUE)) {
	varPtr->value.objPtr = NULL;
    }
    if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) {











	if (flags & TCL_LIST_ELEMENT) {		/* Append list element. */
	    if (oldValuePtr == NULL) {
		TclNewObj(oldValuePtr);
		varPtr->value.objPtr = oldValuePtr;
		Tcl_IncrRefCount(oldValuePtr);	/* Since var is referenced. */
	    } else if (Tcl_IsShared(oldValuePtr)) {
		varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);

	if (flags & TCL_LEAVE_ERR_MSG) {
	    TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset",
		    ((arrayPtr == NULL) ? noSuchVar : noSuchElement), index);
	    Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", NULL);
	}
    }













    /*
     * Finally, if the variable is truly not in use then free up its Var
     * structure and remove it from its hash table, if any. The ref count of
     * its value object, if any, was decremented above.
     */

    if (TclIsVarInHash(varPtr)) {

    return TCL_ERROR;
}

/*
 * localVarName -
 *
 * INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1:   pointer to name obj in varFramePtr->localCache
 *			  or NULL if it is this same obj
 *   twoPtrValue.ptr2: index into locals table
 */

static void
FreeLocalVarName(
    Tcl_Obj *objPtr)
{
    Tcl_Obj *namePtr = objPtr->internalRep.twoPtrValue.ptr1;

    if (namePtr) {
	Tcl_DecrRefCount(namePtr);
    }
    objPtr->typePtr = NULL;
}

static void
DupLocalVarName(
    Tcl_Obj *srcPtr,
    Tcl_Obj *dupPtr)
{
    Tcl_Obj *namePtr = srcPtr->internalRep.twoPtrValue.ptr1;

    if (!namePtr) {
	namePtr = srcPtr;
    }
    dupPtr->internalRep.twoPtrValue.ptr1 = namePtr;
    Tcl_IncrRefCount(namePtr);

    dupPtr->internalRep.twoPtrValue.ptr2 =
	    srcPtr->internalRep.twoPtrValue.ptr2;
    dupPtr->typePtr = &localVarNameType;
}










































/*
 * parsedVarName -
 *
 * INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1 = pointer to the array name Tcl_Obj (NULL if scalar)
 *   twoPtrValue.ptr2 = pointer to the element name string (owned by this
 *			Tcl_Obj), or NULL if it is a scalar variable

#
#----------------------------------------------------------------------

# We must have message catalogs that support the root locale, and we need
# access to the Registry on Windows systems.

uplevel \#0 {
    package require msgcat 1.6
    if { $::tcl_platform(platform) eq {windows} } {
	if { [catch { package require registry 1.1 }] } {
	    namespace eval ::tcl::clock [list variable NoRegistry {}]
	}
    }
}

    namespace export seconds
    namespace export add

    # Import the message catalog commands that we use.

    namespace import ::msgcat::mcload
    namespace import ::msgcat::mclocale
    namespace import ::msgcat::mc
    namespace import ::msgcat::mcpackagelocale

}

#----------------------------------------------------------------------
#
# ::tcl::clock::Initialize --
#

	    {-9223372036854775808 0 0 UTC}
	}
	set TZData(:UTC) $TZData(:Etc/UTC)
	set TZData(:localtime) {}
    }
    InitTZData

    mcpackagelocale set {}
    ::msgcat::mcpackageconfig set mcfolder [file join $LibDir msgs]
    ::msgcat::mcpackageconfig set unknowncmd ""

    # Define the message catalog for the root locale.

    ::msgcat::mcmset {} {
	AM {am}
	BCE {B.C.E.}
	CE {C.E.}
	DATE_FORMAT {%m/%d/%Y}

	    lappend ZoneinfoPaths $path
	}
    }

    # Define the directories for time zone data and message catalogs.

    variable DataDir [file join $LibDir tzdata]


    # Number of days in the months, in common years and leap years.

    variable DaysInRomanMonthInCommonYear \
	{ 31 28 31 30 31 30 31 31 30 31 30 31 }
    variable DaysInRomanMonthInLeapYear \
	{ 31 29 31 30 31 30 31 31 30 31 30 31 }

    variable LocaleNumeralCache {};	# Dictionary whose keys are locale
					# names and whose values are pairs
					# comprising regexes matching numerals
					# in the given locales and dictionaries
					# mapping the numerals to their numeric
					# values.





    # variable CachedSystemTimeZone;    # If 'CachedSystemTimeZone' exists,
					# it contains the value of the
					# system time zone, as determined from
					# the environment.
    variable TimeZoneBad {};	        # Dictionary whose keys are time zone
    					# names and whose values are 1 if
					# the time zone is unknown and 0

#
# The 'clock format' command formats times of day for output.  Refer to the
# user documentation to see what it does.
#
#----------------------------------------------------------------------

proc ::tcl::clock::format { args } {

    variable FormatProc
    variable TZData

    lassign [ParseFormatArgs {*}$args] format locale timezone
    set locale [string tolower $locale]
    set clockval [lindex $args 0]

	set procName $FormatProc($procName)
    } else {
	set FormatProc($procName) \
	    [ParseClockFormatFormat $procName $format $locale]
    }

    return [$procName $clockval $timezone]

}

#----------------------------------------------------------------------
#
# ParseClockFormatFormat --
#
#	Builds and caches a procedure that formats a time value.
#
# Parameters:
#	format -- Format string to use
#	locale -- Locale in which the format string is to be interpreted
#
# Results:
#	Returns the name of the newly-built procedure.
#
#----------------------------------------------------------------------

proc ::tcl::clock::ParseClockFormatFormat {procName format locale} {

    if {[namespace which $procName] ne {}} {
	return $procName
    }

    # Map away the locale-dependent composite format groups

    EnterLocale $locale

    # Change locale if a fresh locale has been given on the command line.

    try {
	return [ParseClockFormatFormat2 $format $locale $procName]
    } trap CLOCK {result opts} {
	dict unset opts -errorinfo
	return -options $opts $result






    }
}

proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} {
    set didLocaleEra 0
    set didLocaleNumerals 0
    set preFormatCode \

#
# The 'clock format' command scans times of day on input.  Refer to the user
# documentation to see what it does.
#
#----------------------------------------------------------------------

proc ::tcl::clock::scan { args } {

    set format {}

    # Check the count of args

    if { [llength $args] < 1 || [llength $args] % 2 != 1 } {
	set cmdName "clock scan"
	return -code error \

	}
	return [FreeScan $string $base $timezone $locale]
    }

    # Change locale if a fresh locale has been given on the command line.

    EnterLocale $locale

    try {
	# Map away the locale-dependent composite format groups

	set scanner [ParseClockScanFormat $format $locale]
	return [$scanner $string $base $timezone]
    } trap CLOCK {result opts} {
	# Conceal location of generation of expected errors

	dict unset opts -errorinfo
	return -options $opts $result






    }
}

#----------------------------------------------------------------------
#
# FreeScan --
#

# Results:
#	Returns the date and time extracted from the string in seconds from
#	the epoch
#
#----------------------------------------------------------------------

proc ::tcl::clock::FreeScan { string base timezone locale } {

    variable TZData

    # Get the data for time changes in the given zone

    try {
	SetupTimeZone $timezone
    } on error {retval opts} {

	    + ( 86400 * wide([dict get $date2 julianDay]) )
	    + [dict get $date secondOfDay]
	}]
	dict set date2 tzName $timezone
	set date2 [ConvertLocalToUTC $date2[set date2 {}] $TZData($timezone) \
		       2361222]
	set seconds [dict get $date2 seconds]

    }

    # Do relative month

    if { [llength $parseOrdinalMonth] > 0 } {
	lassign $parseOrdinalMonth monthOrdinal monthNumber
	if { $monthOrdinal > 0 } {

#	None.
#
#----------------------------------------------------------------------

proc ::tcl::clock::MakeUniquePrefixRegexp { successors
					  uniquePrefixMapping
					  prefixString } {

    # Get the characters that may follow the current prefix string

    set schars [lsort -ascii [dict keys [dict get $successors $prefixString]]]
    if { [llength $schars] == 0 } {
	return {}
    }

#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } {

    set currPrio 999
    set currFieldPos [list]
    set currCodeBurst {
	error "in ::tcl::clock::MakeParseCodeFromFields: can't happen"
    }

    foreach { fieldSet prio parseAction } $parseActions {

#
# EnterLocale --
#
#	Switch [mclocale] to a given locale if necessary
#
# Parameters:
#	locale -- Desired locale


#
# Results:
#	Returns the locale that was previously current.
#
# Side effects:
#	Does [mclocale].  If necessary, loades the designated locale's files.


#
#----------------------------------------------------------------------

proc ::tcl::clock::EnterLocale { locale } {






    if { $locale eq {system} } {
	if { $::tcl_platform(platform) ne {windows} } {
	    # On a non-windows platform, the 'system' locale is the same as
	    # the 'current' locale

	    set locale current
	} else {
	    # On a windows platform, the 'system' locale is adapted from the
	    # 'current' locale by applying the date and time formats from the
	    # Control Panel.  First, load the 'current' locale if it's not yet
	    # loaded



	    mcpackagelocale set [mclocale]


	    # Make a new locale string for the system locale, and get the
	    # Control Panel information

	    set locale [mclocale]_windows
	    if { ! [mcpackagelocale present $locale] } {
		LoadWindowsDateTimeFormats $locale

	    }
	}
    }
    if { $locale eq {current}} {
	set locale [mclocale]





    }

    # Eventually load the locale
    mcpackagelocale set $locale

}

#----------------------------------------------------------------------
#
# LoadWindowsDateTimeFormats --
#
#	Load the date/time formats from the Control Panel in Windows and

	::msgcat::mcset $locale DATE_TIME_FORMAT "$datefmt $timefmt"
    }
    catch {
	::msgcat::mcset $locale LOCALE_DATE_TIME_FORMAT "$ldatefmt $timefmt"
    }

    return

}

#----------------------------------------------------------------------
#
# LocalizeFormat --
#
#	Map away locale-dependent format groups in a clock format.

#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc ::tcl::clock::LocalizeFormat { locale format } {


    # message catalog key to cache this format
    set key FORMAT_$format

    if { [::msgcat::mcexists -exactlocale -exactnamespace $key] } {
	return [mc $key]
    }
    # Handle locale-dependent format groups by mapping them out of the format
    # string.  Note that the order of the [string map] operations is
    # significant because later formats can refer to later ones; for example
    # %c can refer to %X, which in turn can refer to %T.

    set list {
	%% %%

    lappend list %EX [string map $list [mc LOCALE_TIME_FORMAT]]
    lappend list %x  [string map $list [mc DATE_FORMAT]]
    lappend list %Ex [string map $list [mc LOCALE_DATE_FORMAT]]
    lappend list %c  [string map $list [mc DATE_TIME_FORMAT]]
    lappend list %Ec [string map $list [mc LOCALE_DATE_TIME_FORMAT]]
    set format [string map $list $format]

    ::msgcat::mcset $locale $key $format
    return $format
}

#----------------------------------------------------------------------
#
# FormatNumericTimeZone --
#

		    LoadZoneinfoFile [string range $timezone 1 end]
		}]
	    } then {
		return -code error \
		    -errorcode [list CLOCK badTimeZone $timezone] \
		    "time zone \"$timezone\" not found"
	    }

	} elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } {
	    # This looks like a POSIX time zone - try to process it

	    if { [catch {ProcessPosixTimeZone $tzfields} data opts] } {
		if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
		    dict unset opts -errorinfo
		}

# Results:
#	Returns the transition time as a count of seconds from the epoch.  The
#	time is relative to the wall clock, not UTC.
#
#----------------------------------------------------------------------

proc ::tcl::clock::DeterminePosixDSTTime { z bound y } {

    variable FEB_28

    # Determine the start or end day of DST

    set date [dict create era CE year $y]
    set doy [dict get $z ${bound}DayOfYear]
    if { $doy ne {} } {

	# Time was specified as a day of the year

	if { [dict get $z ${bound}J] ne {}
	     && [IsGregorianLeapYear $y]
	     && ( $doy > $FEB_28 ) } {
	    incr doy
	}

    }
    if { ![string is boolean -strict $gmt] } {
	return -code error "expected boolean value but got \"$gmt\""
    } elseif { $gmt } {
	set timezone :GMT
    }

    EnterLocale $locale

    set changeover [mc GREGORIAN_CHANGE_DATE]

    if {[catch {SetupTimeZone $timezone} retval opts]} {
	dict unset opts -errorinfo
	return -options $opts $retval
    }

	    }
	}
	return $clockval
    } trap CLOCK {result opts} {
	# Conceal the innards of [clock] when it's an expected error
	dict unset opts -errorinfo
	return -options $opts $result






    }
}

#----------------------------------------------------------------------
#
# AddMonths --
#

	+ ( 86400 * wide([dict get $date julianDay]) )
	+ [dict get $date secondOfDay]
    }]
    set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \
		 $changeover]

    return [dict get $date seconds]

}

#----------------------------------------------------------------------
#
# AddDays --
#
#	Add a given number of days to a given clock value in a given time

	+ ( 86400 * wide([dict get $date julianDay]) )
	+ [dict get $date secondOfDay]
    }]
    set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \
		  $changeover]

    return [dict get $date seconds]
































}

#----------------------------------------------------------------------
#
# ClearCaches --
#
#	Clears all caches to reclaim the memory used in [clock]

#	Caches are cleared.
#
#----------------------------------------------------------------------

proc ::tcl::clock::ClearCaches {} {
    variable FormatProc
    variable LocaleNumeralCache

    variable CachedSystemTimeZone
    variable TimeZoneBad

    foreach p [info procs [namespace current]::scanproc'*] {
	rename $p {}
    }
    foreach p [info procs [namespace current]::formatproc'*] {
	rename $p {}
    }

    catch {unset FormatProc}
    set LocaleNumeralCache {}

    catch {unset CachedSystemTimeZone}
    set TimeZoneBad {}
    InitTZData
}

# msgcat.tcl --
#
#	This file defines various procedures which implement a
#	message catalog facility for Tcl programs.  It should be
#	loaded with the command "package require msgcat".
#
# Copyright (c) 2010-2015 by Harald Oehlmann.
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 1998 by Mark Harrison.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require Tcl 8.5-
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
package provide msgcat 1.6.0

namespace eval msgcat {
    namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\
            mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
	    mcpackageconfig mcpackagelocale



    # Records the list of locales to search
    variable Loclist {}

    # List of currently loaded locales
    variable LoadedLocales {}

    # Records the locale of the currently sourced message catalogue file
    variable FileLocale

    # Configuration values per Package (e.g. client namespace).
    # The dict key is of the form "<option> <namespace>" and the value is the
    # configuration option. A nonexisting key is an unset option.
    variable PackageConfig [dict create mcfolder {} loadcmd {} changecmd {}\
	    unknowncmd {} loadedlocales {} loclist {}]

    # Records the mapping between source strings and translated strings.  The
    # dict key is of the form "<namespace> <locale> <src>", where locale and
    # namespace should be themselves dict values and the value is
    # the translated string.
    variable Msgs [dict create]

    # Map of language codes used in Windows registry to those of ISO-639
    if {[info sharedlibextension] eq ".dll"} {
	variable WinRegToISO639 [dict create  {*}{

# msgcat::mc --
#
#	Find the translation for the given string based on the current
#	locale setting. Check the local namespace first, then look in each
#	parent namespace until the source is found.  If additional args are
#	specified, use the format command to work them into the traslated
#	string.
#	If no catalog item is found, mcunknown is called in the caller frame
#	and its result is returned.
#
# Arguments:
#	src	The string to translate.
#	args	Args to pass to the format command
#
# Results:
#	Returns the translated string.  Propagates errors thrown by the
#	format command.

proc msgcat::mc {src args} {
    # this may be replaced by:
    # return [mcget -namespace [uplevel 1 [list ::namespace current]] --\
    #	    $src {*}$args]

    # Check for the src in each namespace starting from the local and
    # ending in the global.

    variable Msgs
    variable Loclist

    set ns [uplevel 1 [list ::namespace current]]
    set loclist [PackagePreferences $ns]

    set nscur $ns
    while {$nscur != ""} {
	foreach loc $loclist {
	    if {[dict exists $Msgs $nscur $loc $src]} {
		return [DefaultUnknown "" [dict get $Msgs $nscur $loc $src]\
			{*}$args]
	    }
	}
	set nscur [namespace parent $nscur]
    }
    # call package local or default unknown command
    set args [linsert $args 0 [lindex $loclist 0] $src]
    switch -exact -- [Invoke unknowncmd $args $ns result 1] {
	0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] }
	1 { return [DefaultUnknown {*}$args] }
	default { return $result }
    }
}

# msgcat::mcexists --
#
#	Check if a catalog item is set or if mc would invoke mcunknown.
#
# Arguments:
#	-exactnamespace		Only check the exact namespace and no
#				parent namespaces
#	-exactlocale		Only check the exact locale and not all members
#				of the preferences list
#	src			Message catalog key
#
# Results:
#	true if an adequate catalog key was found

proc msgcat::mcexists {args} {

    variable Msgs
    variable Loclist
    variable PackageConfig

    set ns [uplevel 1 [list ::namespace current]]
    set loclist [PackagePreferences $ns]

    while {[llength $args] != 1} {
	set args [lassign $args option]
	switch -glob -- $option {
	    -exactnamespace { set exactnamespace 1 }
	    -exactlocale { set loclist [lrange $loclist 0 0] }
	    -* { return -code error "unknown option \"$option\"" }
	    default {
		return -code error "wrong # args: should be\
			\"[lindex [info level 0] 0] ?-exactnamespace?\
			?-exactlocale? src\""
	    }
	}
    }
    set src [lindex $args 0]
    
    while {$ns ne ""} {
	foreach loc $loclist {
	    if {[dict exists $Msgs $ns $loc $src]} {

		return 1


	    }
	}

	if {[info exists exactnamespace]} {return 0}
	set ns [namespace parent $ns]
    }

    return 0

}

# msgcat::mclocale --
#
#	Query or set the current locale.
#
# Arguments:
#	newLocale	(Optional) The new locale string. Locale strings
#			should be composed of one or more sublocale parts
#			separated by underscores (e.g. en_US).
#
# Results:
#	Returns the normalized set locale.

proc msgcat::mclocale {args} {
    variable Loclist
    variable LoadedLocales
    set len [llength $args]

    if {$len > 1} {
	return -code error "wrong # args: should be\
		\"[lindex [info level 0] 0] ?newLocale?\""
    }

    if {$len == 1} {
	set newLocale [string tolower [lindex $args 0]]
	if {$newLocale ne [file tail $newLocale]} {
	    return -code error "invalid newLocale value \"$newLocale\":\
		    could be path to unsafe code."
	}
	if {[lindex $Loclist 0] ne $newLocale} {
	    set Loclist [GetPreferences $newLocale]
	    
	    # locale not loaded jet
	    LoadAll $Loclist
	    # Invoke callback
	    Invoke changecmd $Loclist
	}
    }
    return [lindex $Loclist 0]
}

# msgcat::GetPreferences --
#
#	Get list of locales from a locale.
#	The first element is always the lowercase locale.
#	Other elements have one component separated by "_" less.
#	Multiple "_" are seen as one separator: de__ch_spec de__ch de {}
#
# Arguments:
#	Locale.
#
# Results:
#	Locale list

proc msgcat::GetPreferences {locale} {
    set locale [string tolower $locale]
    set loclist [list $locale]
    while {-1 !=[set pos [string last "_" $locale]]} {
	set locale [string range $locale 0 $pos-1]
	if { "_" ne [string index $locale end] } {
	    lappend loclist $locale
	}
    }
    if {"" ne [lindex $loclist end]} {
	lappend loclist {}
    }
    return $loclist
}

# msgcat::mcpreferences --
#
#	Fetch the list of locales used to look up strings, ordered from
#	most preferred to least preferred.
#
# Arguments:
#	None.
#
# Results:
#	Returns an ordered list of the locales preferred by the user.

proc msgcat::mcpreferences {} {
    variable Loclist
    return $Loclist
}

# msgcat::mcloadedlocales --
#
#	Get or change the list of currently loaded default locales
#
#	The following subcommands are available:
#	loaded
#	    Get the current list of loaded locales
#	clear
#	    Remove all loaded locales not present in mcpreferences.
#
# Arguments:
#	subcommand		One of loaded or clear
#
# Results:
#	Empty string, if not stated differently for the subcommand

proc msgcat::mcloadedlocales {subcommand} {
    variable Loclist
    variable LoadedLocales
    variable Msgs
    variable PackageConfig
    switch -exact -- $subcommand {
	clear {
	    # Remove all locales not contained in Loclist
	    # skip any packages with package locale
	    set LoadedLocales $Loclist
	    foreach ns [dict keys $Msgs] {
		if {![dict exists $PackageConfig loclist $ns]} {
		    foreach locale [dict keys [dict get $Msgs $ns]] {
			if {$locale ni $Loclist} {
			    dict unset Msgs $ns $locale
			}
		    }
		}
	    }
	}
	loaded { return $LoadedLocales }
	default {
	    return -code error "unknown subcommand \"$subcommand\": must be\
		    clear, or loaded"
	}
    }
    return
}

# msgcat::mcpackagelocale --
#
#	Get or change the package locale of the calling package.
#
#	The following subcommands are available:
#	set
#	    Set a package locale.
#	    This may load message catalog files and may clear message catalog
#	    items, if the former locale was the default locale.
#	    Returns the normalized set locale.
#	    The default locale is taken, if locale is not given.
#	get
#	    Get the locale valid for this package.
#	isset
#	    Returns true, if a package locale is set
#	unset
#	    Unset the package locale and activate the default locale.
#	    This loads message catalog file which where missing in the package
#	    locale.
#	preferences
#	    Return locale preference list valid for the package.
#	loaded
#	    Return loaded locale list valid for the current package.
#	clear
#	    If the current package has a package locale, remove all package
#	    locales not containes in package mcpreferences.
#	    It is an error to call this without a package locale set.
#
#	The subcommands get, preferences and loaded return the corresponding
#	default data, if no package locale is set.
#
# Arguments:
#	subcommand		see list above
#	locale			package locale (only set subcommand)
#
# Results:
#	Empty string, if not stated differently for the subcommand

proc msgcat::mcpackagelocale {subcommand {locale ""}} {
    # todo: implement using an ensemble
    variable Loclist
    variable LoadedLocales
    variable Msgs
    variable PackageConfig
    # Check option
    # check if required item is exactly provided
    if {[llength [info level 0]] == 2} {
	# locale not given
	unset locale
    } else {
	# locale given
	if {$subcommand in
		{"get" "isset" "unset" "preferences" "loaded" "clear"} } {
	    return -code error "wrong # args: should be\
		    \"[lrange [info level 0] 0 1]\""
	}
        set locale [string tolower $locale]
    }
    set ns [uplevel 1 {::namespace current}]
    
    switch -exact -- $subcommand {
	get { return [lindex [PackagePreferences $ns] 0] }
	preferences { return [PackagePreferences $ns] }
	loaded { return [PackageLocales $ns] }
	present { return [expr {$locale in [PackageLocales $ns]} ]}
	isset { return [dict exists $PackageConfig loclist $ns] }
	set { # set a package locale or add a package locale

	    # Copy the default locale if no package locale set so far
	    if {![dict exists $PackageConfig loclist $ns]} {
		dict set PackageConfig loclist $ns $Loclist
		dict set PackageConfig loadedlocales $ns $LoadedLocales
	    }

	    # Check if changed
	    set loclist [dict get $PackageConfig loclist $ns]
	    if {! [info exists locale] || $locale eq [lindex $loclist 0] } {
		return [lindex $loclist 0]
	    }

	    # Change loclist
	    set loclist [GetPreferences $locale]
	    set locale [lindex $loclist 0]
	    dict set PackageConfig loclist $ns $loclist

	    # load eventual missing locales
	    set loadedLocales [dict get $PackageConfig loadedlocales $ns]
	    if {$locale in $loadedLocales} { return $locale }
	    set loadLocales [ListComplement $loadedLocales $loclist]
	    dict set PackageConfig loadedlocales $ns\
		    [concat $loadedLocales $loadLocales]
	    Load $ns $loadLocales
	    return $locale
	}
	clear { # Remove all locales not contained in Loclist
	    if {![dict exists $PackageConfig loclist $ns]} {
		return -code error "clear only when package locale set"
	    }
	    set loclist [dict get $PackageConfig loclist $ns]
	    dict set PackageConfig loadedlocales $ns $loclist
	    if {[dict exists $Msgs $ns]} {
		foreach locale [dict keys [dict get $Msgs $ns]] {
		    if {$locale ni $loclist} {
			dict unset Msgs $ns $locale
		    }
		}
	    }
	}
	unset {	# unset package locale and restore default locales

	    if { ![dict exists $PackageConfig loclist $ns] } { return }

	    # unset package locale
	    set loadLocales [ListComplement\
		    [dict get $PackageConfig loadedlocales $ns] $LoadedLocales]
	    dict unset PackageConfig loadedlocales $ns
	    dict unset PackageConfig loclist $ns

	    # unset keys not in global loaded locales
	    if {[dict exists $Msgs $ns]} {
		foreach locale [dict keys [dict get $Msgs $ns]] {
		    if {$locale ni $LoadedLocales} {
			dict unset Msgs $ns $locale
		    }
		}
	    }

	    # Add missing locales
	    Load $ns $loadLocales
	}
	default {
	    return -code error "unknown subcommand \"$subcommand\": must be\
		    clear, get, isset, loaded, present, set, or unset"
	}
    }
    return
}

# msgcat::mcforgetpackage --
#
#	Remove any data of the calling package from msgcat
#

proc msgcat::mcforgetpackage {} {
    # todo: this may be implemented using an ensemble
    variable PackageConfig
    variable Msgs
    set ns [uplevel 1 {::namespace current}]
    # Remove MC items
    dict unset Msgs $ns
    # Remove config items
    foreach key [dict keys $PackageConfig] {
	dict unset PackageConfig $key $ns
    }
    return
}

# msgcat::mcpackageconfig --
#
#	Get or modify the per caller namespace (e.g. packages) config options.
#
#	Available subcommands are:
#
#	    get		get the current value or an error if not set.
#	    isset	return true, if the option is set
#	    set		set the value (see also distinct option).
#			Returns the number of loaded message files.
#	    unset	Clear option. return "".
#
#	Available options are:
#
#	mcfolder
#	    The message catalog folder of the package.
#	    This is automatically set by mcload.
#	    If the value is changed using the set subcommand, an evntual
#	    loadcmd is invoked and all message files of the package locale are
#	    loaded.
#
#	loadcmd
#	    The command gets executed before a message file would be
#	    sourced for this module.
#	    The command is invoked with the expanded locale list to load.
#	    The command is not invoked if the registering package namespace
#	    is not present.
#	    This callback might also be used as an alternative to message
#	    files.
#	    If the value is changed using the set subcommand, the callback is
#	    directly invoked with the current file locale list. No file load is
#	    executed.
#
#	changecmd
#	    The command is invoked, after an executed locale change.
#	    Appended argument is expanded mcpreferences.
#
#	unknowncmd
#	    Use a package locale mcunknown procedure instead the global one.
#	    The appended arguments are identical to mcunknown.
#	    A default 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.
#
# Arguments:
#	subcommand		Operation on the package
#	option			The package option to get or set.
#	?value?			Eventual value for the subcommand
#
# Results:
#	Depends on the subcommand and option and is described there

proc msgcat::mcpackageconfig {subcommand option {value ""}} {
    variable PackageConfig
    # get namespace
    set ns [uplevel 1 {::namespace current}]

    if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} {
	return -code error "bad option \"$option\": must be mcfolder, loadcmd,\
		changecmd, or unknowncmd"
    }

    # check if value argument is exactly provided
    if {[llength [info level 0]] == 4 } {
	# value provided
	if {$subcommand in {"get" "isset" "unset"}} {
	    return -code error "wrong # args: should be\
		    \"[lrange [info level 0] 0 2] value\""
	}
    } elseif {$subcommand eq "set"} {
        return -code error\
		"wrong # args: should be \"[lrange [info level 0] 0 2]\""
    }

    # Execute subcommands
    switch -exact -- $subcommand {
	get {	# Operation get return current value
	    if {![dict exists $PackageConfig $option $ns]} {
		return -code error "package option \"$option\" not set"
	    }
	    return [dict get $PackageConfig $option $ns]
	}
	isset {	return [dict exists $PackageConfig $option $ns] }
	unset {	dict unset PackageConfig $option $ns }
	set {	# Set option
	
	    if {$option eq "mcfolder"} {
		set value [file normalize $value]
	    }
	    # Check if changed
	    if { [dict exists $PackageConfig $option $ns]
		    && $value eq [dict get $PackageConfig $option $ns] } {
		return 0
	    }

	    # set new value
	    dict set PackageConfig $option $ns $value

	    # Reload pending message catalogs
	    switch -exact -- $option {
		mcfolder { return [Load $ns [PackageLocales $ns]] }
		loadcmd { return [Load $ns [PackageLocales $ns] 1] }
	    }
	    return 0
	}
	default {
	    return -code error "unknown subcommand \"$subcommand\":\
		    must be get, isset, set, or unset"
	}
    }
    return
}

# msgcat::PackagePreferences --
#
#	Return eventual present package preferences or the default list if not
#	present.
#
# Arguments:
#	ns		Package namespace
#
# Results:
#	locale list

proc msgcat::PackagePreferences {ns} {
    variable PackageConfig
    if {[dict exists $PackageConfig loclist $ns]} {
	return [dict get $PackageConfig loclist $ns]
    }
    variable Loclist
    return $Loclist
}

# msgcat::PackageLocales --
#
#	Return eventual present package locales or the default list if not
#	present.
#
# Arguments:
#	ns		Package namespace
#
# Results:
#	locale list

proc msgcat::PackageLocales {ns} {
    variable PackageConfig
    if {[dict exists $PackageConfig loadedlocales $ns]} {
	return [dict get $PackageConfig loadedlocales $ns]
    }
    variable LoadedLocales
    return $LoadedLocales
}

# msgcat::ListComplement --
#
#	Build the complement of two lists.
#	Return a list with all elements in list2 but not in list1.
#	Optionally return the intersection.
#
# Arguments:
#	list1		excluded list
#	list2		included list
#	inlistname	If not "", write in this variable the intersection list
#
# Results:
#	list with all elements in list2 but not in list1

proc msgcat::ListComplement {list1 list2 {inlistname ""}} {
    if {"" ne $inlistname} {
	upvar 1 $inlistname inlist
    }
    set inlist {}
    set outlist {}
    foreach item $list2 {
	if {$item in $list1} {
	    lappend inlist $item
	} else {
	    lappend outlist $item
	}
    }
    return $outlist
}

# msgcat::mcload --
#
#	Attempt to load message catalogs for each locale in the
#	preference list from the specified directory.
#
# Arguments:
#	langdir		The directory to search.
#
# Results:
#	Returns the number of message catalogs that were loaded.

proc msgcat::mcload {langdir} {
    return [uplevel 1 [list\
	    [namespace origin mcpackageconfig] set mcfolder $langdir]]
}

# msgcat::LoadAll --
#
#	Load a list of locales for all packages not having a package locale
#	list.
#
# Arguments:
#	langdir		The directory to search.
#
# Results:
#	Returns the number of message catalogs that were loaded.

proc msgcat::LoadAll {locales} {
    variable PackageConfig
    variable LoadedLocales
    if {0 == [llength $locales]} { return {} }
    # filter jet unloaded locales
    set locales [ListComplement $LoadedLocales $locales]
    if {0 == [llength $locales]} { return {} }
    lappend LoadedLocales {*}$locales
    
    set packages [lsort -unique [concat\
	    [dict keys [dict get $PackageConfig loadcmd]]\
	    [dict keys [dict get $PackageConfig mcfolder]]]]
    foreach ns $packages {
	if {! [dict exists $PackageConfig loclist $ns] } {
	    Load $ns $locales
	}
    }
    return $locales
}

# msgcat::Load --
#
#	Invoke message load callback and load message catalog files.
#
# Arguments:
#	ns		Namespace (equal package) to load the message catalog.
#	locales		List of locales to load.
#	callbackonly	true if only callback should be invoked
#
# Results:
#	Returns the number of message catalogs that were loaded.

proc msgcat::Load {ns locales {callbackonly 0}} {
    variable FileLocale
    variable PackageConfig
    variable LoadedLocals

    if {0 == [llength $locales]} { return 0 }

    # Invoke callback
    Invoke loadcmd $locales $ns
    
    if {$callbackonly || ![dict exists $PackageConfig mcfolder $ns]} {
	return 0
    }

    # Invoke file load
    set langdir [dict get $PackageConfig mcfolder $ns]
    
    # Save the file locale if we are recursively called
    if {[info exists FileLocale]} {
	set nestedFileLocale $FileLocale
    }
    set x 0
    foreach p $locales {
	if {$p eq {}} {
	    set p ROOT
	}
	set langfile [file join $langdir $p.msg]
	if {[file exists $langfile]} {
	    incr x
	    set FileLocale [string tolower\
		    [file tail [file rootname $langfile]]]
	    if {"root" eq $FileLocale} {
		set FileLocale ""
	    }
	    namespace inscope $ns [list ::source -encoding utf-8 $langfile]
	    unset FileLocale
	}
    }
    if {[info exists nestedFileLocale]} {
	set FileLocale $nestedFileLocale
    }
    return $x
}

# msgcat::Invoke --
#
#	Invoke a set of registered callbacks.
#	The callback is only invoked, if its registered namespace exists.
#
# Arguments:
#	index		Index into PackageConfig to get callback command
#	arglist		parameters to the callback invocation
#	ns		(Optional) package to call.
#			If not given or empty, check all registered packages.
#	resultname	Variable to save the callback result of the last called
#			callback to. May be set to "" to discard the result.
#	failerror (0)	Fail on error if true. Otherwise call bgerror.
#
# Results:
#	Possible values:
#	- 0: no valid command registered
#	- 1: registered command was the empty string
#	- 2: registered command called, resultname is set
#	- 3: registered command failed
#	If multiple commands are called, the maximum of all results is returned.

proc msgcat::Invoke {index arglist {ns ""} {resultname ""} {failerror 0}} {
    variable PackageConfig
    variable Config
    if {"" ne $resultname} {
	upvar 1 $resultname result
    }
    if {"" eq $ns} {
	set packageList [dict keys [dict get $PackageConfig $index]]
    } else {
	set packageList [list $ns]
    }
    set ret 0
    foreach ns $packageList {
	if {[dict exists $PackageConfig $index $ns] && [namespace exists $ns]} {
	    set cmd [dict get $PackageConfig $index $ns]
	    if {"" eq $cmd} {
		if {$ret == 0} {set ret 1}
	    } else {
		if {$failerror} {
		    set result [namespace inscope $ns $cmd {*}$arglist]
		    set ret 2
		} elseif {1 == [catch {
		    set result [namespace inscope $ns $cmd {*}$arglist]
		    if {$ret < 2} {set ret 2}
		} err derr]} {
		    after idle [concat [::interp bgerror ""]\
			    [list $err $derr]]
		    set ret 3
		}
	    }
	}
    }
    return $ret
}

# msgcat::mcset --
#
#	Set the translation for a given string in a specified locale.
#
# Arguments:
#	locale		The locale to use.

	set dest $src
    }

    set ns [uplevel 1 [list ::namespace current]]

    set locale [string tolower $locale]

    dict set Msgs $ns $locale $src $dest
    return $dest
}

# msgcat::mcflset --
#
#	Set the translation for a given string in the current file locale.
#
# Arguments:
#	src		The source string.
#	dest		(Optional) The translated string.  If omitted,
#			the source string is used.
#
# Results:
#	Returns the new locale.

proc msgcat::mcflset {src {dest ""}} {
    variable FileLocale
    variable Msgs

    if {![info exists FileLocale]} {
	return -code error "must only be used inside a message catalog loaded\
		with ::msgcat::mcload"
    }



    return [uplevel 1 [list [namespace origin mcset] $FileLocale $src $dest]]



}

# msgcat::mcmset --
#
#	Set the translation for multiple strings in a specified locale.
#
# Arguments:
#	locale		The locale to use.
#	pairs		One or more src/dest pairs (must be even length)
#
# Results:
#	Returns the number of pairs processed

proc msgcat::mcmset {locale pairs} {
    variable Msgs

    set length [llength $pairs]
    if {$length % 2} {
	return -code error "bad translation list:\
		should be \"[lindex [info level 0] 0] locale {src dest ...}\""
    }

    set locale [string tolower $locale]
    set ns [uplevel 1 [list ::namespace current]]

    foreach {src dest} $pairs {
	dict set Msgs $ns $locale $src $dest
    }

    return [expr {$length / 2}]
}

# msgcat::mcflmset --
#
#	Set the translation for multiple strings in the mc file locale.
#
# Arguments:
#	pairs		One or more src/dest pairs (must be even length)
#
# Results:
#	Returns the number of pairs processed

proc msgcat::mcflmset {pairs} {
    variable FileLocale
    variable Msgs

    if {![info exists FileLocale]} {
	return -code error "must only be used inside a message catalog loaded\
		with ::msgcat::mcload"
    }





    return [uplevel 1 [list [namespace origin mcmset] $FileLocale $pairs]]





}

# msgcat::mcunknown --
#
#	This routine is called by msgcat::mc if a translation cannot
#	be found for a string and no unknowncmd is set for the current
#	package. This routine is intended to be replaced
#	by an application specific routine for error reporting
#	purposes.  The default behavior is to return the source string.
#	If additional args are specified, the format command will be used
#	to work them into the traslated string.
#
# Arguments:
#	locale		The current locale.
#	src		The string to be translated.
#	args		Args to pass to the format command
#
# Results:
#	Returns the translated value.

proc msgcat::mcunknown {args} {
    return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]]
}

# msgcat::DefaultUnknown --
#
#	This routine is called by msgcat::mc if a translation cannot
#	be found for a string in the following circumstances:
#	- Default global handler, if mcunknown is not redefined.
#	- Per package handler, if the package sets unknowncmd to the empty
#	  string.
#	It returna the source string if the argument list is empty.
#	If additional args are specified, the format command will be used
#	to work them into the traslated string.
#
# Arguments:
#	locale		(unused) The current locale.
#	src		The string to be translated.
#	args		Args to pass to the format command
#
# Results:
#	Returns the translated value.

proc msgcat::DefaultUnknown {locale src args} {
    if {[llength $args]} {
	return [format $src {*}$args]
    } else {
	return $src
    }
}

if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
package ifneeded msgcat 1.6.0 [list source [file join $dir msgcat.tcl]]

# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.

package require Tcl 8.5-
if {[catch {package require tcltest 2}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2 required."
    return
}
if {[catch {package require msgcat 1.6}]} {
    puts stderr "Skipping tests in [info script].  No msgcat 1.6 found to test."
    return
}

namespace eval ::msgcat::test {
    namespace import ::msgcat::*
    namespace import ::tcltest::test
    namespace import ::tcltest::cleanupTests
    namespace import ::tcltest::temporaryDirectory
    namespace import ::tcltest::make*
    namespace import ::tcltest::remove*

    # Tests msgcat-0.*: locale initialization

    # Calculate set of all permutations of a list
    # PowerSet {1 2 3} -> {1 2 3} {2 3} {1 3} 3 {1 2} 2 1 {}
    proc PowerSet {l} {
	if {[llength $l] == 0} {return [list [list]]}
	set element [lindex $l 0]
	set rest [lrange $l 1 end]
	set result [list]
	foreach x [PowerSet $rest] {
	    lappend result [linsert $x 0 $element]

	}
	makeFile [list ::msgcat::mcset $loc abc abc-$loc] $msg.msg $msgdir
    }
    variable count 1
    foreach loc {foo foo_BAR foo_BAR_baz} {
	test msgcat-5.$count {mcload} -setup {
	    variable locale [mclocale]
	    ::msgcat::mclocale ""
	    ::msgcat::mcloadedlocales clear
	    ::msgcat::mcpackageconfig unset mcfolder 
	    mclocale $loc
	} -cleanup {
	    mclocale $locale
	    ::msgcat::mcloadedlocales clear
	    ::msgcat::mcpackageconfig unset mcfolder 
	} -body {
	    mcload $msgdir
	} -result [expr { $count+1 }]
	incr count
    }

    # Even though foo_BAR_notexist does not exist,
    # foo_BAR, foo and the root should be loaded.
	test msgcat-5.4 {mcload} -setup {
	    variable locale [mclocale]
	    mclocale foo_BAR_notexist
	} -cleanup {
	    mclocale $locale
	    mcloadedlocales clear
	    mcpackageconfig unset mcfolder 
	} -body {
	    mcload $msgdir
	} -result 3

	test msgcat-5.5 {mcload} -setup {
	    variable locale [mclocale]
	    mclocale no_FI_notexist
	} -cleanup {
	    mclocale $locale
	    mcloadedlocales clear
	    mcpackageconfig unset mcfolder 
	} -body {
	    mcload $msgdir
	} -result 1

	test msgcat-5.6 {mcload} -setup {
	    variable locale [mclocale]
	    mclocale foo

	} -cleanup {
	    mclocale $locale
	    rename ::msgcat::mcunknown {}
	    rename SavedMcunknown ::msgcat::mcunknown
	} -body {
	    mc def
	} -result unknown:no_fi_notexist:def

	test msgcat-5.11 {mcpackageconfig mcfolder} -setup {
	    variable locale [mclocale]
	    mclocale ""
	    mcloadedlocales clear
	    mcpackageconfig unset mcfolder
	} -cleanup {
	    mclocale $locale
	    mcloadedlocales clear
	    mcpackageconfig unset mcfolder 
	} -body {
	    mclocale foo
	    mcpackageconfig set mcfolder $msgdir
	} -result 2

    foreach loc $locales {
	if { $loc eq {} } {
	    set msg ROOT
        } else {
	    set msg [string tolower $loc]
	}

	    return [mc k2][mc k3]
	} -result v2v3

    removeFile l2.msg $msgdir2
    removeDirectory msgdir2
    removeDirectory msgdir3

    # Tests msgcat-9.*: [mcexists]

	test msgcat-9.1 {mcexists no parameter} -body {
	    mcexists
	} -returnCodes 1\
	-result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? src"}
    
	test msgcat-9.2 {mcexists unknown option} -body {
	    mcexists -unknown src 
	} -returnCodes 1\
	-result {unknown option "-unknown"}
    
	test msgcat-9.3 {mcexists} -setup {
	    mcforgetpackage
	    variable locale [mclocale]
	    mclocale foo
	    mcset foo k1 v1
	} -cleanup {
	    mclocale $locale
	} -body {
	    list [mcexists k1] [mcexists k2]
	} -result {1 0}

	test msgcat-9.4 {mcexists descendent preference} -setup {
	    mcforgetpackage
	    variable locale [mclocale]
	    mclocale foo_bar
	    mcset foo k1 v1
	} -cleanup {
	    mclocale $locale
	} -body {
	    list [mcexists k1] [mcexists -exactlocale k1]
	} -result {1 0}
    
	test msgcat-9.5 {mcexists parent namespace} -setup {
	    mcforgetpackage
	    variable locale [mclocale]
	    mclocale foo_bar
	    mcset foo k1 v1
	} -cleanup {
	    mclocale $locale
	} -body {
	    namespace eval ::msgcat::test::sub {
		list [::msgcat::mcexists k1]\
			[::msgcat::mcexists -exactnamespace k1]
	    }
	} -result {1 0}
    
    # Tests msgcat-10.*: [mcloadedlocales]

	test msgcat-10.1 {mcloadedlocales no arg} -body {
	    mcloadedlocales
	} -returnCodes 1\
	-result {wrong # args: should be "mcloadedlocales subcommand"}
    
	test msgcat-10.2 {mcloadedlocales wrong subcommand} -body {
	    mcloadedlocales junk
	} -returnCodes 1\
	-result {unknown subcommand "junk": must be clear, or loaded}
    
	test msgcat-10.3 {mcloadedlocales loaded} -setup {
	    mcforgetpackage
	    variable locale [mclocale]
	    mclocale {}
	    mcloadedlocales clear
	} -cleanup {
	    mclocale $locale
	} -body {
	    mclocale foo_bar
	    # The result is position independent so sort
	    set resultlist [lsort [mcloadedlocales loaded]]
	} -result {{} foo foo_bar}
    
	test msgcat-10.4 {mcloadedlocales clear} -setup {
	    mcforgetpackage
	    variable locale [mclocale]
	    mclocale {}
	    mcloadedlocales clear
	} -cleanup {
	    mclocale $locale
	} -body {
	    mclocale foo
	    mcset foo k1 v1
	    set res [mcexists k1]
	    mclocale ""
	    mcloadedlocales clear
	    mclocale foo
	    lappend res [mcexists k1]
	} -result {1 0}

    # Tests msgcat-11.*: [mcforgetpackage]

	test msgcat-11.1 {mcforgetpackage translation} -setup {
	    variable locale [mclocale]
	} -cleanup {
	    mclocale $locale
	} -body {
	    mclocale foo
	    mcset foo k1 v1
	    set res [mcexists k1]
	    mcforgetpackage
	    lappend res [mcexists k1]
	} -result {1 0}

	test msgcat-11.2 {mcforgetpackage locale} -setup {
	    variable locale [mclocale]
	} -cleanup {
	    mclocale $locale
	} -body {
	    mclocale foo
	    mcpackagelocale set bar
	    set res [mcpackagelocale get]
	    mcforgetpackage
	    lappend res [mcpackagelocale get]
	} -result {bar foo}

	test msgcat-11.3 {mcforgetpackage options} -body {
	    mcpackageconfig set loadcmd ""
	    set res [mcpackageconfig isset loadcmd]
	    mcforgetpackage
	    lappend res [mcpackageconfig isset loadcmd]
	} -result {1 0}

    # Tests msgcat-12.*: [mcpackagelocale]

	test msgcat-12.1 {mcpackagelocale no subcommand} -body {
	    mcpackagelocale
	} -returnCodes 1\
	-result {wrong # args: should be "mcpackagelocale subcommand ?locale?"}

	test msgcat-12.2 {mclpackagelocale wrong subcommand} -body {
	    mcpackagelocale junk
	} -returnCodes 1\
	-result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset}

	test msgcat-12.3 {mcpackagelocale set} -setup {
	    variable locale [mclocale]
	} -cleanup {
	    mclocale $locale
	    mcforgetpackage
	} -body {
	    mclocale foo
	    mcpackagelocale set bar
	    list [mcpackagelocale get] [mclocale]
	} -result {bar foo}

	test msgcat-12.4 {mcpackagelocale get} -setup {
	    variable locale [mclocale]
	} -cleanup {
	    mclocale $locale
	    mcforgetpackage
	} -body {
	    mclocale foo
	    set res [mcpackagelocale get]
	    mcpackagelocale set bar
	    lappend res [mcpackagelocale get]
	} -result {foo bar}

	test msgcat-12.5 {mcpackagelocale preferences} -setup {
	    variable locale [mclocale]
	} -cleanup {
	    mclocale $locale
	    mcforgetpackage
	} -body {
	    mclocale foo
	    set res [list [mcpackagelocale preferences]]
	    mcpackagelocale set bar
	    lappend res [mcpackagelocale preferences]
	} -result {{foo {}} {bar {}}}

	test msgcat-12.6 {mcpackagelocale loaded} -setup {
	    variable locale [mclocale]
	} -cleanup {
	    mclocale $locale
	    mcforgetpackage
	} -body {
	    mclocale ""
	    mcloadedlocales clear
	    mclocale foo
	    # The result is position independent so sort
	    set res [list [lsort [mcpackagelocale loaded]]]
	    mcpackagelocale set bar
	    lappend res [lsort [mcpackagelocale loaded]]
	} -result {{{} foo} {{} bar foo}}

	test msgcat-12.7 {mcpackagelocale isset} -setup {
	    variable locale [mclocale]
	} -cleanup {
	    mclocale $locale
	    mcforgetpackage
	} -body {
	    mclocale foo
	    set res [mcpackagelocale isset]
	    mcpackagelocale set bar
	    lappend res [mcpackagelocale isset]
	} -result {0 1}

	test msgcat-12.8 {mcpackagelocale unset} -setup {
	    variable locale [mclocale]
	} -cleanup {
	    mclocale $locale
	    mcforgetpackage
	} -body {
	    mcpackagelocale set bar
	    set res [mcpackagelocale isset]
	    mcpackagelocale unset
	    lappend res [mcpackagelocale isset]
	} -result {1 0}

	test msgcat-12.9 {mcpackagelocale present} -setup {
	    variable locale [mclocale]
	} -cleanup {
	    mclocale $locale
	    mcforgetpackage
	} -body {
	    mclocale ""
	    mcloadedlocales clear
	    mclocale foo
	    set res [mcpackagelocale present foo]
	    lappend res [mcpackagelocale present bar]
	    mcpackagelocale set bar
	    lappend res [mcpackagelocale present foo]\
		    [mcpackagelocale present bar]
	} -result {1 0 1 1}

	test msgcat-12.10 {mcpackagelocale clear} -setup {
	    variable locale [mclocale]
	} -cleanup {
	    mclocale $locale
	    mcforgetpackage
	} -body {
	    mclocale ""
	    mcloadedlocales clear
	    mclocale foo
	    mcpackagelocale set bar
	    mcpackagelocale clear
	    list [mcpackagelocale present foo] [mcpackagelocale present bar]
	} -result {0 1}

    # Tests msgcat-13.*: [mcpackageconfig subcmds]

	test msgcat-13.1 {mcpackageconfig no subcommand} -body {
	    mcpackageconfig
	} -returnCodes 1\
	-result {wrong # args: should be "mcpackageconfig subcommand option ?value?"}

	test msgcat-13.2 {mclpackageconfig wrong subcommand} -body {
	    mcpackageconfig junk mcfolder
	} -returnCodes 1\
	-result {unknown subcommand "junk": must be get, isset, set, or unset}

	test msgcat-13.3 {mclpackageconfig wrong option} -body {
	    mcpackageconfig get junk
	} -returnCodes 1\
	-result {bad option "junk": must be mcfolder, loadcmd, changecmd, or unknowncmd}

	test msgcat-13.4 {mcpackageconfig get} -setup {
	    mcforgetpackage
	} -cleanup {
	    mcforgetpackage
	} -body {
	    mcpackageconfig set loadcmd ""
	    mcpackageconfig get loadcmd
	} -result {}

	test msgcat-13.5 {mcpackageconfig (is/un)set} -setup {
	    mcforgetpackage
	} -cleanup {
	    mcforgetpackage
	} -body {
	    set res [mcpackageconfig isset loadcmd]
	    lappend res [mcpackageconfig set loadcmd ""]
	    lappend res [mcpackageconfig isset loadcmd]
	    mcpackageconfig unset loadcmd
	    lappend res [mcpackageconfig isset loadcmd]
	} -result {0 0 1 0}

    # option mcfolder is already tested with 5.11
    
    # Tests msgcat-14.*: callbacks: loadcmd, changecmd, unknowncmd
    
    # This routine is used as bgerror and by direct callback invocation
    proc callbackproc args {
	variable resultvariable
	set resultvariable $args
    }
    proc callbackfailproc args {
	return -code error fail
    }
    set bgerrorsaved [interp bgerror {}]
    interp bgerror {} [namespace code callbackproc]
    
	test msgcat-14.1 {invokation loadcmd} -setup {
	    mcforgetpackage
    	    mclocale $locale
	    mclocale ""
	    mcloadedlocales clear
	    set resultvariable ""
	} -cleanup {
	    mcforgetpackage
	} -body {
	    mcpackageconfig set loadcmd [namespace code callbackproc]
	    mclocale foo_bar
	    lsort $resultvariable
	} -result {foo foo_bar}

	test msgcat-14.2 {invokation failed in loadcmd} -setup {
	    mcforgetpackage
    	    mclocale $locale
	    mclocale ""
	    mcloadedlocales clear
	} -cleanup {
	    mcforgetpackage
	} -body {
	    mcpackageconfig set loadcmd [namespace code callbackfailproc]
	    mclocale foo_bar
	    # let the bgerror run
	    after 100 set [namespace current]::resultvariable timeout
	    vwait [namespace current]::resultvariable
	    lassign $resultvariable err errdict
	    list $err [dict get $errdict -code]
	} -result {fail 1}

	test msgcat-14.3 {invokation changecmd} -setup {
	    mcforgetpackage
    	    mclocale $locale
	    mclocale ""
	    set resultvariable ""
	} -cleanup {
	    mcforgetpackage
	} -body {
	    mcpackageconfig set changecmd [namespace code callbackproc]
	    mclocale foo_bar
	    set resultvariable
	} -result {foo_bar foo {}}

	test msgcat-14.4 {invokation unknowncmd} -setup {
	    mcforgetpackage
    	    mclocale $locale
	    mclocale ""
	    mcloadedlocales clear
	    set resultvariable ""
	} -cleanup {
	    mcforgetpackage
	} -body {
	    mcpackageconfig set unknowncmd [namespace code callbackproc]
	    mclocale foo_bar
	    mc k1 p1
	    set resultvariable
	} -result {foo_bar k1 p1}

	test msgcat-14.5 {disable global unknowncmd} -setup {
	    mcforgetpackage
    	    mclocale $locale
	    mclocale ""
	    mcloadedlocales clear
	    set resultvariable ""
	    rename ::msgcat::mcunknown SavedMcunknown
	    proc ::msgcat::mcunknown {dom s} {
		return unknown:$dom:$s
	    }
	} -cleanup {
	    mcforgetpackage
	    rename ::msgcat::mcunknown {}
	    rename SavedMcunknown ::msgcat::mcunknown
	} -body {
	    mcpackageconfig set unknowncmd ""
	    mclocale foo_bar
	    mc k1%s p1
	} -result {k1p1}

	test msgcat-14.6 {unknowncmd failing} -setup {
	    mcforgetpackage
    	    mclocale $locale
	    mclocale ""
	    mcloadedlocales clear
	    set resultvariable ""
	} -cleanup {
	    mcforgetpackage
	} -body {
	    mcpackageconfig set unknowncmd [namespace code callbackfailproc]
	    mclocale foo_bar
	    mc k1
	} -returnCodes 1\
	-result {fail}

    interp bgerror {} $bgerrorsaved

    cleanupTests
}
namespace delete ::msgcat::test
return

	@echo "Installing package http 2.8.9 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.9.tm;
	@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
	@for i in $(TOP_DIR)/library/opt/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
	    done;
	@echo "Installing package msgcat 1.6.0 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.0.tm;
	@echo "Installing package tcltest 2.3.8 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.8.tm;

	@echo "Installing package platform 1.0.13 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.13.tm;
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;

	@echo "Installing package http 2.8.9 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.9.tm;
	@echo "Installing library opt0.4 directory";
	@for j in $(ROOT_DIR)/library/opt/*.tcl; \
	    do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
	    done;
	@echo "Installing package msgcat 1.6.0 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.0.tm;
	@echo "Installing package tcltest 2.3.8 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.8.tm;
	@echo "Installing package platform 1.0.13 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.13.tm;
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm;
	@echo "Installing encodings";