Tcl Source Code

2005-09-12  Don Porter  <[email protected]>

	[kennykb-numerics-branch]	Merge updates from HEAD.

	* generic/tclCmdAH.c:		Added support for the "ll" width	
	* generic/tclStringObj.c:	specifier to [format].

2005-09-15  Don Porter  <[email protected]>

	[kennykb-numerics-branch]	Merge updates from HEAD.

	* generic/tclStringObj.c (TclAppendFormattedObjs):	Revision
	to eliminate one round of string copying.

	* generic/tclBasic.c:	More callers of TclObjPrintf and
	* generic/tclCkalloc.c:	TclFormatToErrorInfo.
	* generic/tclCmdMZ.c:
	* generic/tclExecute.c:
	* generic/tclIORChan.c:
	* generic/tclMain.c:
	* generic/tclProc.c:
	* generic/tclTimer.c:
	* generic/tclUtil.c:
	* unix/tclUnixFCmd.c

	* unix/configure:	autoconf-2.59

2005-09-15  Donal K. Fellows  <[email protected]>

	* unix/tcl.m4 (SC_TCL_EARLY_FLAGS): Added extra hack to allow Tcl
	to transparently open large files on RHEL 3. [Bug 1287638]

2005-09-14  Don Porter  <[email protected]>

	* generic/tclStringObj.c:	Bug fixes: ObjPrintfVA needed to
	support "*" fields and needed to interpret precision limits on
	%s conversions as a maximum number of bytes, not Tcl_UniChars, to
	take from the (char *) argument.

	* generic/tclBasic.c:	Updated several callers to use
	* generic/tclCkalloc.c: TclFormatToErrorInfo() and/or
	* generic/tclCmdAH.c:	TclObjPrintf().
	* generic/tclCmdIL.c:	
	* generic/tclCmdMZ.c:	
	* generic/tclDictObj.c:
	* generic/tclExecute.c:
	* generic/tclIORChan.c:	
	* generic/tclIOUtil.c:	
	* generic/tclNamesp.c:
	* generic/tclProc.c:

	* library/init.tcl:	Keep [unknown] in sync with errorInfo
	formatting rules.

2005-09-13  Don Porter  <[email protected]>

	* generic/tclBasic.c:	First caller of TclFormatToErrorInfo.

	* generic/tclInt.h:		Using stdarg.h conventions, add more
	* generic/tclStringObj.c:	fixed arguments to TclFormatObj() and
	TclObjPrintf().  Added new routine TclFormatToErrorInfo().

	* generic/tcl.h:	Explicitly standardized on the use of stdarg.h
	* generic/tclBasic.c:	conventions for functions with variable number
	* generic/tclInt.h:	of arguments.  Support for varargs.h has been
	* generic/tclPanic.c:	implicitly gone for some time now.  All
	* generic/tclResult.c:	TCL_VARARGS* macros purged from Tcl sources,
	* generic/tclStringObj.c:	leaving only some deprecated #define's
	* tools/genStubs.tcl:	in tcl.h for the sake of older extensions.

	* generic/tclDecls.h:	make genstubs

	* doc/AddErrInfo.3:	Replaced all documented requirement for use
	* doc/Eval.3:		of TCL_VARARGS_START() with requirement for
	* doc/Panic.3:		use of va_start().
	* doc/SetResult.3:
	* doc/StringObj.3:

2005-09-12  Don Porter  <[email protected]>

	[kennykb-numerics-branch]	Merge updates from HEAD.

	* generic/tclCmdAH.c:		Added support for the "ll" width	
	* generic/tclStringObj.c:	specifier to [format].

'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: AddErrInfo.3,v 1.13.2.1 2005/08/15 18:13:58 dgp Exp $
'\" 
.so man.macros
.TH Tcl_AddErrorInfo 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.VS 8.5
................................................................................
.AP Tcl_Obj *errorObjPtr in
The \fB-errorcode\fR return option will be set to this value.
.AP char *element in
String to record as one element of the \fB-errorcode\fR return option.
Last \fIelement\fR argument must be NULL.
.AP va_list argList in
An argument list which must have been initialized using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.AP "const char" *script in
Pointer to first character in script containing command (must be <= command)
.AP "const char" *command in
Pointer to first character in command that generated the error
.AP int commandLength in
Number of bytes in command; -1 means use all bytes up to first null byte
.BE

'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: AddErrInfo.3,v 1.13.2.2 2005/09/15 20:58:38 dgp Exp $
'\" 
.so man.macros
.TH Tcl_AddErrorInfo 3 8.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.VS 8.5
................................................................................
.AP Tcl_Obj *errorObjPtr in
The \fB-errorcode\fR return option will be set to this value.
.AP char *element in
String to record as one element of the \fB-errorcode\fR return option.
Last \fIelement\fR argument must be NULL.
.AP va_list argList in
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
.AP "const char" *script in
Pointer to first character in script containing command (must be <= command)
.AP "const char" *command in
Pointer to first character in command that generated the error
.AP int commandLength in
Number of bytes in command; -1 means use all bytes up to first null byte
.BE

'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Eval.3,v 1.18.2.2 2005/05/05 17:55:20 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts
.SH SYNOPSIS
................................................................................
first null byte are used.
.AP "const char" *script in
Points to first byte of script to execute (null-terminated and UTF-8).
.AP char *part in
String forming part of a Tcl script.
.AP va_list argList in
An argument list which must have been initialized using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.BE

.SH DESCRIPTION
.PP
The procedures described here are invoked to execute Tcl scripts in
various forms.
\fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others.

'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Eval.3,v 1.18.2.3 2005/09/15 20:58:38 dgp Exp $
'\" 
.so man.macros
.TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts
.SH SYNOPSIS
................................................................................
first null byte are used.
.AP "const char" *script in
Points to first byte of script to execute (null-terminated and UTF-8).
.AP char *part in
String forming part of a Tcl script.
.AP va_list argList in
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
.BE

.SH DESCRIPTION
.PP
The procedures described here are invoked to execute Tcl scripts in
various forms.
\fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others.

'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Panic.3,v 1.7 2004/10/07 15:15:47 dkf Exp $
'\" 
.so man.macros
.TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures"
.BS
'\"  Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc \- report fatal error and abort
................................................................................
.AS Tcl_PanicProc *panicProc
.AP "const char*" format in
A printf-style format string.
.AP "" arg in
Arguments matching the format string.
.AP va_list argList in
An argument list of arguments matching the format string.
Must have been initialized using \fBTCL_VARARGS_START\fR,
and cleared using \fBva_end\fR.
.AP Tcl_PanicProc *panicProc in
Procedure to report fatal error message and abort.

.BE

.SH DESCRIPTION

'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Panic.3,v 1.7.2.1 2005/09/15 20:58:38 dgp Exp $
'\" 
.so man.macros
.TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures"
.BS
'\"  Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc \- report fatal error and abort
................................................................................
.AS Tcl_PanicProc *panicProc
.AP "const char*" format in
A printf-style format string.
.AP "" arg in
Arguments matching the format string.
.AP va_list argList in
An argument list of arguments matching the format string.
Must have been initialized using \fBva_start\fR,
and cleared using \fBva_end\fR.
.AP Tcl_PanicProc *panicProc in
Procedure to report fatal error message and abort.

.BE

.SH DESCRIPTION

'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: SetResult.3,v 1.11.2.1 2005/05/05 17:55:23 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_FreeResult \- manipulate Tcl result
.SH SYNOPSIS
................................................................................
to the existing result of \fIinterp\fR.
.AP Tcl_FreeProc *freeProc in
Address of procedure to call to release storage at
\fIresult\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or
\fBTCL_VOLATILE\fR.
.AP va_list argList in
An argument list which must have been initialized using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.BE

.SH DESCRIPTION
.PP
The procedures described here are utilities for manipulating the
result value in a Tcl interpreter.
The interpreter result may be either a Tcl object or a string.

'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: SetResult.3,v 1.11.2.2 2005/09/15 20:58:38 dgp Exp $
'\" 
.so man.macros
.TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_FreeResult \- manipulate Tcl result
.SH SYNOPSIS
................................................................................
to the existing result of \fIinterp\fR.
.AP Tcl_FreeProc *freeProc in
Address of procedure to call to release storage at
\fIresult\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or
\fBTCL_VOLATILE\fR.
.AP va_list argList in
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
.BE

.SH DESCRIPTION
.PP
The procedures described here are utilities for manipulating the
result value in a Tcl interpreter.
The interpreter result may be either a Tcl object or a string.

'\"
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: StringObj.3,v 1.17.2.1 2005/04/10 23:14:42 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendObjToObj, Tcl_SetObjLength, Tcl_ConcatObj, Tcl_AttemptSetObjLength \- manipulate Tcl objects as strings
.SH SYNOPSIS
................................................................................
.AP int *lengthPtr out
If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store
the length of an object's string representation.
.AP "const char" *string in
Null-terminated string value to append to \fIobjPtr\fR.
.AP va_list argList in
An argument list which must have been initialised using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.AP int newLength in
New length for the string value of \fIobjPtr\fR, not including the
final null character.
.AP int objc in
The number of elements to concatenate.
.AP Tcl_Obj *objv[] in
The array of objects to concatenate.

'\"
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: StringObj.3,v 1.17.2.2 2005/09/15 20:58:39 dgp Exp $
'\" 
.so man.macros
.TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendObjToObj, Tcl_SetObjLength, Tcl_ConcatObj, Tcl_AttemptSetObjLength \- manipulate Tcl objects as strings
.SH SYNOPSIS
................................................................................
.AP int *lengthPtr out
If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store
the length of an object's string representation.
.AP "const char" *string in
Null-terminated string value to append to \fIobjPtr\fR.
.AP va_list argList in
An argument list which must have been initialised using
\fBva_start\fR, and cleared using \fBva_end\fR.
.AP int newLength in
New length for the string value of \fIobjPtr\fR, not including the
final null character.
.AP int objc in
The number of elements to concatenate.
.AP Tcl_Obj *objv[] in
The array of objects to concatenate.

 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tcl.h,v 1.191.2.9 2005/09/09 18:48:40 dgp Exp $
 */

#ifndef _TCL
#define _TCL

/*
 * For C++ compilers, use extern "C"
................................................................................
 * should, so also for their sake, we keep the #include to be consistent with
 * prior Tcl releases.
 */

#include <stdio.h>

/*
 * Definitions that allow Tcl functions with variable numbers of arguments to
 * be used with either varargs.h or stdarg.h. TCL_VARARGS is used in function
 * prototypes. TCL_VARARGS_DEF is used to declare the arguments in a function
 * definiton: it takes the type and name of the first argument and supplies
 * the appropriate argument declaration string for use in the function
 * definition. TCL_VARARGS_START initializes the va_list data structure and
 * returns the first argument.
 */

#if !defined(NO_STDARG)
#   include <stdarg.h>
#   define TCL_VARARGS(type, name) (type name, ...)
#   define TCL_VARARGS_DEF(type, name) (type name, ...)
#   define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)
#else
#   include <varargs.h>
#   define TCL_VARARGS(type, name) ()
#   define TCL_VARARGS_DEF(type, name) (va_alist)
#   define TCL_VARARGS_START(type, name, list) \
	(va_start(list), va_arg(list, type))
#endif

/*
 * Macros used to declare a function to be exported by a DLL. Used by Windows,
 * maps to no-op declarations on non-Windows systems. The default build on
 * windows is for a DLL, which causes the DLLIMPORT and DLLEXPORT macros to be
 * nonempty. To build a static library, the macro STATIC_BUILD should be
................................................................................
	Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr));
typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv));
typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef int (Tcl_PackageUnloadProc) _ANSI_ARGS_((Tcl_Interp *interp,
	int flags));
typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(CONST char *, format));
typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
	Tcl_Channel chan, char *address, int port));
typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp,
	struct Tcl_Obj *objPtr));
typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,

 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tcl.h,v 1.191.2.10 2005/09/15 20:58:39 dgp Exp $
 */

#ifndef _TCL
#define _TCL

/*
 * For C++ compilers, use extern "C"
................................................................................
 * should, so also for their sake, we keep the #include to be consistent with
 * prior Tcl releases.
 */

#include <stdio.h>

/*
 * Support for functions with a variable number of arguments.
 *
 * The following TCL_VARARGS* macros are to support old extensions
 * written for older versions of Tcl where the macros permitted
 * support for the varargs.h system as well as stdarg.h .  
 *
 * New code should just directly be written to use stdarg.h conventions.
 */

#include <stdarg.h>
#ifndef TCL_NO_DEPRECATED
#    define TCL_VARARGS(type, name) (type name, ...)
#    define TCL_VARARGS_DEF(type, name) (type name, ...)
#    define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)






#endif

/*
 * Macros used to declare a function to be exported by a DLL. Used by Windows,
 * maps to no-op declarations on non-Windows systems. The default build on
 * windows is for a DLL, which causes the DLLIMPORT and DLLEXPORT macros to be
 * nonempty. To build a static library, the macro STATIC_BUILD should be
................................................................................
	Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr));
typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv));
typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef int (Tcl_PackageUnloadProc) _ANSI_ARGS_((Tcl_Interp *interp,
	int flags));
typedef void (Tcl_PanicProc) _ANSI_ARGS_((CONST char *format, ...));
typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
	Tcl_Channel chan, char *address, int port));
typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp,
	struct Tcl_Obj *objPtr));
typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,

 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBasic.c,v 1.136.2.33 2005/09/09 18:48:40 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include <float.h>
#include <math.h>
#include "tommath.h"
................................................................................
    CONST char *command;	/* First character in command that generated
				 * the error. */
    int length;			/* Number of bytes in command (-1 means use
				 * all bytes up to first null byte). */
{
    register CONST char *p;
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *message;

    if (iPtr->flags & ERR_ALREADY_LOGGED) {
	/*
	 * Someone else has already logged error information for this command;
	 * we shouldn't add anything more.
	 */

................................................................................
    iPtr->errorLine = 1;
    for (p = script; p != command; p++) {
	if (*p == '\n') {
	    iPtr->errorLine++;
	}
    }



    if (iPtr->errorInfo == NULL) {
	message = Tcl_NewStringObj("\n    while executing\n\"", -1);
    } else {
	message = Tcl_NewStringObj("\n    invoked from within\n\"", -1);
    }
    Tcl_IncrRefCount(message);
    TclAppendLimitedToObj(message, command, length, 153, NULL);
    Tcl_AppendToObj(message, "\"", -1);
    TclAppendObjToErrorInfo(interp, message);
    Tcl_DecrRefCount(message);

}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalTokensStandard --
 *
................................................................................
		Tcl_IncrRefCount(objv[objectsUsed]);
		if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
		    int numElements;

		    code = Tcl_ListObjLength(interp,
			    objv[objectsUsed], &numElements);
		    if (code == TCL_ERROR) {
			/*
			 * Attempt to expand a non-list.
			 */

			Tcl_Obj *msg;
			Tcl_Obj *wordNum;

			msg = Tcl_NewStringObj("\n    (expanding word ", -1);
			TclNewIntObj(wordNum, objectsUsed);
			Tcl_IncrRefCount(wordNum);
			Tcl_IncrRefCount(msg);
			Tcl_AppendObjToObj(msg, wordNum);
			Tcl_DecrRefCount(wordNum);
			Tcl_AppendToObj(msg, ")", -1);
			TclAppendObjToErrorInfo(interp, msg);
			Tcl_DecrRefCount(msg);

			Tcl_DecrRefCount(objv[objectsUsed]);
			goto error;
		    }
		    expandRequested = 1;
		    expand[objectsUsed] = 1;
		    objectsNeeded += (numElements ? numElements : 1);
		} else {
................................................................................
    if (returnCode == TCL_BREAK) {
	Tcl_AppendResult(interp,
		"invoked \"break\" outside of a loop", (char *) NULL);
    } else if (returnCode == TCL_CONTINUE) {
	Tcl_AppendResult(interp,
		"invoked \"continue\" outside of a loop", (char *) NULL);
    } else {
	char buf[30 + TCL_INTEGER_SPACE];

	sprintf(buf, "command returned bad code: %d", returnCode);
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
    }
}
 
/*
 *---------------------------------------------------------------------------
 *
 * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
................................................................................
 *	left in interp->result.
 *
 * Side effects:
 *	Depends on what was done by the command.
 *
 *----------------------------------------------------------------------
 */
	/* VARARGS2 */ /* ARGSUSED */
int
Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
    Tcl_Interp *interp;
    va_list argList;
    int result;

    interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
    result = Tcl_VarEvalVA(interp, argList);
    va_end(argList);

    return result;
}
 
/*

 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBasic.c,v 1.136.2.34 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include <float.h>
#include <math.h>
#include "tommath.h"
................................................................................
    CONST char *command;	/* First character in command that generated
				 * the error. */
    int length;			/* Number of bytes in command (-1 means use
				 * all bytes up to first null byte). */
{
    register CONST char *p;
    Interp *iPtr = (Interp *) interp;
    int overflow, limit = 150;

    if (iPtr->flags & ERR_ALREADY_LOGGED) {
	/*
	 * Someone else has already logged error information for this command;
	 * we shouldn't add anything more.
	 */

................................................................................
    iPtr->errorLine = 1;
    for (p = script; p != command; p++) {
	if (*p == '\n') {
	    iPtr->errorLine++;
	}
    }

    overflow = (length > limit);
    TclFormatToErrorInfo(interp, "\n    %s\n\"%.*s%s\"",
	    ((iPtr->errorInfo == NULL)


	    ? "while executing" : "invoked from within"),






	    (overflow ? limit : length), command, (overflow ? "..." : ""));
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalTokensStandard --
 *
................................................................................
		Tcl_IncrRefCount(objv[objectsUsed]);
		if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
		    int numElements;

		    code = Tcl_ListObjLength(interp,
			    objv[objectsUsed], &numElements);
		    if (code == TCL_ERROR) {

			/* Attempt to expand a non-list. */












			TclFormatToErrorInfo(interp,

				"\n    (expanding word %d)", objectsUsed);
			Tcl_DecrRefCount(objv[objectsUsed]);
			goto error;
		    }
		    expandRequested = 1;
		    expand[objectsUsed] = 1;
		    objectsNeeded += (numElements ? numElements : 1);
		} else {
................................................................................
    if (returnCode == TCL_BREAK) {
	Tcl_AppendResult(interp,
		"invoked \"break\" outside of a loop", (char *) NULL);
    } else if (returnCode == TCL_CONTINUE) {
	Tcl_AppendResult(interp,
		"invoked \"continue\" outside of a loop", (char *) NULL);
    } else {
	Tcl_Obj *objPtr = Tcl_NewObj();

	TclObjPrintf(NULL, objPtr, "command returned bad code: %d", returnCode);
	Tcl_SetObjResult(interp, objPtr);
    }
}
 
/*
 *---------------------------------------------------------------------------
 *
 * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
................................................................................
 *	left in interp->result.
 *
 * Side effects:
 *	Depends on what was done by the command.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
int
Tcl_VarEval(Tcl_Interp *interp, ...)
{

    va_list argList;
    int result;

    va_start(argList, interp);
    result = Tcl_VarEvalVA(interp, argList);
    va_end(argList);

    return result;
}
 
/*

 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * This code contributed by Karl Lehenbauer and Mark Diekhans
 *
 * RCS: @(#) $Id: tclCkalloc.c,v 1.22.2.1 2005/08/02 18:15:12 dgp Exp $
 */

#include "tclInt.h"

#define FALSE	0
#define TRUE	1

................................................................................
	}
	if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    if (strcmp(argv[1],"info") == 0) {
	char buf[400];
	sprintf(buf, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n",
		"total mallocs", total_mallocs, "total frees", total_frees,
		"current packets allocated", current_malloc_packets,
		"current bytes allocated", current_bytes_malloced,
		"maximum packets allocated", maximum_malloc_packets,
		"maximum bytes allocated", maximum_bytes_malloced);
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
	return TCL_OK;
    }
    if (strcmp(argv[1],"init") == 0) {
	if (argc != 3) {
	    goto bad_suboption;
	}
	init_malloced_bodies = (strcmp(argv[2],"on") == 0);

 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * This code contributed by Karl Lehenbauer and Mark Diekhans
 *
 * RCS: @(#) $Id: tclCkalloc.c,v 1.22.2.2 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"

#define FALSE	0
#define TRUE	1

................................................................................
	}
	if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    if (strcmp(argv[1],"info") == 0) {
	Tcl_Obj *objPtr = Tcl_NewObj();
	TclObjPrintf(NULL, objPtr, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n",
		"total mallocs", total_mallocs, "total frees", total_frees,
		"current packets allocated", current_malloc_packets,
		"current bytes allocated", current_bytes_malloced,
		"maximum packets allocated", maximum_malloc_packets,
		"maximum bytes allocated", maximum_bytes_malloced);
	Tcl_SetObjResult(interp, objPtr);
	return TCL_OK;
    }
    if (strcmp(argv[1],"init") == 0) {
	if (argc != 3) {
	    goto bad_suboption;
	}
	init_malloced_bodies = (strcmp(argv[2],"on") == 0);

 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdAH.c,v 1.57.2.9 2005/09/12 19:12:27 dgp Exp $
 */

#include "tclInt.h"
#include <locale.h>

#define NEW_FORMAT 1

................................................................................
    }

  match:
    if (body != -1) {
	armPtr = caseObjv[body - 1];
	result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
	if (result == TCL_ERROR) {
	    char msg[100 + TCL_INTEGER_SPACE];

	    arg = TclGetString(armPtr);
	    sprintf(msg, "\n    (\"%.50s\" arm line %d)", arg,
		    interp->errorLine);
	    Tcl_AddObjErrorInfo(interp, msg, -1);
	}
	return result;
    }

    /*
     * Nothing matched: return nothing.
     */
................................................................................
    result = Tcl_EvalObjEx(interp, objv[1], 0);

    /*
     * We disable catch in interpreters where the limit has been exceeded.
     */

    if (Tcl_LimitExceeded(interp)) {
	char msg[32 + TCL_INTEGER_SPACE];

	sprintf(msg, "\n    (\"catch\" body line %d)", interp->errorLine);
	Tcl_AddErrorInfo(interp, msg);

	return TCL_ERROR;
    }

    if (objc >= 3) {
	if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL,
		Tcl_GetObjResult(interp), 0)) {
	    Tcl_ResetResult(interp);
................................................................................
	 * object when it decrements its refcount after eval'ing it.
	 */

	objPtr = Tcl_ConcatObj(objc-1, objv+1);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }
    if (result == TCL_ERROR) {
	char msg[32 + TCL_INTEGER_SPACE];

	sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
	Tcl_AddObjErrorInfo(interp, msg, -1);

    }
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
	}
	if (!value) {
	    break;
	}
	result = Tcl_EvalObjEx(interp, objv[4], 0);
	if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
	    if (result == TCL_ERROR) {
		char msg[32 + TCL_INTEGER_SPACE];

		sprintf(msg, "\n    (\"for\" body line %d)",interp->errorLine);
		Tcl_AddErrorInfo(interp, msg);

	    }
	    break;
	}
	result = Tcl_EvalObjEx(interp, objv[3], 0);
	if (result == TCL_BREAK) {
	    break;
	} else if (result != TCL_OK) {
................................................................................
	if (result != TCL_OK) {
	    if (result == TCL_CONTINUE) {
		result = TCL_OK;
	    } else if (result == TCL_BREAK) {
		result = TCL_OK;
		break;
	    } else if (result == TCL_ERROR) {
		char msg[32 + TCL_INTEGER_SPACE];

		sprintf(msg, "\n    (\"foreach\" body line %d)",
			interp->errorLine);
		Tcl_AddObjErrorInfo(interp, msg, -1);
		break;
	    } else {
		break;
	    }
	}
    }
    if (result == TCL_OK) {

 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdAH.c,v 1.57.2.10 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include <locale.h>

#define NEW_FORMAT 1

................................................................................
    }

  match:
    if (body != -1) {
	armPtr = caseObjv[body - 1];
	result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
	if (result == TCL_ERROR) {



	    TclFormatToErrorInfo(interp, "\n    (\"%.50s\" arm line %d)",
		    TclGetString(armPtr), interp->errorLine);

	}
	return result;
    }

    /*
     * Nothing matched: return nothing.
     */
................................................................................
    result = Tcl_EvalObjEx(interp, objv[1], 0);

    /*
     * We disable catch in interpreters where the limit has been exceeded.
     */

    if (Tcl_LimitExceeded(interp)) {


	TclFormatToErrorInfo(interp, "\n    (\"catch\" body line %d)",

		interp->errorLine);
	return TCL_ERROR;
    }

    if (objc >= 3) {
	if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL,
		Tcl_GetObjResult(interp), 0)) {
	    Tcl_ResetResult(interp);
................................................................................
	 * object when it decrements its refcount after eval'ing it.
	 */

	objPtr = Tcl_ConcatObj(objc-1, objv+1);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }
    if (result == TCL_ERROR) {


	TclFormatToErrorInfo(interp,"\n    (\"eval\" body line %d)",

		interp->errorLine);
    }
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
	}
	if (!value) {
	    break;
	}
	result = Tcl_EvalObjEx(interp, objv[4], 0);
	if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
	    if (result == TCL_ERROR) {


		TclFormatToErrorInfo(interp, "\n    (\"for\" body line %d)",

			interp->errorLine);
	    }
	    break;
	}
	result = Tcl_EvalObjEx(interp, objv[3], 0);
	if (result == TCL_BREAK) {
	    break;
	} else if (result != TCL_OK) {
................................................................................
	if (result != TCL_OK) {
	    if (result == TCL_CONTINUE) {
		result = TCL_OK;
	    } else if (result == TCL_BREAK) {
		result = TCL_OK;
		break;
	    } else if (result == TCL_ERROR) {
		TclFormatToErrorInfo(interp,

			"\n    (\"foreach\" body line %d)", interp->errorLine);


		break;
	    } else {
		break;
	    }
	}
    }
    if (result == TCL_OK) {

 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2005 Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdIL.c,v 1.70.2.8 2005/08/29 18:38:45 dgp Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"

/*
 * During execution of the "lsort" command, structures of the following type
................................................................................
	     * their scale is sensible yet, but we at least perform the
	     * syntactic check here.
	     */

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
			&sortInfo.indexv[j]) != TCL_OK) {
		    char buffer[TCL_INTEGER_SPACE];

		    if (sortInfo.indexc > 1) {
			ckfree((char *) sortInfo.indexv);
		    }
		    sprintf(buffer, "%d", j);
		    Tcl_AddErrorInfo(interp,
			    "\n    (-index option item number ");
		    Tcl_AddErrorInfo(interp, buffer);
		    Tcl_AddErrorInfo(interp, ")");
		    return TCL_ERROR;
		}
	    }
	    break;
	}
	}
    }
................................................................................
	     * their scale is sensible yet, but we at least perform the
	     * syntactic check here.
	     */

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
			&sortInfo.indexv[j]) != TCL_OK) {
		    char buffer[TCL_INTEGER_SPACE];

		    if (sortInfo.indexc > 1) {
			ckfree((char *) sortInfo.indexv);
		    }
		    sprintf(buffer, "%d", j);
		    Tcl_AddErrorInfo(interp,
			    "\n    (-index option item number ");
		    Tcl_AddErrorInfo(interp, buffer);
		    Tcl_AddErrorInfo(interp, ")");
		    return TCL_ERROR;
		}
	    }
	    i++;
	    break;
	}
	case LSORT_INTEGER:

 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2005 Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdIL.c,v 1.70.2.9 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"

/*
 * During execution of the "lsort" command, structures of the following type
................................................................................
	     * their scale is sensible yet, but we at least perform the
	     * syntactic check here.
	     */

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
			&sortInfo.indexv[j]) != TCL_OK) {


		    if (sortInfo.indexc > 1) {
			ckfree((char *) sortInfo.indexv);
		    }

		    TclFormatToErrorInfo(interp,
			    "\n    (-index option item number %d)", j);


		    return TCL_ERROR;
		}
	    }
	    break;
	}
	}
    }
................................................................................
	     * their scale is sensible yet, but we at least perform the
	     * syntactic check here.
	     */

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
			&sortInfo.indexv[j]) != TCL_OK) {


		    if (sortInfo.indexc > 1) {
			ckfree((char *) sortInfo.indexv);
		    }

		    TclFormatToErrorInfo(interp,
			    "\n    (-index option item number %d)", j);


		    return TCL_ERROR;
		}
	    }
	    i++;
	    break;
	}
	case LSORT_INTEGER:

 * Copyright (c) 1998-2000 Scriptics Corporation.
 * Copyright (c) 2002 ActiveState Corporation.
 * Copyright (c) 2003 Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdMZ.c,v 1.115.2.12 2005/08/29 18:38:45 dgp Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"
 
/*
 *----------------------------------------------------------------------
................................................................................
		 * with back-division. [Bug #714106]
		 */

		Tcl_Obj *resultPtr;

		length2 = length1 * count;
		if ((length2 / count) != length1) {
		    char buf[TCL_INTEGER_SPACE+1];

		    sprintf(buf, "%d", INT_MAX);
		    Tcl_AppendResult(interp,
			    "string size overflow, must be less than ",
			    buf, (char *) NULL);
		    return TCL_ERROR;
		}

		/*
		 * Include space for the NULL.
		 */

................................................................................
Tcl_SwitchObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved, noCase;

    char *pattern;
    Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
    Tcl_Obj *CONST *savedObjv = objv;
    Tcl_RegExp regExpr = NULL;

    /*
     * If you add options that make -e and -g not unique prefixes of -exact or
................................................................................
    }

    for (i = 0; i < objc; i += 2) {
	/*
	 * See if the pattern matches the string.
	 */

	pattern = TclGetString(objv[i]);

	if ((i == objc - 2) && (*pattern == 'd')
		&& (strcmp(pattern, "default") == 0)) {
	    Tcl_Obj *emptyObj = NULL;

	    /*
	     * If either indexVarObj or matchVarObj are non-NULL, we're in
................................................................................
    result = Tcl_EvalObjEx(interp, objv[j], 0);

    /*
     * Generate an error message if necessary.
     */

    if (result == TCL_ERROR) {
	Tcl_Obj *msg = Tcl_NewStringObj("\n    (\"", -1);
	Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);

	Tcl_IncrRefCount(msg);
	Tcl_IncrRefCount(errorLine);
	TclAppendLimitedToObj(msg, pattern, -1, 50, "");
	Tcl_AppendToObj(msg,"\" arm line ", -1);
	Tcl_AppendObjToObj(msg, errorLine);
	Tcl_DecrRefCount(errorLine);
	Tcl_AppendToObj(msg,")", -1);
	TclAppendObjToErrorInfo(interp, msg);
	Tcl_DecrRefCount(msg);


    }
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
	}
	if (!value) {
	    break;
	}
	result = Tcl_EvalObjEx(interp, objv[2], 0);
	if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
	    if (result == TCL_ERROR) {
		char msg[32 + TCL_INTEGER_SPACE];

		sprintf(msg, "\n    (\"while\" body line %d)",
			interp->errorLine);
		Tcl_AddErrorInfo(interp, msg);
	    }
	    break;
	}
    }
    if (result == TCL_BREAK) {
	result = TCL_OK;
    }

 * Copyright (c) 1998-2000 Scriptics Corporation.
 * Copyright (c) 2002 ActiveState Corporation.
 * Copyright (c) 2003 Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdMZ.c,v 1.115.2.13 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"
 
/*
 *----------------------------------------------------------------------
................................................................................
		 * with back-division. [Bug #714106]
		 */

		Tcl_Obj *resultPtr;

		length2 = length1 * count;
		if ((length2 / count) != length1) {
		    resultPtr = Tcl_NewObj();
		    TclObjPrintf(NULL, resultPtr,
			    "string size overflow, must be less than %d",
			    INT_MAX);
		    Tcl_SetObjResult(interp, resultPtr);

		    return TCL_ERROR;
		}

		/*
		 * Include space for the NULL.
		 */

................................................................................
Tcl_SwitchObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved, noCase;
    int patternLength;
    char *pattern;
    Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
    Tcl_Obj *CONST *savedObjv = objv;
    Tcl_RegExp regExpr = NULL;

    /*
     * If you add options that make -e and -g not unique prefixes of -exact or
................................................................................
    }

    for (i = 0; i < objc; i += 2) {
	/*
	 * See if the pattern matches the string.
	 */

	pattern = Tcl_GetStringFromObj(objv[i], &patternLength);

	if ((i == objc - 2) && (*pattern == 'd')
		&& (strcmp(pattern, "default") == 0)) {
	    Tcl_Obj *emptyObj = NULL;

	    /*
	     * If either indexVarObj or matchVarObj are non-NULL, we're in
................................................................................
    result = Tcl_EvalObjEx(interp, objv[j], 0);

    /*
     * Generate an error message if necessary.
     */

    if (result == TCL_ERROR) {
	int limit = 50;
	int overflow = (patternLength > limit);








	TclFormatToErrorInfo(interp, "\n    (\"%.*s%s\" arm line %d)",

		(overflow ? limit : patternLength), pattern,
		(overflow ? "..." : ""), interp->errorLine);
    }
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
	}
	if (!value) {
	    break;
	}
	result = Tcl_EvalObjEx(interp, objv[2], 0);
	if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
	    if (result == TCL_ERROR) {


		TclFormatToErrorInfo(interp, "\n    (\"while\" body line %d)",
			interp->errorLine);

	    }
	    break;
	}
    }
    if (result == TCL_BREAK) {
	result = TCL_OK;
    }

 *	Declarations of functions in the platform independent public Tcl API.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDecls.h,v 1.107.2.7 2005/08/25 15:46:30 dgp Exp $
 */

#ifndef _TCLDECLS
#define _TCLDECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
................................................................................
				Tcl_Interp * interp, CONST char * name, 
				CONST char * version, int exact, 
				ClientData * clientDataPtr));
#endif
#ifndef Tcl_Panic_TCL_DECLARED
#define Tcl_Panic_TCL_DECLARED
/* 2 */
EXTERN void		Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(CONST char *,format));
#endif
#ifndef Tcl_Alloc_TCL_DECLARED
#define Tcl_Alloc_TCL_DECLARED
/* 3 */
EXTERN char *		Tcl_Alloc _ANSI_ARGS_((unsigned int size));
#endif
#ifndef Tcl_Free_TCL_DECLARED
................................................................................
/* 14 */
EXTERN int		Tcl_AppendAllObjTypes _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr));
#endif
#ifndef Tcl_AppendStringsToObj_TCL_DECLARED
#define Tcl_AppendStringsToObj_TCL_DECLARED
/* 15 */
EXTERN void		Tcl_AppendStringsToObj _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr));
#endif
#ifndef Tcl_AppendToObj_TCL_DECLARED
#define Tcl_AppendToObj_TCL_DECLARED
/* 16 */
EXTERN void		Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj* objPtr, 
				CONST char* bytes, int length));
#endif
................................................................................
/* 69 */
EXTERN void		Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * element));
#endif
#ifndef Tcl_AppendResult_TCL_DECLARED
#define Tcl_AppendResult_TCL_DECLARED
/* 70 */
EXTERN void		Tcl_AppendResult _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
#endif
#ifndef Tcl_AsyncCreate_TCL_DECLARED
#define Tcl_AsyncCreate_TCL_DECLARED
/* 71 */
EXTERN Tcl_AsyncHandler	 Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc * proc, 
				ClientData clientData));
#endif
................................................................................
#define Tcl_SetErrno_TCL_DECLARED
/* 227 */
EXTERN void		Tcl_SetErrno _ANSI_ARGS_((int err));
#endif
#ifndef Tcl_SetErrorCode_TCL_DECLARED
#define Tcl_SetErrorCode_TCL_DECLARED
/* 228 */
EXTERN void		Tcl_SetErrorCode _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
#endif
#ifndef Tcl_SetMaxBlockTime_TCL_DECLARED
#define Tcl_SetMaxBlockTime_TCL_DECLARED
/* 229 */
EXTERN void		Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time * timePtr));
#endif
#ifndef Tcl_SetPanicProc_TCL_DECLARED
................................................................................
				CONST char * frameName, CONST char * part1, 
				CONST char * part2, CONST char * localName, 
				int flags));
#endif
#ifndef Tcl_VarEval_TCL_DECLARED
#define Tcl_VarEval_TCL_DECLARED
/* 260 */
EXTERN int		Tcl_VarEval _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
#endif
#ifndef Tcl_VarTraceInfo_TCL_DECLARED
#define Tcl_VarTraceInfo_TCL_DECLARED
/* 261 */
EXTERN ClientData	Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName, int flags, 
				Tcl_VarTraceProc * procPtr, 
................................................................................

typedef struct TclStubs {
    int magic;
    struct TclStubHooks *hooks;

    int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 0 */
    CONST84_RETURN char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 1 */
    void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); /* 2 */
    char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */
    void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */
    char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */
    char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 6 */
    int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, CONST char * file, int line)); /* 7 */
    char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 8 */
#if !defined(__WIN32__) /* UNIX */
................................................................................
#ifdef __WIN32__
    void *reserved10;
#endif /* __WIN32__ */
    void (*tcl_SetTimer) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 11 */
    void (*tcl_Sleep) _ANSI_ARGS_((int ms)); /* 12 */
    int (*tcl_WaitForEvent) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 13 */
    int (*tcl_AppendAllObjTypes) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 14 */
    void (*tcl_AppendStringsToObj) _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr)); /* 15 */
    void (*tcl_AppendToObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 16 */
    Tcl_Obj * (*tcl_ConcatObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 17 */
    int (*tcl_ConvertToType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_ObjType * typePtr)); /* 18 */
    void (*tcl_DbDecrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 19 */
    void (*tcl_DbIncrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 20 */
    int (*tcl_DbIsShared) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 21 */
    Tcl_Obj * (*tcl_DbNewBooleanObj) _ANSI_ARGS_((int boolValue, CONST char * file, int line)); /* 22 */
................................................................................
    void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj * objPtr, long longValue)); /* 63 */
    void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */
    void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 65 */
    void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */
    void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */
    void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */
    void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * element)); /* 69 */
    void (*tcl_AppendResult) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 70 */
    Tcl_AsyncHandler (*tcl_AsyncCreate) _ANSI_ARGS_((Tcl_AsyncProc * proc, ClientData clientData)); /* 71 */
    void (*tcl_AsyncDelete) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 72 */
    int (*tcl_AsyncInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int code)); /* 73 */
    void (*tcl_AsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 74 */
    int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */
    void (*tcl_BackgroundError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 76 */
    char (*tcl_Backslash) _ANSI_ARGS_((CONST char * src, int * readPtr)); /* 77 */
................................................................................
    int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */
    int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */
    void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */
    void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */
    int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, CONST char * newValue)); /* 225 */
    int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST Tcl_CmdInfo * infoPtr)); /* 226 */
    void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */
    void (*tcl_SetErrorCode) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 228 */
    void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */
    void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */
    int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */
    void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * result, Tcl_FreeProc * freeProc)); /* 232 */
    int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */
    void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */
    void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */
................................................................................
    int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 253 */
    int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 254 */
    void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */
    void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */
    void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 257 */
    int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * varName, CONST char * localName, int flags)); /* 258 */
    int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); /* 259 */
    int (*tcl_VarEval) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 260 */
    ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */
    ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */
    int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, CONST char * s, int slen)); /* 263 */
    void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], CONST char * message)); /* 264 */
    int (*tcl_DumpActiveMemory) _ANSI_ARGS_((CONST char * fileName)); /* 265 */
    void (*tcl_ValidateAllMemory) _ANSI_ARGS_((CONST char * file, int line)); /* 266 */
    void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */

 *	Declarations of functions in the platform independent public Tcl API.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDecls.h,v 1.107.2.8 2005/09/15 20:58:39 dgp Exp $
 */

#ifndef _TCLDECLS
#define _TCLDECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
................................................................................
				Tcl_Interp * interp, CONST char * name, 
				CONST char * version, int exact, 
				ClientData * clientDataPtr));
#endif
#ifndef Tcl_Panic_TCL_DECLARED
#define Tcl_Panic_TCL_DECLARED
/* 2 */
EXTERN void		Tcl_Panic _ANSI_ARGS_((CONST char *format, ...));
#endif
#ifndef Tcl_Alloc_TCL_DECLARED
#define Tcl_Alloc_TCL_DECLARED
/* 3 */
EXTERN char *		Tcl_Alloc _ANSI_ARGS_((unsigned int size));
#endif
#ifndef Tcl_Free_TCL_DECLARED
................................................................................
/* 14 */
EXTERN int		Tcl_AppendAllObjTypes _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr));
#endif
#ifndef Tcl_AppendStringsToObj_TCL_DECLARED
#define Tcl_AppendStringsToObj_TCL_DECLARED
/* 15 */
EXTERN void		Tcl_AppendStringsToObj _ANSI_ARGS_((Tcl_Obj *objPtr, ...));
#endif
#ifndef Tcl_AppendToObj_TCL_DECLARED
#define Tcl_AppendToObj_TCL_DECLARED
/* 16 */
EXTERN void		Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj* objPtr, 
				CONST char* bytes, int length));
#endif
................................................................................
/* 69 */
EXTERN void		Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * element));
#endif
#ifndef Tcl_AppendResult_TCL_DECLARED
#define Tcl_AppendResult_TCL_DECLARED
/* 70 */
EXTERN void		Tcl_AppendResult _ANSI_ARGS_((Tcl_Interp *interp, ...));
#endif
#ifndef Tcl_AsyncCreate_TCL_DECLARED
#define Tcl_AsyncCreate_TCL_DECLARED
/* 71 */
EXTERN Tcl_AsyncHandler	 Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc * proc, 
				ClientData clientData));
#endif
................................................................................
#define Tcl_SetErrno_TCL_DECLARED
/* 227 */
EXTERN void		Tcl_SetErrno _ANSI_ARGS_((int err));
#endif
#ifndef Tcl_SetErrorCode_TCL_DECLARED
#define Tcl_SetErrorCode_TCL_DECLARED
/* 228 */
EXTERN void		Tcl_SetErrorCode _ANSI_ARGS_((Tcl_Interp *interp, ...));
#endif
#ifndef Tcl_SetMaxBlockTime_TCL_DECLARED
#define Tcl_SetMaxBlockTime_TCL_DECLARED
/* 229 */
EXTERN void		Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time * timePtr));
#endif
#ifndef Tcl_SetPanicProc_TCL_DECLARED
................................................................................
				CONST char * frameName, CONST char * part1, 
				CONST char * part2, CONST char * localName, 
				int flags));
#endif
#ifndef Tcl_VarEval_TCL_DECLARED
#define Tcl_VarEval_TCL_DECLARED
/* 260 */
EXTERN int		Tcl_VarEval _ANSI_ARGS_((Tcl_Interp *interp, ...));
#endif
#ifndef Tcl_VarTraceInfo_TCL_DECLARED
#define Tcl_VarTraceInfo_TCL_DECLARED
/* 261 */
EXTERN ClientData	Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName, int flags, 
				Tcl_VarTraceProc * procPtr, 
................................................................................

typedef struct TclStubs {
    int magic;
    struct TclStubHooks *hooks;

    int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 0 */
    CONST84_RETURN char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 1 */
    void (*tcl_Panic) _ANSI_ARGS_((CONST char *format, ...)); /* 2 */
    char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */
    void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */
    char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */
    char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 6 */
    int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, CONST char * file, int line)); /* 7 */
    char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 8 */
#if !defined(__WIN32__) /* UNIX */
................................................................................
#ifdef __WIN32__
    void *reserved10;
#endif /* __WIN32__ */
    void (*tcl_SetTimer) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 11 */
    void (*tcl_Sleep) _ANSI_ARGS_((int ms)); /* 12 */
    int (*tcl_WaitForEvent) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 13 */
    int (*tcl_AppendAllObjTypes) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 14 */
    void (*tcl_AppendStringsToObj) _ANSI_ARGS_((Tcl_Obj *objPtr, ...)); /* 15 */
    void (*tcl_AppendToObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 16 */
    Tcl_Obj * (*tcl_ConcatObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 17 */
    int (*tcl_ConvertToType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_ObjType * typePtr)); /* 18 */
    void (*tcl_DbDecrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 19 */
    void (*tcl_DbIncrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 20 */
    int (*tcl_DbIsShared) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 21 */
    Tcl_Obj * (*tcl_DbNewBooleanObj) _ANSI_ARGS_((int boolValue, CONST char * file, int line)); /* 22 */
................................................................................
    void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj * objPtr, long longValue)); /* 63 */
    void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */
    void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 65 */
    void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */
    void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */
    void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */
    void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * element)); /* 69 */
    void (*tcl_AppendResult) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 70 */
    Tcl_AsyncHandler (*tcl_AsyncCreate) _ANSI_ARGS_((Tcl_AsyncProc * proc, ClientData clientData)); /* 71 */
    void (*tcl_AsyncDelete) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 72 */
    int (*tcl_AsyncInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int code)); /* 73 */
    void (*tcl_AsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 74 */
    int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */
    void (*tcl_BackgroundError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 76 */
    char (*tcl_Backslash) _ANSI_ARGS_((CONST char * src, int * readPtr)); /* 77 */
................................................................................
    int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */
    int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */
    void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */
    void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */
    int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, CONST char * newValue)); /* 225 */
    int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST Tcl_CmdInfo * infoPtr)); /* 226 */
    void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */
    void (*tcl_SetErrorCode) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 228 */
    void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */
    void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */
    int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */
    void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * result, Tcl_FreeProc * freeProc)); /* 232 */
    int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */
    void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */
    void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */
................................................................................
    int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 253 */
    int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 254 */
    void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */
    void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */
    void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 257 */
    int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * varName, CONST char * localName, int flags)); /* 258 */
    int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); /* 259 */
    int (*tcl_VarEval) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 260 */
    ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */
    ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */
    int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, CONST char * s, int slen)); /* 263 */
    void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], CONST char * message)); /* 264 */
    int (*tcl_DumpActiveMemory) _ANSI_ARGS_((CONST char * fileName)); /* 265 */
    void (*tcl_ValidateAllMemory) _ANSI_ARGS_((CONST char * file, int line)); /* 266 */
    void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */

 *	type and its accessor command.
 *
 * Copyright (c) 2002 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDictObj.c,v 1.27.2.4 2005/08/18 18:18:45 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"

/*
 * Forward declaration.
................................................................................
	result = Tcl_EvalObjEx(interp, scriptObj, 0);
	if (result == TCL_CONTINUE) {
	    result = TCL_OK;
	} else if (result != TCL_OK) {
	    if (result == TCL_BREAK) {
		result = TCL_OK;
	    } else if (result == TCL_ERROR) {
		char msg[32 + TCL_INTEGER_SPACE];

		sprintf(msg, "\n    (\"dict for\" body line %d)",
			interp->errorLine);
		Tcl_AddObjErrorInfo(interp, msg, -1);
	    }
	    break;
	}

	Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
    }

................................................................................
	FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES
    };
    Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
    Tcl_Obj **varv, *keyObj, *valueObj, *resultObj, *boolObj;
    Tcl_DictSearch search;
    int index, varc, done, result, satisfied;
    char *pattern;
    char msg[32 + TCL_INTEGER_SPACE];

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 2, objv, "dictionary filterType ...");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[3], filters, "filterType",
	     0, &index) != TCL_OK) {
................................................................................
		 */
		Tcl_ResetResult(interp);
		Tcl_DictObjDone(&search);
	    case TCL_CONTINUE:
		result = TCL_OK;
		break;
	    case TCL_ERROR:

		sprintf(msg, "\n    (\"dict filter\" script line %d)",
			interp->errorLine);
		Tcl_AddObjErrorInfo(interp, msg, -1);
	    default:
		goto abnormalResult;
	    }

	    TclDecrRefCount(keyObj);
	    TclDecrRefCount(valueObj);

 *	type and its accessor command.
 *
 * Copyright (c) 2002 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDictObj.c,v 1.27.2.5 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"

/*
 * Forward declaration.
................................................................................
	result = Tcl_EvalObjEx(interp, scriptObj, 0);
	if (result == TCL_CONTINUE) {
	    result = TCL_OK;
	} else if (result != TCL_OK) {
	    if (result == TCL_BREAK) {
		result = TCL_OK;
	    } else if (result == TCL_ERROR) {
		TclFormatToErrorInfo(interp,

			"\n    (\"dict for\" body line %d)", interp->errorLine);


	    }
	    break;
	}

	Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
    }

................................................................................
	FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES
    };
    Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
    Tcl_Obj **varv, *keyObj, *valueObj, *resultObj, *boolObj;
    Tcl_DictSearch search;
    int index, varc, done, result, satisfied;
    char *pattern;


    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 2, objv, "dictionary filterType ...");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[3], filters, "filterType",
	     0, &index) != TCL_OK) {
................................................................................
		 */
		Tcl_ResetResult(interp);
		Tcl_DictObjDone(&search);
	    case TCL_CONTINUE:
		result = TCL_OK;
		break;
	    case TCL_ERROR:
		TclFormatToErrorInfo(interp,
			"\n    (\"dict filter\" script line %d)",
			interp->errorLine);

	    default:
		goto abnormalResult;
	    }

	    TclDecrRefCount(keyObj);
	    TclDecrRefCount(valueObj);

 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002-2005 by Miguel Sofer.
 * Copyright (c) 2005 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclExecute.c,v 1.167.2.38 2005/08/25 21:21:33 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include "tommath.h"

#include <math.h>
................................................................................
	    Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
	} else {
	    s = "floating-point value too large to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
	}
    } else {
	char msg[64 + TCL_INTEGER_SPACE];

	sprintf(msg, "unknown floating-point error, errno = %d", errno);
	Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
	Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL);

    }
}
 
#ifdef TCL_COMPILE_STATS
/*
 *----------------------------------------------------------------------
 *

 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002-2005 by Miguel Sofer.
 * Copyright (c) 2005 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclExecute.c,v 1.167.2.39 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include "tommath.h"

#include <math.h>
................................................................................
	    Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
	} else {
	    s = "floating-point value too large to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
	}
    } else {
	Tcl_Obj *objPtr = Tcl_NewObj();
	TclObjPrintf(NULL, objPtr,
		"unknown floating-point error, errno = %d", errno);
	Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", 
		Tcl_GetString(objPtr), (char *) NULL);
	Tcl_SetObjResult(interp, objPtr);
    }
}
 
#ifdef TCL_COMPILE_STATS
/*
 *----------------------------------------------------------------------
 *

 *      See TIP #219 for the specification of this functionality.
 *
 * Copyright (c) 2004-2005 ActiveState, a divison of Sophos
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIORChan.c,v 1.1.2.4 2005/09/12 14:47:16 dgp Exp $
 */

#include <tclInt.h>
#include <tclIO.h>
#include <assert.h>

#ifndef EINVAL
................................................................................
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	return res;
    }

    if ((listc % 2) == 1) {
        /* Odd number of elements is wrong.
	 */

        char buf [20];

	sprintf (buf, "%d", listc);
	Tcl_ResetResult  (interp);
	Tcl_AppendResult (interp,
			  "Expected list with even number of elements, got ",
			  buf, (listc == 1 ? " element" : " elements"),
			  " instead", (char*) NULL);

	Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	return TCL_ERROR;
    }


    {
        int len;
................................................................................
     */

#ifdef TCL_THREADS
    TCL_DECLARE_MUTEX (rcCounterMutex)
#endif
    static unsigned long rcCounter = 0;

    char     channelName [50];
    Tcl_Obj* res = Tcl_NewStringObj ("rc", -1);

#ifdef TCL_THREADS
    Tcl_MutexLock (&rcCounterMutex);
#endif

    sprintf (channelName, "%lu", (unsigned long) rcCounter);
    rcCounter ++;

#ifdef TCL_THREADS
    Tcl_MutexUnlock (&rcCounterMutex);
#endif

    Tcl_AppendStringsToObj (res, channelName, (char*) NULL);
    return res;
}
 

static void
RcFree (rcPtr)
     ReflectingChannel* rcPtr;

 *      See TIP #219 for the specification of this functionality.
 *
 * Copyright (c) 2004-2005 ActiveState, a divison of Sophos
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIORChan.c,v 1.1.2.5 2005/09/15 20:58:39 dgp Exp $
 */

#include <tclInt.h>
#include <tclIO.h>
#include <assert.h>

#ifndef EINVAL
................................................................................
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	return res;
    }

    if ((listc % 2) == 1) {
        /* Odd number of elements is wrong.
	 */
	Tcl_Obj *objPtr = Tcl_NewObj();
	Tcl_ResetResult(interp);
	TclObjPrintf(NULL, objPtr, "Expected list with even number of "
		"elements, got %d element%s instead", listc, 
		(listc == 1 ? "" : "s"));
	Tcl_SetObjResult(interp, objPtr);




	Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	return TCL_ERROR;
    }


    {
        int len;
................................................................................
     */

#ifdef TCL_THREADS
    TCL_DECLARE_MUTEX (rcCounterMutex)
#endif
    static unsigned long rcCounter = 0;


    Tcl_Obj* res = Tcl_NewObj ();

#ifdef TCL_THREADS
    Tcl_MutexLock (&rcCounterMutex);
#endif

    TclObjPrintf(NULL, res, "rc%lu", rcCounter);
    rcCounter ++;

#ifdef TCL_THREADS
    Tcl_MutexUnlock (&rcCounterMutex);
#endif


    return res;
}
 

static void
RcFree (rcPtr)
     ReflectingChannel* rcPtr;

 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2001-2004 Vincent Darley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOUtil.c,v 1.113.2.6 2005/09/09 18:48:40 dgp Exp $
 */

#include "tclInt.h"
#ifdef __WIN32__
#   include "tclWinInt.h"
#endif
#include "tclFileSystem.h"
................................................................................

    if (result == TCL_RETURN) {
	result = TclUpdateReturnInfo(iPtr);
    } else if (result == TCL_ERROR) {
	/*
	 * Record information telling where the error occurred.
	 */

	Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
	Tcl_Obj *msg = Tcl_NewStringObj("\n    (file \"", -1);
	CONST char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
	Tcl_IncrRefCount(msg);
	Tcl_IncrRefCount(errorLine);
	TclAppendLimitedToObj(msg, pathString, length, 150, "");
	Tcl_AppendToObj(msg, "\" line ", -1);
	Tcl_AppendObjToObj(msg, errorLine);
	Tcl_DecrRefCount(errorLine);
	Tcl_AppendToObj(msg, ")", -1);
	TclAppendObjToErrorInfo(interp, msg);
	Tcl_DecrRefCount(msg);
    }

  end:
    Tcl_DecrRefCount(objPtr);
    return result;
}
 

 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2001-2004 Vincent Darley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOUtil.c,v 1.113.2.7 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#ifdef __WIN32__
#   include "tclWinInt.h"
#endif
#include "tclFileSystem.h"
................................................................................

    if (result == TCL_RETURN) {
	result = TclUpdateReturnInfo(iPtr);
    } else if (result == TCL_ERROR) {
	/*
	 * Record information telling where the error occurred.
	 */
	CONST char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
	int limit = 150;
	int overflow = (length > limit);

	TclFormatToErrorInfo(interp, "\n    (file \"%.*s%s\" line %d)",
		(overflow ? limit : length), pathString,
		(overflow ? "..." : ""), interp->errorLine);






    }

  end:
    Tcl_DecrRefCount(objPtr);
    return result;
}
 

 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-19/99 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.202.2.38 2005/09/09 18:48:40 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options
................................................................................
MODULE_SCOPE void	TclFinalizeNotifier(void);
MODULE_SCOPE void	TclFinalizeObjects(void);
MODULE_SCOPE void	TclFinalizePreserve(void);
MODULE_SCOPE void	TclFinalizeSynchronization(void);
MODULE_SCOPE void	TclFinalizeThreadData(void);
MODULE_SCOPE double	TclFloor(mp_int* a);
MODULE_SCOPE void	TclFormatNaN(double value, char* buffer);
MODULE_SCOPE int	TclFormatObj TCL_VARARGS(Tcl_Interp *, arg1);



MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
			    CONST char *attributeName, int *indexPtr);
MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler(Tcl_Interp *interp);
MODULE_SCOPE int	TclGetEncodingFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE int	TclGetNamespaceFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
................................................................................
			    Tcl_Obj* valuePtr);
MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[], Tcl_Obj **optionsPtrPtr,
			    int *codePtr, int *levelPtr);
MODULE_SCOPE int	TclObjInvokeNamespace(Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[],
			    Tcl_Namespace *nsPtr, int flags);
MODULE_SCOPE int	TclObjPrintf TCL_VARARGS(Tcl_Interp *, arg1);

MODULE_SCOPE int	TclParseBackslash(CONST char *src,
			    int numBytes, int *readPtr, char *dst);
MODULE_SCOPE int	TclParseHex(CONST char *src, int numBytes,
			    Tcl_UniChar *resultPtr);
MODULE_SCOPE int	TclParseNumber(Tcl_Interp* interp, Tcl_Obj* objPtr,
			    CONST char* type, CONST char* string,
			    size_t length, CONST char** endPtrPtr, int flags);
................................................................................
MODULE_SCOPE ClientData	TclpGetNativeCwd(ClientData clientData);
MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
MODULE_SCOPE Tcl_Obj*	TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
			    int linkType);
MODULE_SCOPE int	TclpObjChdir(Tcl_Obj *pathPtr);
MODULE_SCOPE Tcl_Obj *	TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    Tcl_PathPart portion);
MODULE_SCOPE void	TclpPanic TCL_VARARGS(CONST char *, format);
MODULE_SCOPE char *	TclpReadlink(CONST char *fileName,
			    Tcl_DString *linkPtr);
MODULE_SCOPE void	TclpReleaseFile(TclFile file);
MODULE_SCOPE void	TclpSetInterfaces(void);
MODULE_SCOPE void	TclpSetVariables(Tcl_Interp *interp);
MODULE_SCOPE void	TclpUnloadFile(Tcl_LoadHandle loadHandle);
MODULE_SCOPE VOID *	TclpThreadDataKeyGet(Tcl_ThreadDataKey *keyPtr);

 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-19/99 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.202.2.39 2005/09/15 20:58:39 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options
................................................................................
MODULE_SCOPE void	TclFinalizeNotifier(void);
MODULE_SCOPE void	TclFinalizeObjects(void);
MODULE_SCOPE void	TclFinalizePreserve(void);
MODULE_SCOPE void	TclFinalizeSynchronization(void);
MODULE_SCOPE void	TclFinalizeThreadData(void);
MODULE_SCOPE double	TclFloor(mp_int* a);
MODULE_SCOPE void	TclFormatNaN(double value, char* buffer);
MODULE_SCOPE int	TclFormatObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    CONST char *format, ...);
MODULE_SCOPE int	TclFormatToErrorInfo(Tcl_Interp *interp,
			    CONST char *format, ...);
MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
			    CONST char *attributeName, int *indexPtr);
MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler(Tcl_Interp *interp);
MODULE_SCOPE int	TclGetEncodingFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE int	TclGetNamespaceFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
................................................................................
			    Tcl_Obj* valuePtr);
MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[], Tcl_Obj **optionsPtrPtr,
			    int *codePtr, int *levelPtr);
MODULE_SCOPE int	TclObjInvokeNamespace(Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[],
			    Tcl_Namespace *nsPtr, int flags);
MODULE_SCOPE int	TclObjPrintf(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    CONST char *format, ...);
MODULE_SCOPE int	TclParseBackslash(CONST char *src,
			    int numBytes, int *readPtr, char *dst);
MODULE_SCOPE int	TclParseHex(CONST char *src, int numBytes,
			    Tcl_UniChar *resultPtr);
MODULE_SCOPE int	TclParseNumber(Tcl_Interp* interp, Tcl_Obj* objPtr,
			    CONST char* type, CONST char* string,
			    size_t length, CONST char** endPtrPtr, int flags);
................................................................................
MODULE_SCOPE ClientData	TclpGetNativeCwd(ClientData clientData);
MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
MODULE_SCOPE Tcl_Obj*	TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
			    int linkType);
MODULE_SCOPE int	TclpObjChdir(Tcl_Obj *pathPtr);
MODULE_SCOPE Tcl_Obj *	TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    Tcl_PathPart portion);
MODULE_SCOPE void	TclpPanic(CONST char *format, ...);
MODULE_SCOPE char *	TclpReadlink(CONST char *fileName,
			    Tcl_DString *linkPtr);
MODULE_SCOPE void	TclpReleaseFile(TclFile file);
MODULE_SCOPE void	TclpSetInterfaces(void);
MODULE_SCOPE void	TclpSetVariables(Tcl_Interp *interp);
MODULE_SCOPE void	TclpUnloadFile(Tcl_LoadHandle loadHandle);
MODULE_SCOPE VOID *	TclpThreadDataKeyGet(Tcl_ThreadDataKey *keyPtr);

 * Copyright (c) 1988-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2000 Ajuba Solutions.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMain.c,v 1.30.2.1 2005/08/02 18:16:01 dgp Exp $
 */

#include "tclInt.h"

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT

................................................................................
    if (commandPtr != NULL) {
	Tcl_DecrRefCount(commandPtr);
    }

    /*
     * Rather than calling exit, invoke the "exit" command so that users can
     * replace "exit" with some other command to do additional cleanup on
     * exit. The Tcl_Eval call should never return.
     */

    if (!Tcl_InterpDeleted(interp)) {
	if (!Tcl_LimitExceeded(interp)) {
	    char buffer[TCL_INTEGER_SPACE + 5];

	    sprintf(buffer, "exit %d", exitCode);

	    Tcl_Eval(interp, buffer);

	}

	/*
	 * If Tcl_Eval returns, trying to eval [exit], something unusual is
	 * happening. Maybe interp has been deleted; maybe [exit] was
	 * redefined, maybe we've blown up because of an exceeded limit. We
	 * still want to cleanup and exit.
	 */

	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_DeleteInterp(interp);
	}

 * Copyright (c) 1988-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2000 Ajuba Solutions.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMain.c,v 1.30.2.2 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT

................................................................................
    if (commandPtr != NULL) {
	Tcl_DecrRefCount(commandPtr);
    }

    /*
     * Rather than calling exit, invoke the "exit" command so that users can
     * replace "exit" with some other command to do additional cleanup on
     * exit. The Tcl_EvalObjEx call should never return.
     */

    if (!Tcl_InterpDeleted(interp)) {
	if (!Tcl_LimitExceeded(interp)) {
	    Tcl_Obj *cmd = Tcl_NewObj();

	    TclObjPrintf(NULL, cmd, "exit %d", exitCode);
	    Tcl_IncrRefCount(cmd);
	    Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
	    Tcl_DecrRefCount(cmd);
	}

	/*
	 * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual
	 * is happening. Maybe interp has been deleted; maybe [exit] was
	 * redefined, maybe we've blown up because of an exceeded limit. We
	 * still want to cleanup and exit.
	 */

	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_DeleteInterp(interp);
	}

 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   [email protected]
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNamesp.c,v 1.66.2.9 2005/08/29 18:38:45 dgp Exp $
 */

#include "tclInt.h"

/*
 * Initial size of stack allocated space for tail list - used when resetting
 * shadowed command references in the functin: TclResetShadowedCmdRefs.
................................................................................
	 */

	objPtr = Tcl_ConcatObj(objc-3, objv+3);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }

    if (result == TCL_ERROR) {
	Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
	Tcl_Obj *msg = Tcl_NewStringObj("\n    (in namespace eval \"", -1);
	Tcl_IncrRefCount(errorLine);
	Tcl_IncrRefCount(msg);
	TclAppendLimitedToObj(msg, namespacePtr->fullName, -1, 200, "");
	Tcl_AppendToObj(msg, "\" script line ", -1);
	Tcl_AppendObjToObj(msg, errorLine);
	Tcl_DecrRefCount(errorLine);
	Tcl_AppendToObj(msg, ")", -1);
	TclAppendObjToErrorInfo(interp, msg);
	Tcl_DecrRefCount(msg);
    }

    /*
     * Restore the previous "current" namespace.
     */

    TclPopStackFrame(interp);
................................................................................
	concatObjv[1] = listPtr;
	cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
	result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT);
	Tcl_DecrRefCount(listPtr);    /* we're done with the list object */
    }

    if (result == TCL_ERROR) {
	Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
	Tcl_Obj *msg = Tcl_NewStringObj("\n    (in namespace inscope \"", -1);


	Tcl_IncrRefCount(errorLine);
	Tcl_IncrRefCount(msg);

	TclAppendLimitedToObj(msg, namespacePtr->fullName, -1, 200, "");
	Tcl_AppendToObj(msg, "\" script line ", -1);
	Tcl_AppendObjToObj(msg, errorLine);
	Tcl_DecrRefCount(errorLine);
	Tcl_AppendToObj(msg, ")", -1);
	TclAppendObjToErrorInfo(interp, msg);
	Tcl_DecrRefCount(msg);
    }

    /*
     * Restore the previous "current" namespace.
     */

    TclPopStackFrame(interp);

 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   [email protected]
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNamesp.c,v 1.66.2.10 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"

/*
 * Initial size of stack allocated space for tail list - used when resetting
 * shadowed command references in the functin: TclResetShadowedCmdRefs.
................................................................................
	 */

	objPtr = Tcl_ConcatObj(objc-3, objv+3);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }

    if (result == TCL_ERROR) {
	int length = strlen(namespacePtr->fullName);
	int limit = 200;
	int overflow = (length > limit);

	TclFormatToErrorInfo(interp,
		"\n    (in namespace eval \"%.*s%s\" script line %d)",
		(overflow ? limit : length), namespacePtr->fullName,
		(overflow ? "..." : ""), interp->errorLine);



    }

    /*
     * Restore the previous "current" namespace.
     */

    TclPopStackFrame(interp);
................................................................................
	concatObjv[1] = listPtr;
	cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
	result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT);
	Tcl_DecrRefCount(listPtr);    /* we're done with the list object */
    }

    if (result == TCL_ERROR) {
	int length = strlen(namespacePtr->fullName);
	int limit = 200;
	int overflow = (length > limit);


	TclFormatToErrorInfo(interp,
		"\n    (in namespace inscope \"%.*s%s\" script line %d)",
		(overflow ? limit : length), namespacePtr->fullName,

		(overflow ? "..." : ""), interp->errorLine);




    }

    /*
     * Restore the previous "current" namespace.
     */

    TclPopStackFrame(interp);

 * Copyright (c) 1988-1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPanic.c,v 1.5.2.1 2005/08/02 18:16:04 dgp Exp $
 */

#include "tclInt.h"

/*
 * The panicProc variable contains a pointer to an application specific panic
 * procedure.
................................................................................
 *
 * Side effects:
 *	The process dies, entering the debugger if possible.
 *
 *----------------------------------------------------------------------
 */

	/* VARARGS ARGSUSED */
void
Tcl_Panic TCL_VARARGS_DEF(CONST char *,arg1)
{
    va_list argList;
    CONST char *format;

    format = TCL_VARARGS_START(CONST char *,arg1,argList);

    Tcl_PanicVA(format, argList);
    va_end (argList);
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

 * Copyright (c) 1988-1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPanic.c,v 1.5.2.2 2005/09/15 20:58:40 dgp Exp $
 */

#include "tclInt.h"

/*
 * The panicProc variable contains a pointer to an application specific panic
 * procedure.
................................................................................
 *
 * Side effects:
 *	The process dies, entering the debugger if possible.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
void
Tcl_Panic(CONST char *format, ...)
{
    va_list argList;



    va_start(argList, format);
    Tcl_PanicVA(format, argList);
    va_end (argList);
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclProc.c,v 1.66.2.6 2005/08/19 21:55:21 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for static functions in this file
................................................................................
    result = Tcl_SplitList(interp, args, &numArgs, &argArray);
    if (result != TCL_OK) {
	goto procError;
    }

    if (precompiled) {
	if (numArgs > procPtr->numArgs) {
	    char buf[40 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE];


	    sprintf(buf, "%d entries, precompiled header expects %d",
		    numArgs, procPtr->numArgs);
	    Tcl_AppendResult(interp, "procedure \"", procName,
		    "\": arg list contains ", buf, NULL);
	    goto procError;
	}
	localPtr = procPtr->firstLocalPtr;
    } else {
	procPtr->numArgs = numArgs;
	procPtr->numCompiledLocals = numArgs;
    }
................................................................................
	    if ((localPtr->nameLength != nameLength)
		    || (strcmp(localPtr->name, fieldValues[0]))
		    || (localPtr->frameIndex != i)
		    || ((localPtr->flags & ~VAR_UNDEFINED)
			    != (VAR_SCALAR | VAR_ARGUMENT))
		    || (localPtr->defValuePtr == NULL && fieldCount == 2)
		    || (localPtr->defValuePtr != NULL && fieldCount != 2)) {
		char buf[40 + TCL_INTEGER_SPACE];


		ckfree((char *) fieldValues);
		sprintf(buf, "%d is inconsistent with precompiled body", i);
		Tcl_AppendResult(interp, "procedure \"", procName,
			"\": formal parameter ", buf, (char *) NULL);
		goto procError;
	    }

	    /*
	     * compare the default value if any
	     */

	    if (localPtr->defValuePtr != NULL) {
		int tmpLength;
		char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr,
			&tmpLength);
		if ((valueLength != tmpLength) ||
			strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) {
		    Tcl_AppendResult(interp, "procedure \"", procName,


			    "\": formal parameter \"", fieldValues[0],
			    "\" has default value inconsistent with ",
			    "precompiled body", (char *) NULL);


		    ckfree((char *) fieldValues);
		    goto procError;
		}
		if ((i == numArgs - 1)
			&& (localPtr->nameLength == 4)
			&& (localPtr->name[0] == 'a')
			&& (strcmp(localPtr->name, "args") == 0)) {
................................................................................

	Tcl_Obj *objPtr;

	objPtr = Tcl_ConcatObj(objc, objv);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }
    if (result == TCL_ERROR) {
	char msg[32 + TCL_INTEGER_SPACE];
	sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
	Tcl_AddObjErrorInfo(interp, msg, -1);
    }

    /*
     * Restore the variable frame, and return.
     */

    iPtr->varFramePtr = savedVarFramePtr;
................................................................................
	    TclPopStackFrame(interp);
	}

 	iPtr->compiledProcPtr = saveProcPtr;

 	if (result != TCL_OK) {
 	    if (result == TCL_ERROR) {
		Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
		Tcl_Obj *message =
			Tcl_NewStringObj("\n    (compiling ", -1);

		Tcl_IncrRefCount(message);
		Tcl_AppendStringsToObj(message, description, " \"", NULL);
		TclAppendLimitedToObj(message, procName, -1, 50, NULL);
		Tcl_AppendToObj(message, "\", line ", -1);
		Tcl_AppendObjToObj(message, errorLine);
		Tcl_DecrRefCount(errorLine);
		Tcl_AppendToObj(message, ")", -1);
 		TclAppendObjToErrorInfo(interp, message);
		Tcl_DecrRefCount(message);



	    }
 	    return result;
 	}
    } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
	/*
	 * The resolver epoch has changed, but we only need to invalidate the
	 * resolver cache.
................................................................................
				 * called and returned returnCode. */
    char *procName;		/* Name of the procedure. Used for error
				 * messages and trace information. */
    int nameLen;		/* Number of bytes in procedure's name. */
    int returnCode;		/* The unexpected result code. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *message, *errorLine;

    if (returnCode == TCL_OK) {
	return TCL_OK;
    }
    if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) {
	return returnCode;
    }
................................................................................
    }
    if (returnCode != TCL_ERROR) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "invoked \"",
		((returnCode == TCL_BREAK) ? "break" : "continue"),
		"\" outside of a loop", NULL);
    }
    errorLine = Tcl_NewIntObj(interp->errorLine);
    message = Tcl_NewStringObj("\n    (procedure \"", -1);
    Tcl_IncrRefCount(message);
    TclAppendLimitedToObj(message, procName, nameLen, 60, NULL);
    Tcl_AppendToObj(message, "\" line ", -1);
    Tcl_AppendObjToObj(message, errorLine);
    Tcl_DecrRefCount(errorLine);
    Tcl_AppendToObj(message, ")", -1);
    TclAppendObjToErrorInfo(interp, message);
    Tcl_DecrRefCount(message);
    return TCL_ERROR;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclProcDeleteProc --

 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclProc.c,v 1.66.2.7 2005/09/15 20:58:40 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for static functions in this file
................................................................................
    result = Tcl_SplitList(interp, args, &numArgs, &argArray);
    if (result != TCL_OK) {
	goto procError;
    }

    if (precompiled) {
	if (numArgs > procPtr->numArgs) {
	    Tcl_Obj *objPtr = Tcl_NewObj();
	    TclObjPrintf(NULL, objPtr,
		    "procedure \"%s\": arg list contains %d entries, "
		    "precompiled header expects %d", procName, numArgs,
		    procPtr->numArgs);
	    Tcl_SetObjResult(interp, objPtr);

	    goto procError;
	}
	localPtr = procPtr->firstLocalPtr;
    } else {
	procPtr->numArgs = numArgs;
	procPtr->numCompiledLocals = numArgs;
    }
................................................................................
	    if ((localPtr->nameLength != nameLength)
		    || (strcmp(localPtr->name, fieldValues[0]))
		    || (localPtr->frameIndex != i)
		    || ((localPtr->flags & ~VAR_UNDEFINED)
			    != (VAR_SCALAR | VAR_ARGUMENT))
		    || (localPtr->defValuePtr == NULL && fieldCount == 2)
		    || (localPtr->defValuePtr != NULL && fieldCount != 2)) {
		Tcl_Obj *objPtr = Tcl_NewObj();

		TclObjPrintf(NULL, objPtr,
			"procedure \"%s\": formal parameter %d is "
			"inconsistent with precompiled body", procName, i);
		Tcl_SetObjResult(interp, objPtr);
		ckfree((char *) fieldValues);
		goto procError;
	    }

	    /*
	     * compare the default value if any
	     */

	    if (localPtr->defValuePtr != NULL) {
		int tmpLength;
		char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr,
			&tmpLength);
		if ((valueLength != tmpLength) ||
			strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) {
		    Tcl_Obj *objPtr = Tcl_NewObj();

		    TclObjPrintf(NULL, objPtr,
			    "procedure \"%s\": formal parameter \"%s\" has "
			    "default value inconsistent with precompiled body",

			    procName, fieldValues[0]);
		    Tcl_SetObjResult(interp, objPtr);
		    ckfree((char *) fieldValues);
		    goto procError;
		}
		if ((i == numArgs - 1)
			&& (localPtr->nameLength == 4)
			&& (localPtr->name[0] == 'a')
			&& (strcmp(localPtr->name, "args") == 0)) {
................................................................................

	Tcl_Obj *objPtr;

	objPtr = Tcl_ConcatObj(objc, objv);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }
    if (result == TCL_ERROR) {
	TclFormatToErrorInfo(interp, "\n    (\"uplevel\" body line %d)",
		interp->errorLine);

    }

    /*
     * Restore the variable frame, and return.
     */

    iPtr->varFramePtr = savedVarFramePtr;
................................................................................
	    TclPopStackFrame(interp);
	}

 	iPtr->compiledProcPtr = saveProcPtr;

 	if (result != TCL_OK) {
 	    if (result == TCL_ERROR) {
		int length = strlen(procName);
		int limit = 50;
		int overflow = (length > limit);








		TclFormatToErrorInfo(interp,

			"\n    (compiling %s \"%.*s%s\", line %d)",
			description, (overflow ? limit : length), procName,
			(overflow ? "..." : ""), interp->errorLine);
	    }
 	    return result;
 	}
    } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
	/*
	 * The resolver epoch has changed, but we only need to invalidate the
	 * resolver cache.
................................................................................
				 * called and returned returnCode. */
    char *procName;		/* Name of the procedure. Used for error
				 * messages and trace information. */
    int nameLen;		/* Number of bytes in procedure's name. */
    int returnCode;		/* The unexpected result code. */
{
    Interp *iPtr = (Interp *) interp;
    int overflow, limit = 60;

    if (returnCode == TCL_OK) {
	return TCL_OK;
    }
    if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) {
	return returnCode;
    }
................................................................................
    }
    if (returnCode != TCL_ERROR) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "invoked \"",
		((returnCode == TCL_BREAK) ? "break" : "continue"),
		"\" outside of a loop", NULL);
    }
    overflow = (nameLen > limit);
    TclFormatToErrorInfo(interp, "\n    (procedure \"%.*s%s\" line %d)",
	    (overflow ? limit : nameLen), procName,
	    (overflow ? "..." : ""), interp->errorLine);






    return TCL_ERROR;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclProcDeleteProc --

 *	This file contains code to manage the interpreter result.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclResult.c,v 1.23.2.4 2005/09/09 18:48:40 dgp Exp $
 */

#include "tclInt.h"

/*
 * Indices of the standard return options dictionary keys.
 */
................................................................................
 *	If the string result is non-empty, the object result forced to be a
 *	duplicate of it first. There will be a string result afterwards.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
    Tcl_Interp *interp;
    va_list argList;

    interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);

    Tcl_AppendResultVA(interp, argList);
    va_end(argList);
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 *	The errorCode field of the interp is modified to hold all of the
 *	arguments to this function, in a list form with each argument becoming
 *	one element of the list.
 *
 *----------------------------------------------------------------------
 */

	/* VARARGS2 */
void
Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)

{
    Tcl_Interp *interp;
    va_list argList;

    /*
     * Scan through the arguments one at a time, appending them to the
     * errorCode field as list elements.
     */

    interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
    Tcl_SetErrorCodeVA(interp, argList);
    va_end(argList);
}
 
/*
 *----------------------------------------------------------------------
 *

 *	This file contains code to manage the interpreter result.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclResult.c,v 1.23.2.5 2005/09/15 20:58:40 dgp Exp $
 */

#include "tclInt.h"

/*
 * Indices of the standard return options dictionary keys.
 */
................................................................................
 *	If the string result is non-empty, the object result forced to be a
 *	duplicate of it first. There will be a string result afterwards.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendResult(Tcl_Interp *interp, ...)
{

    va_list argList;


    va_start(argList, interp);
    Tcl_AppendResultVA(interp, argList);
    va_end(argList);
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 *	The errorCode field of the interp is modified to hold all of the
 *	arguments to this function, in a list form with each argument becoming
 *	one element of the list.
 *
 *----------------------------------------------------------------------
 */


void

Tcl_SetErrorCode(Tcl_Interp *interp, ...)
{

    va_list argList;

    /*
     * Scan through the arguments one at a time, appending them to the
     * errorCode field as list elements.
     */

    va_start(argList, interp);
    Tcl_SetErrorCodeVA(interp, argList);
    va_end(argList);
}
 
/*
 *----------------------------------------------------------------------
 *

 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStringObj.c,v 1.35.2.8 2005/09/12 19:39:01 dgp Exp $ */

#include "tclInt.h"
#include "tommath.h"

/*
 * Prototypes for functions defined later in this file:
 */
................................................................................
			    int numChars));
static void		AppendUtfToUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    CONST char *bytes, int numBytes));
static void		AppendUtfToUtfRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    CONST char *bytes, int numBytes));
static void		FillUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static int		FormatObjVA _ANSI_ARGS_((Tcl_Interp *interp,

			    va_list argList));
static int		ObjPrintfVA _ANSI_ARGS_((Tcl_Interp *interp,

			    va_list argList));
static void		FreeStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static void		DupStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr));
static int		SetStringFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static void		UpdateStringOfString _ANSI_ARGS_((Tcl_Obj *objPtr));
................................................................................
 *	The contents of all the string arguments are appended to the string
 *	representation of objPtr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendStringsToObj TCL_VARARGS_DEF(Tcl_Obj *,arg1)
{
    register Tcl_Obj *objPtr;
    va_list argList;

    objPtr = TCL_VARARGS_START(Tcl_Obj *,arg1,argList);

    Tcl_AppendStringsToObjVA(objPtr, argList);
    va_end(argList);
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclAppendFormattedObjs(interp, baseObj, format, objc, objv)
    Tcl_Interp *interp;
    Tcl_Obj *baseObj;
    CONST char *format;
    int objc;
    Tcl_Obj *CONST objv[];
{
    CONST char *span = format;
    int numBytes = 0;
    int objIndex = 0;
    int gotXpg = 0, gotSequential = 0;
    Tcl_Obj *appendObj = Tcl_NewObj();
    CONST char *msg;
    CONST char *mixedXPG = "cannot mix \"%\" and \"%n$\" conversion specifiers";
    CONST char *badIndex[2] = {
	"not enough arguments for all format specifiers",
	"\"%n$\" argument index out of range"
    };

    if (Tcl_IsShared(baseObj)) {
	Tcl_Panic("TclAppendFormattedObjs called with shared object");
    }


    Tcl_IncrRefCount(appendObj);
    /* format string is NUL-terminated */
    while (*format != '\0') {
	char *end;
	int gotMinus, gotHash, gotZero, gotSpace, gotPlus, sawFlag;
	int width, gotPrecision, precision, useShort, useWide, useBig;
	int newXpg, numChars, allocSegment = 0;
	Tcl_Obj *segment;
................................................................................
	objIndex += gotSequential;
    }
    if (numBytes) {
	Tcl_AppendToObj(appendObj, span, numBytes);
	numBytes = 0;
    }

    Tcl_AppendObjToObj(baseObj, appendObj);
    Tcl_DecrRefCount(appendObj);
    return TCL_OK;

  errorMsg:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
    }
  error:
    Tcl_DecrRefCount(appendObj);
    return TCL_ERROR;
}
 
/*
 *---------------------------------------------------------------------------
 *
 * FormatObjVA --
................................................................................
 * Side effects:
 *	Reallocates the String internal rep.
 *
 *---------------------------------------------------------------------------
 */

static int
FormatObjVA(interp, argList)
    Tcl_Interp *interp;


    va_list argList;
{
    int code, objc;
    Tcl_Obj **objv, *element, *list = Tcl_NewObj();
    CONST char *format;
    Tcl_Obj *objPtr = va_arg(argList, Tcl_Obj *);

    if (objPtr == NULL) {
	Tcl_Panic("TclFormatObj: no Tcl_Obj to append to");
    }

    format = va_arg(argList, CONST char *);
    if (format == NULL) {
	Tcl_Panic("TclFormatObj: no format string argument");
    }

    Tcl_IncrRefCount(list);
    element = va_arg(argList, Tcl_Obj *);
    while (element != NULL) {
	Tcl_ListObjAppendElement(NULL, list, element);
	element = va_arg(argList, Tcl_Obj *);
    }
................................................................................
 * Side effects:
 * 	None.
 *
 *---------------------------------------------------------------------------
 */

int
TclFormatObj TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
    va_list argList;
    int result;
    Tcl_Interp *interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
    result = FormatObjVA(interp, argList);

    va_end(argList);
    return result;
}
 
/*
 *---------------------------------------------------------------------------
 *
................................................................................
 *
 * Side effects:
 *
 *---------------------------------------------------------------------------
 */

static int
ObjPrintfVA(interp, argList)
    Tcl_Interp *interp;


    va_list argList;
{
    int code, objc;
    Tcl_Obj **objv, *list = Tcl_NewObj();
    CONST char *format, *p;
    Tcl_Obj *objPtr = va_arg(argList, Tcl_Obj *);

    if (objPtr == NULL) {
	Tcl_Panic("TclObjPrintf: no Tcl_Obj to append to");
    }

    p = format = va_arg(argList, CONST char *);
    if (format == NULL) {
	Tcl_Panic("TclObjPrintf: no format string argument");
    }

    Tcl_IncrRefCount(list);
    while (*p != '\0') {
	int size = 0;
	int seekingConversion = 1;


	if (*p++ != '%') {
	    continue;
	}
	if (*p == '%') {
	    p++;
	    continue;
	}
	do {
	    switch (*p) {

	    case '\0':
		seekingConversion = 0;
		break;
	    case 's':
		Tcl_ListObjAppendElement(NULL, list, Tcl_NewStringObj(
			va_arg(argList, char *), -1));
		seekingConversion = 0;
















		break;

	    case 'c':
	    case 'i':
	    case 'u':
	    case 'd':
	    case 'o':
	    case 'x':
	    case 'X':
................................................................................
	    case 'f':
	    case 'g':
	    case 'G':
		Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
			va_arg(argList, double)));
		seekingConversion = 0;
		break;















	    case 'l':
		size = 1;
		p++;
		break;
	    case 'h':
		size = -1;
	    default:
................................................................................
 * Side effects:
 * 	None.
 *
 *---------------------------------------------------------------------------
 */

int
TclObjPrintf TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
    va_list argList;
    int result;
    Tcl_Interp *interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);


    result = ObjPrintfVA(interp, argList);
    va_end(argList);
    return result;
}






























 
/*
 *---------------------------------------------------------------------------
 *
 * FillUnicodeRep --
 *
 *	Populate the Unicode internal rep with the Unicode form of its string

 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStringObj.c,v 1.35.2.9 2005/09/15 20:58:40 dgp Exp $ */

#include "tclInt.h"
#include "tommath.h"

/*
 * Prototypes for functions defined later in this file:
 */
................................................................................
			    int numChars));
static void		AppendUtfToUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    CONST char *bytes, int numBytes));
static void		AppendUtfToUtfRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    CONST char *bytes, int numBytes));
static void		FillUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static int		FormatObjVA _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr, CONST char *format,
			    va_list argList));
static int		ObjPrintfVA _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr, CONST char *format,
			    va_list argList));
static void		FreeStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static void		DupStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr));
static int		SetStringFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static void		UpdateStringOfString _ANSI_ARGS_((Tcl_Obj *objPtr));
................................................................................
 *	The contents of all the string arguments are appended to the string
 *	representation of objPtr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...)
{

    va_list argList;


    va_start(argList, objPtr);
    Tcl_AppendStringsToObjVA(objPtr, argList);
    va_end(argList);
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclAppendFormattedObjs(interp, appendObj, format, objc, objv)
    Tcl_Interp *interp;
    Tcl_Obj *appendObj;
    CONST char *format;
    int objc;
    Tcl_Obj *CONST objv[];
{
    CONST char *span = format;
    int numBytes = 0;
    int objIndex = 0;
    int gotXpg = 0, gotSequential = 0;
    int originalLength;
    CONST char *msg;
    CONST char *mixedXPG = "cannot mix \"%\" and \"%n$\" conversion specifiers";
    CONST char *badIndex[2] = {
	"not enough arguments for all format specifiers",
	"\"%n$\" argument index out of range"
    };

    if (Tcl_IsShared(appendObj)) {
	Tcl_Panic("TclAppendFormattedObjs called with shared object");
    }
    Tcl_GetStringFromObj(appendObj, &originalLength);


    /* format string is NUL-terminated */
    while (*format != '\0') {
	char *end;
	int gotMinus, gotHash, gotZero, gotSpace, gotPlus, sawFlag;
	int width, gotPrecision, precision, useShort, useWide, useBig;
	int newXpg, numChars, allocSegment = 0;
	Tcl_Obj *segment;
................................................................................
	objIndex += gotSequential;
    }
    if (numBytes) {
	Tcl_AppendToObj(appendObj, span, numBytes);
	numBytes = 0;
    }



    return TCL_OK;

  errorMsg:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
    }
  error:
    Tcl_SetObjLength(appendObj, originalLength);
    return TCL_ERROR;
}
 
/*
 *---------------------------------------------------------------------------
 *
 * FormatObjVA --
................................................................................
 * Side effects:
 *	Reallocates the String internal rep.
 *
 *---------------------------------------------------------------------------
 */

static int

FormatObjVA(Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    CONST char *format,
    va_list argList)
{
    int code, objc;
    Tcl_Obj **objv, *element, *list = Tcl_NewObj();












    Tcl_IncrRefCount(list);
    element = va_arg(argList, Tcl_Obj *);
    while (element != NULL) {
	Tcl_ListObjAppendElement(NULL, list, element);
	element = va_arg(argList, Tcl_Obj *);
    }
................................................................................
 * Side effects:
 * 	None.
 *
 *---------------------------------------------------------------------------
 */

int
TclFormatObj(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, ...)
{
    va_list argList;
    int result;

    va_start(argList, format);
    result = FormatObjVA(interp, objPtr, format, argList);
    va_end(argList);
    return result;
}
 
/*
 *---------------------------------------------------------------------------
 *
................................................................................
 *
 * Side effects:
 *
 *---------------------------------------------------------------------------
 */

static int
ObjPrintfVA(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    CONST char *format,
    va_list argList)
{
    int code, objc;
    Tcl_Obj **objv, *list = Tcl_NewObj();
    CONST char *p;
    char *end;





    p = format;




    Tcl_IncrRefCount(list);
    while (*p != '\0') {

	int size = 0, seekingConversion = 1, gotPrecision = 0;
	int lastNum = -1, numBytes = -1;

	if (*p++ != '%') {
	    continue;
	}
	if (*p == '%') {
	    p++;
	    continue;
	}
	do {
	    switch (*p) {

	    case '\0':
		seekingConversion = 0;
		break;
	    case 's': {

		char *bytes = va_arg(argList, char *);
		seekingConversion = 0;
		if (gotPrecision) {
		    char *end = bytes + lastNum;
		    char *q = bytes;
		    while ((q < end) && (*q != '\0')) {
			q++;
		    }
		    numBytes = (int)(q - bytes);
		}
		Tcl_ListObjAppendElement(NULL, list,
			Tcl_NewStringObj(bytes , numBytes));
		/* We took no more than numBytes bytes from the (char *).
		 * In turn, [format] will take no more than numBytes
		 * characters from the Tcl_Obj.  Since numBytes characters
		 * must be no less than numBytes bytes, the character limit
		 * will have no effect and we can just pass it through.
		 */
		break;
	    }
	    case 'c':
	    case 'i':
	    case 'u':
	    case 'd':
	    case 'o':
	    case 'x':
	    case 'X':
................................................................................
	    case 'f':
	    case 'g':
	    case 'G':
		Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
			va_arg(argList, double)));
		seekingConversion = 0;
		break;
	    case '*':
		lastNum = (int)va_arg(argList, int);
		Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum));
		p++;
		break;
	    case '0': case '1': case '2': case '3': case '4':
	    case '5': case '6': case '7': case '8': case '9':
		lastNum = (int) strtoul(p, &end, 10);
		p = end;
		break;
	    case '.':
		gotPrecision = 1;
		p++;
		break;
	    /* TODO: support for wide (and bignum?) arguments */
	    case 'l':
		size = 1;
		p++;
		break;
	    case 'h':
		size = -1;
	    default:
................................................................................
 * Side effects:
 * 	None.
 *
 *---------------------------------------------------------------------------
 */

int
TclObjPrintf(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, ...)
{
    va_list argList;
    int result;


    va_start(argList, format);
    result = ObjPrintfVA(interp, objPtr, format, argList);
    va_end(argList);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclFormatToErrorInfo --
 *
 * Results:
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

int
TclFormatToErrorInfo(Tcl_Interp *interp, CONST char *format, ...)
{
    int code;
    va_list argList;
    Tcl_Obj *objPtr = Tcl_NewObj();

    va_start(argList, format);
    code = ObjPrintfVA(interp, objPtr, format, argList);
    va_end(argList);
    if (code != TCL_OK) {
        return code;
    }
    TclAppendObjToErrorInfo(interp, objPtr);
    Tcl_DecrRefCount(objPtr);
    return TCL_OK;
}
 
/*
 *---------------------------------------------------------------------------
 *
 * FillUnicodeRep --
 *
 *	Populate the Unicode internal rep with the Unicode form of its string

 *	including the "after" command.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTimer.c,v 1.12.2.4 2005/08/02 18:16:10 dgp Exp $
 */

#include "tclInt.h"

/*
 * For each timer callback that's pending there is one record of the following
 * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained
................................................................................
    int length;
    char *argString;
    int index;
    char buf[16 + TCL_INTEGER_SPACE];
    static CONST char *afterSubCmds[] = {
	"cancel", "idle", "info", (char *) NULL
    };

    enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
    ThreadSpecificData *tsdPtr = InitTimer();

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
	return TCL_ERROR;
    }
................................................................................

	afterPtr->id = tsdPtr->afterId;
	tsdPtr->afterId += 1;
	afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc,
		(ClientData) afterPtr);
	afterPtr->nextPtr = assocPtr->firstAfterPtr;
	assocPtr->firstAfterPtr = afterPtr;

	sprintf(buf, "after#%d", afterPtr->id);
	Tcl_AppendResult(interp, buf, (char *) NULL);
	return TCL_OK;
    }

    /*
     * If it's not a number it must be a subcommand. Note that we're using a
     * custom error message here, so we do not pass an interpreter to T_GIFO.
     */
................................................................................
	Tcl_IncrRefCount(afterPtr->commandPtr);
	afterPtr->id = tsdPtr->afterId;
	tsdPtr->afterId += 1;
	afterPtr->token = NULL;
	afterPtr->nextPtr = assocPtr->firstAfterPtr;
	assocPtr->firstAfterPtr = afterPtr;
	Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);

	sprintf(buf, "after#%d", afterPtr->id);
	Tcl_AppendResult(interp, buf, (char *) NULL);
	break;
    case AFTER_INFO: {
	Tcl_Obj *resultListPtr;

	if (objc == 2) {
	    for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
		    afterPtr = afterPtr->nextPtr) {

 *	including the "after" command.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTimer.c,v 1.12.2.5 2005/09/15 20:58:40 dgp Exp $
 */

#include "tclInt.h"

/*
 * For each timer callback that's pending there is one record of the following
 * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained
................................................................................
    int length;
    char *argString;
    int index;
    char buf[16 + TCL_INTEGER_SPACE];
    static CONST char *afterSubCmds[] = {
	"cancel", "idle", "info", (char *) NULL
    };
    Tcl_Obj *objPtr;
    enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
    ThreadSpecificData *tsdPtr = InitTimer();

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
	return TCL_ERROR;
    }
................................................................................

	afterPtr->id = tsdPtr->afterId;
	tsdPtr->afterId += 1;
	afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc,
		(ClientData) afterPtr);
	afterPtr->nextPtr = assocPtr->firstAfterPtr;
	assocPtr->firstAfterPtr = afterPtr;
	objPtr = Tcl_NewObj();
	TclObjPrintf(NULL, objPtr, "after#%d", afterPtr->id);
	Tcl_SetObjResult(interp, objPtr);
	return TCL_OK;
    }

    /*
     * If it's not a number it must be a subcommand. Note that we're using a
     * custom error message here, so we do not pass an interpreter to T_GIFO.
     */
................................................................................
	Tcl_IncrRefCount(afterPtr->commandPtr);
	afterPtr->id = tsdPtr->afterId;
	tsdPtr->afterId += 1;
	afterPtr->token = NULL;
	afterPtr->nextPtr = assocPtr->firstAfterPtr;
	assocPtr->firstAfterPtr = afterPtr;
	Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
	objPtr = Tcl_NewObj();
	TclObjPrintf(NULL, objPtr, "after#%d", afterPtr->id);
	Tcl_SetObjResult(interp, objPtr);
	break;
    case AFTER_INFO: {
	Tcl_Obj *resultListPtr;

	if (objc == 2) {
	    for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
		    afterPtr = afterPtr->nextPtr) {

 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 *  RCS: @(#) $Id: tclUtil.c,v 1.51.2.19 2005/09/09 18:48:40 dgp Exp $
 */

#include "tclInt.h"
#include <float.h>
#include <math.h>

/*
................................................................................
		}

		/*
		 * Garbage after the closing brace; return an error.
		 */

		if (interp != NULL) {
		    char buf[100];

		    p2 = p;
		    while ((p2 < limit)
			    && (!isspace(UCHAR(*p2)))	/* INTL: ISO space. */
			    && (p2 < p+20)) {
			p2++;
		    }
		    sprintf(buf,
			    "list element in braces followed by \"%.*s\" instead of space",
			    (int) (p2-p), p);
		    Tcl_SetResult(interp, buf, TCL_VOLATILE);
		}
		return TCL_ERROR;
	    }
	    break;

	    /*
	     * Backslash: skip over everything up to the end of the backslash
................................................................................
		}

		/*
		 * Garbage after the closing quote; return an error.
		 */

		if (interp != NULL) {
		    char buf[100];

		    p2 = p;
		    while ((p2 < limit)
			    && (!isspace(UCHAR(*p2)))	/* INTL: ISO space */
			    && (p2 < p+20)) {
			p2++;
		    }
		    sprintf(buf,
			    "list element in quotes followed by \"%.*s\" %s",
			    (int) (p2-p), p, "instead of space");
		    Tcl_SetResult(interp, buf, TCL_VOLATILE);
		}
		return TCL_ERROR;
	    }
	    break;
	}
	p++;
    }

 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 *  RCS: @(#) $Id: tclUtil.c,v 1.51.2.20 2005/09/15 20:58:40 dgp Exp $
 */

#include "tclInt.h"
#include <float.h>
#include <math.h>

/*
................................................................................
		}

		/*
		 * Garbage after the closing brace; return an error.
		 */

		if (interp != NULL) {
		    Tcl_Obj *objPtr = Tcl_NewObj();

		    p2 = p;
		    while ((p2 < limit)
			    && (!isspace(UCHAR(*p2)))	/* INTL: ISO space. */
			    && (p2 < p+20)) {
			p2++;
		    }
		    TclObjPrintf(NULL, objPtr,
			    "list element in braces followed by \"%.*s\" "
			    "instead of space", (int) (p2-p), p);
		    Tcl_SetObjResult(interp, objPtr);
		}
		return TCL_ERROR;
	    }
	    break;

	    /*
	     * Backslash: skip over everything up to the end of the backslash
................................................................................
		}

		/*
		 * Garbage after the closing quote; return an error.
		 */

		if (interp != NULL) {
		    Tcl_Obj *objPtr = Tcl_NewObj();

		    p2 = p;
		    while ((p2 < limit)
			    && (!isspace(UCHAR(*p2)))	/* INTL: ISO space */
			    && (p2 < p+20)) {
			p2++;
		    }
		    TclObjPrintf(NULL, objPtr,
			    "list element in quotes followed by \"%.*s\" "
			    "instead of space", (int) (p2-p), p);
		    Tcl_SetObjResult(interp, objPtr);
		}
		return TCL_ERROR;
	    }
	    break;
	}
	p++;
    }

# init.tcl --
#
# Default system startup file for Tcl-based applications.  Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.69.2.5 2005/08/25 15:46:31 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
# Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
................................................................................
		# Compute stack trace contribution from the [uplevel].
		# Note the dependence on how Tcl_AddErrorInfo, etc. 
		# construct the stack trace.
		#
		set errorInfo [dict get $opts -errorinfo]
		set errorCode [dict get $opts -errorcode]
		set cinfo $args
		if {[string bytelength $cinfo] > 153} {
		    set cinfo [string range $cinfo 0 152]
		    while {[string bytelength $cinfo] > 150} {
			set cinfo [string range $cinfo 0 end-1]
		    }
		    append cinfo ...
		}
		append cinfo "\"\n    (\"uplevel\" body line 1)"
		append cinfo "\n    invoked from within"

# init.tcl --
#
# Default system startup file for Tcl-based applications.  Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.69.2.6 2005/09/15 20:58:40 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
# Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
................................................................................
		# Compute stack trace contribution from the [uplevel].
		# Note the dependence on how Tcl_AddErrorInfo, etc. 
		# construct the stack trace.
		#
		set errorInfo [dict get $opts -errorinfo]
		set errorCode [dict get $opts -errorcode]
		set cinfo $args
		if {[string bytelength $cinfo] > 150} {
		    set cinfo [string range $cinfo 0 150]
		    while {[string bytelength $cinfo] > 150} {
			set cinfo [string range $cinfo 0 end-1]
		    }
		    append cinfo ...
		}
		append cinfo "\"\n    (\"uplevel\" body line 1)"
		append cinfo "\n    invoked from within"

#	interface.  
#	
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: genStubs.tcl,v 1.17 2004/03/17 18:14:18 das Exp $

package require Tcl 8

namespace eval genStubs {
    # libraryName --
    #
    #	The name of the entire library.  This value is used to compute
................................................................................
    set arg1 [lindex $args 0]
    switch -exact $arg1 {
	void {
	    append line "(void)"
	}
	TCL_VARARGS {
	    set arg [lindex $args 1]
	    append line "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])"
	}
	default {
	    set sep "("
	    foreach arg $args {
		append line $sep
		set next {}
		append next [lindex $arg 0] " " [lindex $arg 1] \
................................................................................

    append text "/* Slot $index */\n" $rtype "\n" $fname

    set arg1 [lindex $args 0]

    if {![string compare $arg1 "TCL_VARARGS"]} {
	lassign [lindex $args 1] type argName 
	append text " TCL_VARARGS_DEF($type,$argName)\n\{\n"
	append text "    " $type " var;\n    va_list argList;\n"
	if {[string compare $rtype "void"]} {
	    append text "    " $rtype " resultValue;\n"
	}
	append text "\n    var = (" $type ") TCL_VARARGS_START(" \
		$type "," $argName ",argList);\n\n    "
	if {[string compare $rtype "void"]} {
	    append text "resultValue = "
	}
	append text "(" $name "StubsPtr->" $lfname "VA)(var, argList);\n"
	append text "    va_end(argList);\n"
	if {[string compare $rtype "void"]} {
	    append text "return resultValue;\n"
................................................................................
    set arg1 [lindex $args 0]
    switch -exact $arg1 {
	void {
	    append text "(void)"
	}
	TCL_VARARGS {
	    set arg [lindex $args 1]
	    append text "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])"
	}
	default {
	    set sep "("
	    foreach arg $args {
		append text $sep [lindex $arg 0] " " [lindex $arg 1] \
			[lindex $arg 2]
		set sep ", "

#	interface.  
#	
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: genStubs.tcl,v 1.17.2.1 2005/09/15 20:58:40 dgp Exp $

package require Tcl 8

namespace eval genStubs {
    # libraryName --
    #
    #	The name of the entire library.  This value is used to compute
................................................................................
    set arg1 [lindex $args 0]
    switch -exact $arg1 {
	void {
	    append line "(void)"
	}
	TCL_VARARGS {
	    set arg [lindex $args 1]
	    append line "([lindex $arg 0][lindex $arg 1], ...)"
	}
	default {
	    set sep "("
	    foreach arg $args {
		append line $sep
		set next {}
		append next [lindex $arg 0] " " [lindex $arg 1] \
................................................................................

    append text "/* Slot $index */\n" $rtype "\n" $fname

    set arg1 [lindex $args 0]

    if {![string compare $arg1 "TCL_VARARGS"]} {
	lassign [lindex $args 1] type argName 
	append text " ($type$argName, ...)\n\{\n"
	append text "    " $type " var;\n    va_list argList;\n"
	if {[string compare $rtype "void"]} {
	    append text "    " $rtype " resultValue;\n"
	}
	append text "\n    var = (" $type ") (va_start(argList, " \
		$argName "), " $argName ");\n\n    "
	if {[string compare $rtype "void"]} {
	    append text "resultValue = "
	}
	append text "(" $name "StubsPtr->" $lfname "VA)(var, argList);\n"
	append text "    va_end(argList);\n"
	if {[string compare $rtype "void"]} {
	    append text "return resultValue;\n"
................................................................................
    set arg1 [lindex $args 0]
    switch -exact $arg1 {
	void {
	    append text "(void)"
	}
	TCL_VARARGS {
	    set arg [lindex $args 1]
	    append text "([lindex $arg 0][lindex $arg 1], ...)"
	}
	default {
	    set sep "("
	    foreach arg $args {
		append text $sep [lindex $arg 0] " " [lindex $arg 1] \
			[lindex $arg 2]
		set sep ", "

cat >>confdefs.h <<\_ACEOF
#define _LARGEFILE64_SOURCE 1
_ACEOF

	tcl_flags="$tcl_flags _LARGEFILE64_SOURCE"
    fi








































































































    if test "x${tcl_flags}" = "x" ; then
	echo "$as_me:$LINENO: result: none" >&5
echo "${ECHO_T}none" >&6
    else
	echo "$as_me:$LINENO: result: ${tcl_flags}" >&5
echo "${ECHO_T}${tcl_flags}" >&6
    fi

cat >>confdefs.h <<\_ACEOF
#define _LARGEFILE64_SOURCE 1
_ACEOF

	tcl_flags="$tcl_flags _LARGEFILE64_SOURCE"
    fi

    if test "${tcl_cv_flag__largefile_source64+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/stat.h>
int
main ()
{
char *p = (char *)open64;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_flag__largefile_source64=no
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#define _LARGEFILE_SOURCE64 1
#include <sys/stat.h>
int
main ()
{
char *p = (char *)open64;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_flag__largefile_source64=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_flag__largefile_source64=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi

    if test "x${tcl_cv_flag__largefile_source64}" = "xyes" ; then

cat >>confdefs.h <<\_ACEOF
#define _LARGEFILE_SOURCE64 1
_ACEOF

	tcl_flags="$tcl_flags _LARGEFILE_SOURCE64"
    fi
    if test "x${tcl_flags}" = "x" ; then
	echo "$as_me:$LINENO: result: none" >&5
echo "${ECHO_T}none" >&6
    else
	echo "$as_me:$LINENO: result: ${tcl_flags}" >&5
echo "${ECHO_T}${tcl_flags}" >&6
    fi

AC_DEFUN(SC_TCL_EARLY_FLAGS,[
    AC_MSG_CHECKING([for required early compiler flags])
    tcl_flags=""
    SC_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include <stdlib.h>],
	[char *p = (char *)strtoll; char *q = (char *)strtoull;])
    SC_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include <sys/stat.h>],
	[struct stat64 buf; int i = stat64("/", &buf);])


    if test "x${tcl_flags}" = "x" ; then
	AC_MSG_RESULT(none)
    else
	AC_MSG_RESULT(${tcl_flags})
    fi])

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

AC_DEFUN(SC_TCL_EARLY_FLAGS,[
    AC_MSG_CHECKING([for required early compiler flags])
    tcl_flags=""
    SC_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include <stdlib.h>],
	[char *p = (char *)strtoll; char *q = (char *)strtoull;])
    SC_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include <sys/stat.h>],
	[struct stat64 buf; int i = stat64("/", &buf);])
    SC_TCL_EARLY_FLAG(_LARGEFILE_SOURCE64,[#include <sys/stat.h>],
	[char *p = (char *)open64;])
    if test "x${tcl_flags}" = "x" ; then
	AC_MSG_RESULT(none)
    else
	AC_MSG_RESULT(${tcl_flags})
    fi])

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

 *	already be translated to native format.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixFCmd.c,v 1.40.2.3 2005/08/02 18:16:56 dgp Exp $
 *
 * Portions of this code were derived from NetBSD source code which has the
 * following copyright notice:
 *
 * Copyright (c) 1988, 1993, 1994
 *      The Regents of the University of California.  All rights reserved.
 *
................................................................................
GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;		    /* The interp we are using for errors. */
    int objIndex;		    /* The index of the attribute. */
    Tcl_Obj *fileName;  	    /* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;	    /* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;
    char returnString[7];
    int result;

    result = TclpObjStat(fileName, &statBuf);

    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"",
		    Tcl_GetString(fileName), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return TCL_ERROR;
    }

    sprintf(returnString, "%0#5lo", (long) (statBuf.st_mode & 0x00007FFF));

    *attributePtrPtr = Tcl_NewStringObj(returnString, -1);

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

 *	already be translated to native format.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixFCmd.c,v 1.40.2.4 2005/09/15 20:58:40 dgp Exp $
 *
 * Portions of this code were derived from NetBSD source code which has the
 * following copyright notice:
 *
 * Copyright (c) 1988, 1993, 1994
 *      The Regents of the University of California.  All rights reserved.
 *
................................................................................
GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;		    /* The interp we are using for errors. */
    int objIndex;		    /* The index of the attribute. */
    Tcl_Obj *fileName;  	    /* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;	    /* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;

    int result;

    result = TclpObjStat(fileName, &statBuf);

    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"",
		    Tcl_GetString(fileName), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return TCL_ERROR;
    }

    *attributePtrPtr = Tcl_NewObj();
    TclObjPrintf(NULL, *attributePtrPtr, "%0#5lo",
	    (long) (statBuf.st_mode & 0x00007FFF));

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