* Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
 * Copyright (c) 2006-2008 by Joe Mistachkin.  All rights reserved.
 * Copyright (c) 2008 Miguel Sofer <msofer@users.sourceforge.net>
 *
 * 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.448 2010/03/05 14:34:03 dkf Exp $
 */

#include "tclInt.h"
#include "tclOOInt.h"
#include "tclCompile.h"
#include <float.h>
#include <limits.h>

    Tcl_Interp *interp)		/* Interpreter to delete. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *hTablePtr;
    ResolverScheme *resPtr, *nextResPtr;
    int i;

    /*
     * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
     */

    if (iPtr->numLevels > 0) {
	Tcl_Panic("DeleteInterpProc called with active evals");

    TclDeleteLiteralTable(interp, &iPtr->literalTable);

    /*
     * TIP #280 - Release the arrays for ByteCode/Proc extension, and
     * contents.
     */






    for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &search);
	    hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&search)) {
	CmdFrame *cfPtr = Tcl_GetHashValue(hPtr);

	if (cfPtr->type == TCL_LOCATION_SOURCE) {
	    Tcl_DecrRefCount(cfPtr->data.eval.path);
	}
	ckfree((char *) cfPtr->line);
	ckfree((char *) cfPtr);
	Tcl_DeleteHashEntry(hPtr);
    }
    Tcl_DeleteHashTable(iPtr->linePBodyPtr);
    ckfree((char *) iPtr->linePBodyPtr);
    iPtr->linePBodyPtr = NULL;

    /*
     * See also tclCompile.c, TclCleanupByteCode
     */

    for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &search);
	    hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&search)) {
	ExtCmdLoc *eclPtr = Tcl_GetHashValue(hPtr);

	if (eclPtr->type == TCL_LOCATION_SOURCE) {
	    Tcl_DecrRefCount(eclPtr->path);
	}
	for (i=0; i< eclPtr->nuloc; i++) {
	    ckfree((char *) eclPtr->loc[i].line);
	}

	if (eclPtr->loc != NULL) {
	    ckfree((char *) eclPtr->loc);
	}

	Tcl_DeleteHashTable(&eclPtr->litInfo);

	ckfree((char *) eclPtr);
	Tcl_DeleteHashEntry(hPtr);
    }
    Tcl_DeleteHashTable(iPtr->lineBCPtr);
    ckfree((char *) iPtr->lineBCPtr);
    iPtr->lineBCPtr = NULL;

    /*
     * Location stack for uplevel/eval/... scripts which were passed through
     * proc arguments. Actually we track all arguments as we do not and cannot
     * know which arguments will be used as scripts and which will not.

     */

    if (iPtr->lineLAPtr->numEntries) {
	/*
	 * When the interp goes away we have nothing on the stack, so there
	 * are no arguments, so this table has to be empty.
	 */

	Tcl_Panic("Argument location tracking table not empty");
    }

    Tcl_DeleteHashTable(iPtr->lineLAPtr);
    ckfree((char *) iPtr->lineLAPtr);
    iPtr->lineLAPtr = NULL;

    if (iPtr->lineLABCPtr->numEntries) {
	/*
	 * When the interp goes away we have nothing on the stack, so there
	 * are no arguments, so this table has to be empty.
	 */

	Tcl_Panic("Argument location tracking table not empty");
    }

    Tcl_DeleteHashTable(iPtr->lineLABCPtr);
    ckfree((char *) iPtr->lineLABCPtr);
    iPtr->lineLABCPtr = NULL;

    /*
     * Squelch the tables of traces on variables and searches over arrays in
     * the in the interpreter.
     */

    Tcl_DeleteHashTable(&iPtr->varTraces);
    Tcl_DeleteHashTable(&iPtr->varSearches);

    ckfree((char *) iPtr);
}


    if (type == TCL_NUMBER_LONG) {
	long l = *((const long *) ptr);

	if (l > (long)0) {
	    goto unChanged;
	} else if (l == (long)0) {
	    const char *string = objv[1]->bytes;

	    if (!string) {
		/*
		 * There is no string representation, so internal one is
		 * correct.
		 */

		goto unChanged;
	    }
	    while (isspace(UCHAR(*string))) {
	    	string++;
	    }
	    if (*string != '-') {
		goto unChanged;
	    }
	} else if (l == LONG_MIN) {
	    TclBNInitBignumFromLong(&big, l);
	    goto tooLarge;

    int found,			/* Actual parameter count. */
    Tcl_Obj *const *objv)	/* Actual parameter vector. */
{
    const char *name = Tcl_GetString(objv[0]);
    const char *tail = name + strlen(name);

    while (tail > name+1) {
	tail--;
	if (*tail == ':' && tail[-1] == ':') {
	    name = tail+1;
	    break;
	}
    }
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "too %s arguments for math function \"%s\"",

/*
 * tclBinary.c --
 *
 *	This file contains the implementation of the "binary" Tcl built-in
 *	command and the Tcl binary data object.
 *
 * Copyright (c) 1997 by 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: tclBinary.c,v 1.60 2010/03/05 14:34:03 dkf Exp $
 */

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

#include <math.h>

	    offset += (count + 7) / 8;
	    break;
	}
	case 'h':
	case 'H': {
	    char *dest;
	    unsigned char *src;

	    static const char hexdigit[] = "0123456789abcdef";

	    if (arg >= objc) {
		DeleteScanNumberCache(numberCachePtr);
		goto badIndex;
	    }
	    if (count == BINARY_ALL) {

		}
		if (c > 16) {
		    c += ('A' - 'a');
		}
		value |= (c & 0xf);
	    } else {
		value <<= 4;
		cut++;
	    }
	}
	*cursor++ = UCHAR(value);
	value = 0;
    }
    if (cut > size) {
	cut = size;
    }
    Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;

  badChar:
    TclDecrRefCount(resultObj);
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(

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

#define OUTPUT(c) \
    do {						\
	*cursor++ = (c);				\
	outindex++;					\
	if (maxlen > 0 && cursor != limit) {		\
	    if (outindex == maxlen) {			\
		memcpy(cursor, wrapchar, wrapcharlen);	\
		cursor += wrapcharlen;			\
		outindex = 0;				\
	    }						\
	}						\

		    if (strict || !isspace(UCHAR(c))) {
			goto badUu;
		    }
		    i--;
		    continue;
		}
	    } else {
		cut++;
	    }
	}
	if (cut > 3) {
	    cut = 3;
	}
	*cursor++ = (((d[0] - 0x20) & 0x3f) << 2)
		| (((d[1] - 0x20) & 0x3f) >> 4);
	*cursor++ = (((d[1] - 0x20) & 0x3f) << 4)
		| (((d[2] - 0x20) & 0x3f) >> 2);
	*cursor++ = (((d[2] - 0x20) & 0x3f) << 6)
		| (((d[3] - 0x20) & 0x3f));
    }
    if (cut > size) {
	cut = size;
    }
    Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;

  badUu:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "invalid uuencode character \"%c\" at position %d",

    TclNewObj(resultObj);
    datastart = data = (unsigned char *)
	    TclGetStringFromObj(objv[objc-1], &count);
    dataend = data + count;
    size = ((count + 3) & ~3) * 3 / 4;
    begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
    while (data < dataend) {

	unsigned long value = 0;

	for (i=0 ; i<4 ; i++) {
	    if (data < dataend) {
		c = *data++;

		if (c >= 'A' && c <= 'Z') {
		    value = (value << 6) | ((c - 'A') & 0x3f);
		} else if (c >= 'a' && c <= 'z') {
		    value = (value << 6) | ((c - 'a' + 26) & 0x3f);
		} else if (c >= '0' && c <= '9') {
		    value = (value << 6) | ((c - '0' + 52) & 0x3f);
		} else if (c == '+') {
		    value = (value << 6) | 0x3e;
		} else if (c == '/') {
		    value = (value << 6) | 0x3f;
		} else if (c == '=') {
		    value <<= 6;
		    if (cut < 2) {
			cut++;
		    }
		} else {
		    if (strict || !isspace(c)) {
			goto bad64;
		    }
		    i--;
		    continue;
		}
	    } else {
		value <<= 6;
		cut++;
	    }
	}
	*cursor++ = UCHAR((value >> 16) & 0xff);
	*cursor++ = UCHAR((value >> 8) & 0xff);
	*cursor++ = UCHAR(value & 0xff);
    }
    if (cut > size) {
	cut = size;
    }
    Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;

  bad64:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "invalid base64 character \"%c\" at position %d",

 * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
 * Copyright (c) 1995 Sun Microsystems, Inc.
 * Copyright (c) 2004 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: tclClock.c,v 1.75 2010/03/05 14:34:03 dkf Exp $
 */

#include "tclInt.h"

/*
 * Windows has mktime. The configurators do not check.
 */

		break;
	    }
	}
	if (!found) {
	    if (nHave == 8) {
		Tcl_Panic("loop in ConvertLocalToUTCUsingTable");
	    }
	    have[nHave++] = fields->tzOffset;

	}
	fields->seconds = fields->localSeconds - fields->tzOffset;
    }
    fields->tzOffset = have[i];
    fields->seconds = fields->localSeconds - fields->tzOffset;
    return TCL_OK;
}

     */

    jsec = fields->localSeconds + JULIAN_SEC_POSIX_EPOCH;
    fields->julianDay = (int) (jsec / SECONDS_PER_DAY);
    secondOfDay = (int)(jsec % SECONDS_PER_DAY);
    if (secondOfDay < 0) {
	secondOfDay += SECONDS_PER_DAY;
	fields->julianDay--;
    }
    GetGregorianEraYearDay(fields, changeover);
    GetMonthDay(fields);

    /*
     * Convert the date/time to a 'struct tm'.
     */

	 */

	day = jday - JDAY_1_JAN_1_CE_GREGORIAN;
	n = day / FOUR_CENTURIES;
	day %= FOUR_CENTURIES;
	if (day < 0) {
	    day += FOUR_CENTURIES;
	    n--;
	}
	year += 400 * n;

	/*
	 * n = number of centuries since the start of (year);
	 * day = remaining days
	 */

     * n = number of 4-year cycles; days = remaining days.
     */

    n = day / FOUR_YEARS;
    day %= FOUR_YEARS;
    if (day < 0) {
	day += FOUR_YEARS;
	n--;
    }
    year += 4 * n;

    /*
     * n = number of years; days = remaining days.
     */

    /*
     * Try an initial conversion in the Gregorian calendar.
     */

    ym1o4 = ym1 / 4;
    if (ym1 % 4 < 0) {
	ym1o4--;
    }
    ym1o100 = ym1 / 100;
    if (ym1 % 100 < 0) {
	ym1o100--;
    }
    ym1o400 = ym1 / 400;
    if (ym1 % 400 < 0) {
	ym1o400--;
    }
    fields->julianDay = JDAY_1_JAN_1_CE_GREGORIAN - 1
	    + fields->dayOfMonth
	    + daysInPriorMonths[IsGregorianLeapYear(fields)][month - 1]
	    + (ONE_YEAR * ym1)
	    + ym1o4
	    - ym1o100

static void
ClockDeleteCmdProc(
    ClientData clientData)	/* Opaque pointer to the client data */
{
    ClockClientData *data = clientData;
    int i;

    data->refCount--;
    if (data->refCount == 0) {
	for (i = 0; i < LIT__END; ++i) {
	    Tcl_DecrRefCount(data->literals[i]);
	}
	ckfree((char *) data->literals);
	ckfree((char *) data);
    }

/*
 * tclCmdAH.c --
 *
 *	This file contains the top-level command routines for most of the Tcl
 *	built-in commands whose names begin with the letters A to H.
 *
 * 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.124 2010/03/05 14:34:03 dkf Exp $
 */

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

/*

	}
	resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
	Tcl_SetObjResult(interp, resObj);
	return TCL_OK;
    }
    case FCMD_LINK: {
	Tcl_Obj *contents;


	if (objc < 3 || objc > 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?-linktype? linkname ?target?");
	    return TCL_ERROR;
	}

	/*

 * 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.180 2010/03/05 14:34:03 dkf Exp $
 */

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

/*
 * During execution of the "lsort" command, structures of the following type

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

	    /* === START SPECIAL CASE ===
	     *
	     * When reviewing code flow in this function, note that from here
	     * to the line a bit below (END SPECIAL CASE) the contents of the
	     * indexc and indexv fields of the sortInfo structure may not be
	     * matched, so jumping to the done2 label to exit is wrong.

	    }

	    /*
	     * Take copy to prevent shimmering problems.
	     */

	    if (TclListObjGetElements(interp, objv[i+1], &sortInfo.indexc,
		    &indexv) != TCL_OK) {
		return TCL_ERROR;
	    }
	    /* === END SPECIAL CASE === */

	    switch (sortInfo.indexc) {
	    case 0:
		sortInfo.indexv = NULL;

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

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
			&sortInfo.indexv[j]) != TCL_OK) {
		    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
			    "\n    (-index option item number %d)", j));
		    sortInfo.resultCode = TCL_ERROR;
		    goto done2;
		}
	    }

    /*
     * Now store the sorted elements in the result list.
     */

    if (sortInfo.resultCode == TCL_OK) {
	List *listRepPtr;
	Tcl_Obj **newArray, *objPtr;


	resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL);
	listRepPtr = resultPtr->internalRep.twoPtrValue.ptr1;
	newArray = &listRepPtr->elements;
	if (group) {
	    for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) {
		idx = PTR2INT(elementPtr->objPtr);

 * 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.204 2010/03/05 14:34:03 dkf Exp $
 */

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

static inline Tcl_Obj *	During(Tcl_Interp *interp, int resultCode,
			    Tcl_Obj *oldOptions, Tcl_Obj *errorInfo);

	if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) {
	    nocase = 1;
	} else if ((length2 > 1)
		&& !strncmp(string2, "-length", (size_t)length2)) {
	    if (i+1 >= objc-2) {
		goto str_cmp_args;
	    }
	    i++;
	    if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
		return TCL_ERROR;
	    }
	} else {
	    Tcl_AppendResult(interp, "bad option \"", string2,
		    "\": must be -nocase or -length", NULL);
	    return TCL_ERROR;

	if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) {
	    nocase = 1;
	} else if ((length2 > 1)
		&& !strncmp(string2, "-length", (size_t)length2)) {
	    if (i+1 >= objc-2) {
		goto str_cmp_args;
	    }
	    i++;
	    if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
		return TCL_ERROR;
	    }
	} else {
	    Tcl_AppendResult(interp, "bad option \"", string2,
		    "\": must be -nocase or -length", NULL);
	    return TCL_ERROR;

    Tcl_NRAddCallback(interp, SwitchPostProc, INT2PTR(splitObjs), ctxPtr,
	    INT2PTR(pc), (ClientData) pattern);
    return TclNREvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j);
}
static int
SwitchPostProc(
    ClientData data[],		/* Data passed from Tcl_NRAddCallback above */
    Tcl_Interp *interp,		/* Tcl interpreter */
    int result)			/* Result to return*/
{
    /* Unpack the preserved data */

    int splitObjs = PTR2INT(data[0]);
    CmdFrame *ctxPtr = data[1];
    int pc = PTR2INT(data[2]);

 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002 ActiveState Corporation.
 * Copyright (c) 2004-2006 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: tclCompCmds.c,v 1.168 2010/03/05 14:34:03 dkf Exp $
 */

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

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

	    /*
	     * Check the last token: if it is just ')', do not count it.
	     * Otherwise, remove the ')' and flag so that it is restored at
	     * the end.
	     */

	    if (varTokenPtr[n].size == 1) {
		n--;
	    } else {
		varTokenPtr[n].size--;
		removedParen = n;
	    }

	    name = varTokenPtr[1].start;
	    nameChars = p - varTokenPtr[1].start;
	    elName = p + 1;
	    remainingChars = (varTokenPtr[2].start - p) - 1;

	envPtr->line = line;
	envPtr->clNext = clNext;
	CompileTokens(envPtr, varTokenPtr, interp);
    }

    if (removedParen) {
	varTokenPtr[removedParen].size++;
    }
    if (allocedTokens) {
	TclStackFree(interp, elemTokenPtr);
    }
    *localIndexPtr = localIndex;
    *simpleVarNamePtr = simpleVarName;
    *isScalarPtr = (elName == NULL);

 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002 ActiveState Corporation.
 * Copyright (c) 2004-2010 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: tclCompCmdsSZ.c,v 1.2 2010/03/05 14:34:03 dkf Exp $
 */

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

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

	    /*
	     * Check the last token: if it is just ')', do not count it.
	     * Otherwise, remove the ')' and flag so that it is restored at
	     * the end.
	     */

	    if (varTokenPtr[n].size == 1) {
		n--;
	    } else {
		varTokenPtr[n].size--;
		removedParen = n;
	    }

	    name = varTokenPtr[1].start;
	    nameChars = p - varTokenPtr[1].start;
	    elName = p + 1;
	    remainingChars = (varTokenPtr[2].start - p) - 1;

	envPtr->line = line;
	envPtr->clNext = clNext;
	CompileTokens(envPtr, varTokenPtr, interp);
    }

    if (removedParen) {
	varTokenPtr[removedParen].size++;
    }
    if (allocedTokens) {
	TclStackFree(interp, elemTokenPtr);
    }
    *localIndexPtr = localIndex;
    *simpleVarNamePtr = simpleVarName;
    *isScalarPtr = (elName == NULL);

/*
 * tclCompExpr.c --
 *
 *	This file contains the code to parse and compile Tcl expressions and
 *	implementations of the Tcl commands corresponding to expression
 *	operators, such as the command ::tcl::mathop::+ .
 *
 * Contributions from Don Porter, NIST, 2006-2007. (not subject to US copyright)
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompExpr.c,v 1.104 2010/03/05 14:34:04 dkf Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"		/* CompileEnv */

/*
 * Expression parsing takes place in the routine ParseExpr(). It takes a

	    /* No tokens and no characters for the OT_EMPTY leaf. */
	    break;

	case OT_LITERAL:

	    /* Skip any white space that comes before the literal */
	    scanned = TclParseAllWhiteSpace(start, numBytes);
	    start += scanned;
	    numBytes -= scanned;

	    /*
	     * Reparse the literal to get pointers into source string.
	     */

	    scanned = ParseLexeme(start, numBytes, &lexeme, NULL);

	    TclGrowParseTokenArray(parsePtr, 2);
	    subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
	    subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
	    subExprTokenPtr->start = start;
	    subExprTokenPtr->size = scanned;
	    subExprTokenPtr->numComponents = 1;
	    subExprTokenPtr[1].type = TCL_TOKEN_TEXT;
	    subExprTokenPtr[1].start = start;
	    subExprTokenPtr[1].size = scanned;
	    subExprTokenPtr[1].numComponents = 0;

	    parsePtr->numTokens += 2;
	    start += scanned;
	    numBytes -= scanned;
	    break;

	case OT_TOKENS: {
	    /*
	     * tokenPtr points to a token sequence that came from parsing a
	     * Tcl word. A Tcl word is made up of a sequence of one or more

		subExprTokenPtr++;
		memcpy(subExprTokenPtr, tokenPtr,
			(size_t) toCopy * sizeof(Tcl_Token));
		parsePtr->numTokens += toCopy + 1;
	    }

	    scanned = tokenPtr->start + tokenPtr->size - start;
	    start += scanned;
	    numBytes -= scanned;
	    tokenPtr += toCopy;
	    break;
	}

	default:

	    /* Advance to the child node, which is an operator. */
	    nodePtr = nodes + next;

	    /*
	     * Skip any white space that comes before the subexpression.
	     */

	    scanned = TclParseAllWhiteSpace(start, numBytes);
	    start += scanned;
	    numBytes -= scanned;

	    /*
	     * Generate tokens for the operator / subexpression...
	     */

	    switch (nodePtr->lexeme) {

	    break;

	case MARK_RIGHT:
	    next = nodePtr->right;

	    /* Skip any white space that comes before the operator */
	    scanned = TclParseAllWhiteSpace(start, numBytes);
	    start += scanned;
	    numBytes -= scanned;

	    /*
	     * Here we scan from the string the operator corresponding to
	     * nodePtr->lexeme.
	     */

		subExprTokenPtr = parsePtr->tokenPtr + subExprTokenIdx;
		subExprTokenPtr[1].start = start;
		subExprTokenPtr[1].size = scanned;
		break;
	    }

	    start += scanned;
	    numBytes -= scanned;
	    break;

	case MARK_PARENT:
	    switch (nodePtr->lexeme) {
	    case START:

		/* When we get back to the START node, we're done. */
		return;

	    case COMMA:
	    case COLON:

		/* No tokens for these lexemes -> nothing to do. */
		break;

	    case OPEN_PAREN:

		/* Skip past matching close paren. */
		scanned = TclParseAllWhiteSpace(start, numBytes);
		start += scanned;
		numBytes -= scanned;
		scanned = ParseLexeme(start, numBytes, &lexeme, NULL);
		start += scanned;
		numBytes -= scanned;
		break;

	    default: {

		/*
		 * Before we leave this node/operator/subexpression for the

/*
 * tclCompile.c --
 *
 *	This file contains procedures that compile Tcl commands or parts of
 *	commands (like quoted strings or nested sub-commands) into a sequence
 *	of instructions ("bytecodes").
 *
 * Copyright (c) 1996-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: tclCompile.c,v 1.184 2010/03/05 14:34:04 dkf Exp $
 */

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

/*
 * Table of all AuxData types.

    if (iPtr) {
	Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
		(char *) codePtr);

	if (hePtr) {
	    ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);


	    if (eclPtr->type == TCL_LOCATION_SOURCE) {
		Tcl_DecrRefCount(eclPtr->path);
	    }
	    for (i=0 ; i<eclPtr->nuloc ; i++) {
		ckfree((char *) eclPtr->loc[i].line);
	    }

/*
 * tclDictObj.c --
 *
 *	This file contains functions that implement the Tcl dict object 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.82 2010/03/05 14:34:04 dkf Exp $
 */

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

/*
 * Forward declaration.

static void
FreeDictInternalRep(
    Tcl_Obj *dictPtr)
{
    Dict *dict = dictPtr->internalRep.otherValuePtr;

    dict->refcount--;
    if (dict->refcount <= 0) {
	DeleteDict(dict);
    }

    dictPtr->internalRep.otherValuePtr = NULL;	/* Belt and braces! */
    dictPtr->typePtr = NULL;
}

/*
 * tclEnsemble.c --
 *
 *	Contains support for ensembles (see TIP#112), which provide simple
 *	mechanism for creating composite commands on top of namespaces.
 *
 * Copyright (c) 2005-2010 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: tclEnsemble.c,v 1.5 2010/03/05 14:34:04 dkf Exp $
 */

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

/*
 * Declarations for functions local to this file:

			Tcl_DecrRefCount(mapObj);
		    }
		    return TCL_ERROR;
		}
		paramObj = (len > 0 ? objv[1] : NULL);
		continue;
	    case CRT_MAP: {
		Tcl_Obj *patchedDict = NULL, *subcmdWordsObj;

		/*
		 * Verify that the map is sensible.
		 */

		if (Tcl_DictObjFirst(interp, objv[1], &search,
			&subcmdWordsObj, &listObj, &done) != TCL_OK) {
		    if (allocatedMapFlag) {
			Tcl_DecrRefCount(mapObj);
		    }
		    return TCL_ERROR;
		}
		if (done) {
		    mapObj = NULL;

			    Tcl_AppendStringsToObj(newCmd, "::", NULL);
			}
			Tcl_AppendObjToObj(newCmd, listv[0]);
			Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
			if (patchedDict == NULL) {
			    patchedDict = Tcl_DuplicateObj(objv[1]);
			}
			Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
				newList);
		    }
		    Tcl_DictObjNext(&search, &subcmdWordsObj,&listObj, &done);
		} while (!done);

		if (allocatedMapFlag) {
		    Tcl_DecrRefCount(mapObj);
		}
		mapObj = (patchedDict ? patchedDict : objv[1]);
		if (patchedDict) {

		case CONF_PARAM:
		    if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
			goto freeMapAndError;
		    }
		    paramObj = (len > 0 ? objv[1] : NULL);
		    continue;
		case CONF_MAP: {
		    Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, **listv;
		    const char *cmd;

		    /*
		     * Verify that the map is sensible.
		     */

		    if (Tcl_DictObjFirst(interp, objv[1], &search,
			    &subcmdWordsObj, &listObj, &done) != TCL_OK) {
			goto freeMapAndError;
		    }
		    if (done) {
			mapObj = NULL;
			continue;
		    }
		    do {

				Tcl_AppendStringsToObj(newCmd, "::", NULL);
			    }
			    Tcl_AppendObjToObj(newCmd, listv[0]);
			    Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd);
			    if (patchedDict == NULL) {
				patchedDict = Tcl_DuplicateObj(objv[1]);
			    }
			    Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
				    newList);
			}
			Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj,
				&done);
		    } while (!done);
		    if (allocatedMapFlag) {
			Tcl_DecrRefCount(mapObj);
		    }
		    mapObj = (patchedDict ? patchedDict : objv[1]);
		    if (patchedDict) {
			allocatedMapFlag = 1;

	if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) {
	    return TCL_ERROR;
	}

	for (Tcl_DictObjFirst(NULL, mapDict, &search, NULL, &valuePtr, &done);
		!done; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) {
	    Tcl_Obj *cmdObjPtr;
	    const char *bytes;

	    if (Tcl_ListObjIndex(interp, valuePtr, 0, &cmdObjPtr) != TCL_OK) {
		Tcl_DictObjDone(&search);
		return TCL_ERROR;
	    }
	    bytes = TclGetString(cmdObjPtr);
	    if (bytes[0] != ':' || bytes[1] != ':') {
		Tcl_AppendResult(interp,
			"ensemble target is not a fully-qualified command",
			NULL);
		Tcl_DictObjDone(&search);
		return TCL_ERROR;
	    }

    Tcl_HashEntry *hPtr;

    if (hash->numEntries != 0) {
	/*
	 * Remove pre-existing table.
	 */



	ckfree((char *) ensemblePtr->subcommandArrayPtr);
	hPtr = Tcl_FirstHashEntry(hash, &search);
	while (hPtr != NULL) {
	    Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr);

	    Tcl_DecrRefCount(prefixObj);
	    hPtr = Tcl_NextHashEntry(&search);

 *
 * Copyright (c) 1991-1994 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: tclEnv.c,v 1.42 2010/03/05 14:34:04 dkf Exp $
 */

#include "tclInt.h"

TCL_DECLARE_MUTEX(envMutex)	/* To serialize access to environ. */

static struct {

    for (value=name ; *value!='=' && *value!='\0' ; ++value) {
	/* Empty body */
    }
    if (*value == '\0') {
	/* Can't happen. */
	return;
    }
    *(value++) = '\0';

    if (*value == '\0') {
	value = NULL;
    }

    /*
     * Set the cygwin environment variable.
     */

/*
 * tclFileName.c --
 *
 *	This file contains routines for converting file names betwen native
 *	and network form.
 *
 * Copyright (c) 1995-1998 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: tclFileName.c,v 1.102 2010/03/05 14:34:04 dkf Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"
#include "tclFileSystem.h" /* For TclGetPathType() */

/*

	    /*
	     * Check for QNX //<node id> prefix
	     */
	    if (*path && (pathLen > 3) && (path[0] == '/')
		    && (path[1] == '/') && isdigit(UCHAR(path[2]))) {
		path += 3;
		while (isdigit(UCHAR(*path))) {
		    path++;
		}
	    }
#endif
	    if (path[0] == '/') {
		if (driveNameLengthPtr != NULL) {
		    /*
		     * We need this addition in case the QNX code was used.

     * Deal with the root directory as a special case.
     */

#ifdef __QNX__
    /*
     * Check for QNX //<node id> prefix
     */

    if ((path[0] == '/') && (path[1] == '/')
	    && isdigit(UCHAR(path[2]))) { /* INTL: digit */
	path += 3;
	while (isdigit(UCHAR(*path))) { /* INTL: digit */
	    path++;
	}
    }
#endif

    if (path[0] == '/') {
	Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj("/",1));
	p = path+1;

		    return TCL_ERROR;
		}
		pathPrefix = Tcl_NewStringObj(Tcl_GetString(cwd), 3);
		Tcl_DecrRefCount(cwd);
		if (tail[0] == '/') {
		    tail++;
		} else {
		    tail += 2;
		}
		Tcl_IncrRefCount(pathPrefix);
		break;
	    }
	    case TCL_PATH_ABSOLUTE:
		/*
		 * Absolute, possibly network path //Machine/Share. Use that

 *	See TIP #230 for the specification of this functionality.
 *
 * Copyright (c) 2007-2008 ActiveState.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIORTrans.c,v 1.13 2010/03/05 14:34:04 dkf Exp $
 */

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

#ifndef EINVAL

ReflectInput(
    ClientData clientData,
    char *buf,
    int toRead,
    int *errorCodePtr)
{
    ReflectedTransform *rtPtr = clientData;
    int gotBytes, copied, readBytes;

    /*
     * The following check can be done before thread redirection, because we
     * are reading from an item which is readonly, i.e. will never change
     * during the lifetime of the channel.
     */

	    } /* else: 'maxRead < 0' == Accept the current value of toRead */
	}

	if (toRead <= 0) {
	    return gotBytes;
	}

	readBytes = Tcl_ReadRaw(rtPtr->parent, buf, toRead);
	if (readBytes < 0) {
	    /*
	     * Report errors to caller. The state of the seek system is
	     * unchanged!
	     */

	    if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) {
		/*
		 * EAGAIN is a special situation. If we had some data before
		 * we report that instead of the request to re-try.
		 */

		return gotBytes;
	    }

	    *errorCodePtr = Tcl_GetErrno();
	    return -1;
	}

	if (readBytes == 0) {
	    /*
	     * Check wether we hit on EOF in 'parent' or not. If not
	     * differentiate between blocking and non-blocking modes. In
	     * non-blocking mode we ran temporarily out of data. Signal this
	     * to the caller via EWOULDBLOCK and error return (-1). In the
	     * other cases we simply return what we got and let the caller
	     * wait for more. On the other hand, if we got an EOF we have to

		/*
		 * Reset eof, force caller to drain result buffer.
		 */

		((Channel *) rtPtr->parent)->state->flags &= ~CHANNEL_EOF;
		continue; /* at: while (toRead > 0) */
	    }
	} /* readBytes == 0 */

	/*
	 * Transform the read chunk, which was not empty. Anything we got back
	 * is a transformation result is put into our buffers, and the next
	 * iteration will put it into the result.
	 */

	if (!TransformRead(rtPtr, errorCodePtr, UCHARP(buf), readBytes)) {
	    return -1;
	}
    } /* while toRead > 0 */

    return gotBytes;
}


    }

    case ForwardedClear: {
	(void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL);
	break;
    }

    case ForwardedLimit:


	if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) {
	    ForwardSetObjError(paramPtr, resObj);
	    paramPtr->limit.max = -1;
	} else if (Tcl_GetIntFromObj(interp, resObj,
		&paramPtr->limit.max) != TCL_OK) {
	    ForwardSetObjError(paramPtr, MarshallError(interp));
	    paramPtr->limit.max = -1;
	}

	Tcl_DecrRefCount(resObj);
	break;


    default:
	/*
	 * Bad operation code.
	 */
	Tcl_Panic("Bad operation code in ForwardProc");
	break;

 * 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.169 2010/03/05 14:34:04 dkf Exp $
 */

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

	    mode = O_WRONLY|O_CREAT|O_APPEND;
	    *seekFlagPtr = 1;
	    break;
	default:
	    goto error;
	}
	i = 1;
	while (i<3 && modeString[i]) {
	    if (modeString[i] == modeString[i-1]) {
		goto error;
	    }
	    switch (modeString[i++]) {
	    case '+':
		/*

 * Copyright (c) 1990-1994 The Regents of the University of California.
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 2006 Sam Bromley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIndexObj.c,v 1.58 2010/03/05 14:34:04 dkf Exp $
 */

#include "tclInt.h"

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

/*
 * The structure below defines the index Tcl object type by means of functions
 * that can be invoked by generic object code.
 */

static const Tcl_ObjType indexType = {
    "index",			/* name */
    FreeIndex,			/* freeIntRepProc */
    DupIndex,			/* dupIntRepProc */
    UpdateStringOfIndex,	/* updateStringProc */
    SetIndexFromAny		/* setFromAnyProc */
};

/*
 * The definition of the internal representation of the "index" object; The
 * internalRep.otherValuePtr field of an object of "index" type will be a
 * pointer to one of these structures.
 *

}

/*
 *----------------------------------------------------------------------
 *
 * GetIndexFromObjList --
 *
 *	This procedure looks up an object's value in a table of strings and
 *	returns the index of the matching string, if any.
 *
 * Results:
 *	If the value of objPtr is identical to or a unique abbreviation for
 *	one of the entries in tableObjPtr, then the return value is TCL_OK and
 *	the index of the matching entry is stored at *indexPtr. If there isn't
 *	a proper match, then TCL_ERROR is returned and an error message is
 *	left in interp's result (unless interp is NULL). The msg argument is

 *	used in the error message; for example, if msg has the value "option"
 *	then the error message will say something flag 'bad option "foo": must
 *	be ...'
 *
 * Side effects:
 *	Removes any internal representation that the object might have. (TODO:
 *	find a way to cache the lookup.)
 *
 *----------------------------------------------------------------------
 */

int
GetIndexFromObjList(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */

{

    int objc, result, t;
    Tcl_Obj **objv;
    const char **tablePtr;

    /*
     * Use Tcl_GetIndexFromObjStruct to do the work to avoid duplicating most
     * of the code there. This is a bit ineffiecient but simpler.
     */

    result = Tcl_ListObjGetElements(interp, tableObjPtr, &objc, &objv);
    if (result != TCL_OK) {
	return result;
    }

 *
 *	This function looks up an object's value given a starting string and
 *	an offset for the amount of space between strings. This is useful when
 *	the strings are embedded in some other kind of array.
 *
 * Results:
 *	If the value of objPtr is identical to or a unique abbreviation for
 *	one of the entries in tablePtr, then the return value is TCL_OK and
 *	the index of the matching entry is stored at *indexPtr. If there isn't
 *	a proper match, then TCL_ERROR is returned and an error message is
 *	left in interp's result (unless interp is NULL). The msg argument is
 *	used in the error message; for example, if msg has the value "option"
 *	then the error message will say something flag 'bad option "foo": must
 *	be ...'
 *
 * Side effects:
 *	The result of the lookup is cached as the internal rep of objPtr, so
 *	that repeated lookups can be done quickly.
 *
 *----------------------------------------------------------------------
 */

    } else {
	TclFreeIntRep(objPtr);
	indexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
	objPtr->internalRep.otherValuePtr = indexRep;
	objPtr->typePtr = &indexType;
    }
    indexRep->tablePtr = (void *) tablePtr;
    indexRep->offset = offset;
    indexRep->index = index;

    *indexPtr = index;
    return TCL_OK;

  error:
    if (interp != NULL) {
	/*
	 * Produce a fancy error message.
	 */

	int count;

	TclNewObj(resultPtr);
	Tcl_SetObjResult(interp, resultPtr);
	Tcl_AppendStringsToObj(resultPtr,
		(numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "),
		msg, " \"", key, NULL);
	if (STRING_AT(tablePtr, offset, 0) == NULL) {
	    Tcl_AppendStringsToObj(resultPtr, "\": no valid options", NULL);
	} else {
	    Tcl_AppendStringsToObj(resultPtr, "\": must be ",
		    STRING_AT(tablePtr, offset, 0), NULL);
	    for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0;
		    *entryPtr != NULL;
		    entryPtr = NEXT_ENTRY(entryPtr, offset), count++) {
		if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
		    Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""),
			    " or ", *entryPtr, NULL);
		} else {
		    Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL);
		}
	    }
	}
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL);
    }

	    if (objc == 0) {
		goto missingArg;
	    }
	    if (Tcl_GetDoubleFromObj(interp, objv[srcIndex],
		    (double *) infoPtr->dstPtr) == TCL_ERROR) {
		Tcl_AppendResult(interp, "expected floating-point argument ",
			"for \"", infoPtr->keyStr, "\" but got \"",
			Tcl_GetString(objv[srcIndex]), "\"", NULL);
		goto error;
	    }
	    srcIndex++;
	    objc--;
	    break;
	case TCL_ARGV_FUNC: {
	    Tcl_ArgvFuncProc *handlerProc;

    /*
     * If we broke out of the loop because of an OPT_REST argument, copy the
     * remaining arguments down.
     */

  argsDone:
    if (remObjv == NULL) {
	/*
	 * Nothing to do.
	 */

	return TCL_OK;
    }

    if (objc > 0) {
	leftovers = (Tcl_Obj **) ckrealloc((void *) leftovers,
		(nrem+objc+1) * sizeof(Tcl_Obj *));
	while (objc) {
	    leftovers[nrem] = objv[srcIndex];
	    nrem++;
	    srcIndex++;
	    objc--;
	}
    } else if (leftovers != NULL) {
	ckfree((char *) leftovers);
    }

 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
 * Copyright (c) 2006-2008 by Joe Mistachkin.  All rights reserved.
 * Copyright (c) 2008 by Miguel Sofer. 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.464 2010/03/05 14:34:04 dkf Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options.

 * Procedures shared among Tcl modules but not used by the outside world:
 *----------------------------------------------------------------
 */

MODULE_SCOPE int	TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    int flags);
MODULE_SCOPE void	TclPushTailcallPoint(Tcl_Interp *interp);
MODULE_SCOPE void	TclAdvanceContinuations(int *line, int **next,
			    int loc);
MODULE_SCOPE void	TclAdvanceLines(int *line, const char *start,
			    const char *end);
MODULE_SCOPE void	TclArgumentEnter(Tcl_Interp *interp,
			    Tcl_Obj *objv[], int objc, CmdFrame *cf);
MODULE_SCOPE void	TclArgumentRelease(Tcl_Interp *interp,
			    Tcl_Obj *objv[], int objc);
MODULE_SCOPE void	TclArgumentBCEnter(Tcl_Interp *interp,
			    Tcl_Obj *objv[], int objc,
			    void *codePtr, CmdFrame *cfPtr, int pc);
MODULE_SCOPE void	TclArgumentBCRelease(Tcl_Interp *interp,
			    CmdFrame *cfPtr);
MODULE_SCOPE void	TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj,
			    CmdFrame **cfPtrPtr, int *wordPtr);
MODULE_SCOPE int	TclArraySet(Tcl_Interp *interp,
			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj);
MODULE_SCOPE double	TclBignumToDouble(mp_int *bignum);
MODULE_SCOPE int	TclByteArrayMatch(const unsigned char *string,
			    int strLen, const unsigned char *pattern,
			    int ptnLen, int flags);
MODULE_SCOPE double	TclCeil(mp_int *a);
MODULE_SCOPE int	TclCheckBadOctal(Tcl_Interp *interp,
			    const char *value);
MODULE_SCOPE int	TclChanCaughtErrorBypass(Tcl_Interp *interp,
			    Tcl_Channel chan);
MODULE_SCOPE int	TclClearRootEnsemble(ClientData data[],
			    Tcl_Interp *interp, int result);
MODULE_SCOPE void	TclCleanupLiteralTable(Tcl_Interp *interp,
			    LiteralTable *tablePtr);
MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num,
			    int *loc);
MODULE_SCOPE void	TclContinuationsEnterDerived(Tcl_Obj *objPtr,
			    int start, int *clNext);
MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr);
MODULE_SCOPE void	TclContinuationsCopy(Tcl_Obj *objPtr,
			    Tcl_Obj *originObjPtr);
MODULE_SCOPE int	TclDoubleDigits(char *buf, double value, int *signum);
MODULE_SCOPE void	TclDeleteNamespaceVars(Namespace *nsPtr);
/* TIP #280 - Modified token based evulation, with line information. */
MODULE_SCOPE int	TclEvalEx(Tcl_Interp *interp, const char *script,
			    int numBytes, int flags, int line,

			    const EnsembleImplMap map[]);
MODULE_SCOPE int	TclMarkList(Tcl_Interp *interp, const char *list,
			    const char *end, int *argcPtr,
			    const int **argszPtr, const char ***argvPtr);
MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr,
			    int *codePtr, int *levelPtr);
MODULE_SCOPE int	TclNokia770Doubles(void);
MODULE_SCOPE void	TclNsDecrRefCount(Namespace *nsPtr);
MODULE_SCOPE void	TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, const char *operation,
			    const char *reason, int index);
MODULE_SCOPE int	TclObjInvokeNamespace(Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[],
			    Tcl_Namespace *nsPtr, int flags);

#else /* not PURIFY or USE_THREAD_ALLOC */

#ifdef TCL_THREADS
/* declared in tclObj.c */
MODULE_SCOPE Tcl_Mutex	tclObjMutex;
#endif

#  define TclAllocObjStorageEx(interp, objPtr) \
    do {								\
	Tcl_MutexLock(&tclObjMutex);					\
	if (tclFreeObjList == NULL) {					\
	    TclAllocateFreeObjects();					\
	}								\
	(objPtr) = tclFreeObjList;					\
	tclFreeObjList = (Tcl_Obj *)					\
		tclFreeObjList->internalRep.otherValuePtr;		\
	Tcl_MutexUnlock(&tclObjMutex);					\
    } while (0)

#  define TclFreeObjStorageEx(interp, objPtr) \
    do {							       \
	Tcl_MutexLock(&tclObjMutex);				       \
	(objPtr)->internalRep.otherValuePtr = (void *) tclFreeObjList; \
	tclFreeObjList = (objPtr);				       \
	Tcl_MutexUnlock(&tclObjMutex);				       \
    } while (0)
#endif

#else /* TCL_MEM_DEBUG */
MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
			    int line);

# define TclDbNewObj(objPtr, file, line) \
    do { \
	TclIncrObjsAllocated();						\
	(objPtr) = (Tcl_Obj *)						\
		Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line));		\
	TclDbInitNewObj((objPtr), (file), (line));			\
	TCL_DTRACE_OBJ_CREATE(objPtr);					\
    } while (0)

# define TclNewObj(objPtr) \
    TclDbNewObj(objPtr, __FILE__, __LINE__);

# define TclDecrRefCount(objPtr) \
    Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)

 *				int append);
 *----------------------------------------------------------------
 */

#define TCL_MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token))
#define TCL_MIN_TOKEN_GROWTH 50
#define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr)	\
    do {								\
	int needed = (used) + (append);					\
	if (needed > TCL_MAX_TOKENS) {					\
	    Tcl_Panic("max # of tokens for a Tcl parse (%d) exceeded",	\
		    TCL_MAX_TOKENS);					\
	}								\
	if (needed > (available)) {					\
	    int allocated = 2 * needed;					\
	    Tcl_Token *oldPtr = (tokenPtr);				\
	    Tcl_Token *newPtr;						\
	    if (oldPtr == (staticPtr)) {				\
		oldPtr = NULL;						\
	    }								\
	    if (allocated > TCL_MAX_TOKENS) {				\
		allocated = TCL_MAX_TOKENS;				\
	    }								\
	    newPtr = (Tcl_Token *) attemptckrealloc((char *) oldPtr,	\
		    (unsigned int) (allocated * sizeof(Tcl_Token)));	\
	    if (newPtr == NULL) {					\
		allocated = needed + (append) + TCL_MIN_TOKEN_GROWTH;	\
		if (allocated > TCL_MAX_TOKENS) {			\
		    allocated = TCL_MAX_TOKENS;				\
		}							\
		newPtr = (Tcl_Token *) ckrealloc((char *) oldPtr,	\
			(unsigned int) (allocated * sizeof(Tcl_Token))); \
	    }								\
	    (available) = allocated;					\
	    if (oldPtr == NULL) {					\
		memcpy(newPtr, staticPtr,				\
			(size_t) ((used) * sizeof(Tcl_Token)));		\
	    }								\
	    (tokenPtr) = newPtr;					\
	}								\
    } while (0)

#define TclGrowParseTokenArray(parsePtr, append)			\
    TclGrowTokenArray((parsePtr)->tokenPtr, (parsePtr)->numTokens,	\
	    (parsePtr)->tokensAvailable, (append),			\
	    (parsePtr)->staticTokens)

/*

 * counter. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE void	TclInvalidateNsCmdLookup(Namespace *nsPtr);
 *----------------------------------------------------------------
 */

#define TclInvalidateNsCmdLookup(nsPtr) \
    if ((nsPtr)->numExportPatterns) {	\
	(nsPtr)->exportLookupEpoch++;	\
    }

/*
 *----------------------------------------------------------------------
 *
 * Core procedures added to libtommath for bignum manipulation.
 *

 * Macro used by the Tcl core to check whether a pattern has any characters
 * special to [string match]. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE int	TclMatchIsTrivial(const char *pattern);
 *----------------------------------------------------------------
 */

#define TclMatchIsTrivial(pattern) \
    (strpbrk((pattern), "*[?\\") == NULL)

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to write the string rep of a long integer to a
 * character buffer. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE int	TclFormatInt(char *buf, long n);
 *----------------------------------------------------------------
 */

#define TclFormatInt(buf, n) \
    sprintf((buf), "%ld", (long)(n))

/*
 *----------------------------------------------------------------
 * Macros used by the Tcl core to set a Tcl_Obj's numeric representation
 * avoiding the corresponding function calls in time critical parts of the
 * core. They should only be called on unshared objects. The ANSI C
 * "prototypes" for these macros are:
 *
 * MODULE_SCOPE void	TclSetIntObj(Tcl_Obj *objPtr, int intValue);
 * MODULE_SCOPE void	TclSetLongObj(Tcl_Obj *objPtr, long longValue);
 * MODULE_SCOPE void	TclSetBooleanObj(Tcl_Obj *objPtr, long boolValue);
 * MODULE_SCOPE void	TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
 * MODULE_SCOPE void	TclSetDoubleObj(Tcl_Obj *objPtr, double d);
 *----------------------------------------------------------------
 */

#define TclSetIntObj(objPtr, i) \
    do {						\
	TclInvalidateStringRep(objPtr);			\
	TclFreeIntRep(objPtr);				\
	(objPtr)->internalRep.longValue = (long)(i);	\
	(objPtr)->typePtr = &tclIntType;		\
    } while (0)

#define TclSetLongObj(objPtr, l) \
    TclSetIntObj((objPtr), (l))

/*
 * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set
 * programmatically go straight to being "int" Tcl_Obj's, with value 0 or 1.
 * The only "boolean" Tcl_Obj's shall be those holding the cached boolean
 * value of strings like: "yes", "no", "true", "false", "on", "off".
 */

#define TclSetBooleanObj(objPtr, b) \
    TclSetIntObj((objPtr), ((b)? 1 : 0));

#ifndef NO_WIDE_TYPE
#define TclSetWideIntObj(objPtr, w) \
    do {							\
	TclInvalidateStringRep(objPtr);				\
	TclFreeIntRep(objPtr);					\
	(objPtr)->internalRep.wideValue = (Tcl_WideInt)(w);	\
	(objPtr)->typePtr = &tclWideIntType;			\
    } while (0)
#endif

#define TclSetDoubleObj(objPtr, d) \
    do {							\
	TclInvalidateStringRep(objPtr);				\
	TclFreeIntRep(objPtr);					\
	(objPtr)->internalRep.doubleValue = (double)(d);	\
	(objPtr)->typePtr = &tclDoubleType;			\
    } while (0)

/*
 *----------------------------------------------------------------
 * Macros used by the Tcl core to create and initialise objects of standard
 * types, avoiding the corresponding function calls in time critical parts of
 * the core. The ANSI C "prototypes" for these macros are:
 *
 * MODULE_SCOPE void	TclNewIntObj(Tcl_Obj *objPtr, int i);
 * MODULE_SCOPE void	TclNewLongObj(Tcl_Obj *objPtr, long l);
 * MODULE_SCOPE void	TclNewBooleanObj(Tcl_Obj *objPtr, int b);
 * MODULE_SCOPE void	TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w);
 * MODULE_SCOPE void	TclNewDoubleObj(Tcl_Obj *objPtr, double d);
 * MODULE_SCOPE void	TclNewStringObj(Tcl_Obj *objPtr, char *s, int len);
 * MODULE_SCOPE void	TclNewLiteralStringObj(Tcl_Obj*objPtr, char*sLiteral);
 *
 *----------------------------------------------------------------
 */

#ifndef TCL_MEM_DEBUG
#define TclNewIntObj(objPtr, i) \
    do {						\
	TclIncrObjsAllocated();				\
	TclAllocObjStorage(objPtr);			\
	(objPtr)->refCount = 0;				\
	(objPtr)->bytes = NULL;				\
	(objPtr)->internalRep.longValue = (long)(i);	\
	(objPtr)->typePtr = &tclIntType;		\
	TCL_DTRACE_OBJ_CREATE(objPtr);			\
    } while (0)

#define TclNewLongObj(objPtr, l) \
    TclNewIntObj((objPtr), (l))

/*
 * NOTE: There is to be no such thing as a "pure" boolean.
 * See comment above TclSetBooleanObj macro above.
 */
#define TclNewBooleanObj(objPtr, b) \
    TclNewIntObj((objPtr), ((b)? 1 : 0))

#define TclNewDoubleObj(objPtr, d) \
    do {							\
	TclIncrObjsAllocated();					\
	TclAllocObjStorage(objPtr);				\
	(objPtr)->refCount = 0;					\
	(objPtr)->bytes = NULL;					\
	(objPtr)->internalRep.doubleValue = (double)(d);	\
	(objPtr)->typePtr = &tclDoubleType;			\
	TCL_DTRACE_OBJ_CREATE(objPtr);				\
    } while (0)

#define TclNewStringObj(objPtr, s, len) \
    do {							\
	TclIncrObjsAllocated();					\
	TclAllocObjStorage(objPtr);				\
	(objPtr)->refCount = 0;					\
	TclInitStringRep((objPtr), (s), (len));			\
	(objPtr)->typePtr = NULL;				\
	TCL_DTRACE_OBJ_CREATE(objPtr);				\
    } while (0)

#else /* TCL_MEM_DEBUG */
#define TclNewIntObj(objPtr, i) \
    (objPtr) = Tcl_NewIntObj(i)

#define TclNewLongObj(objPtr, l) \
    (objPtr) = Tcl_NewLongObj(l)

 *
 * ONLY USE FOR CONSTANT nBytes.
 *
 * DO NOT LET THEM CROSS THREAD BOUNDARIES
 *----------------------------------------------------------------
 */

#define TclSmallAlloc(nbytes, memPtr) \
    TclSmallAllocEx(NULL, (nbytes), (memPtr))

#define TclSmallFree(memPtr) \
    TclSmallFreeEx(NULL, (memPtr))

#ifndef TCL_MEM_DEBUG
#define TclSmallAllocEx(interp, nbytes, memPtr) \
    do {								\
	Tcl_Obj *objPtr;						\
	TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj));			\
	TclIncrObjsAllocated();						\
	TclAllocObjStorageEx((interp), (objPtr));			\
	memPtr = (ClientData) (objPtr);					\
    } while (0)

#define TclSmallFreeEx(interp, memPtr) \
    do {								\
	TclFreeObjStorageEx((interp), (Tcl_Obj *) (memPtr));		\
	TclIncrObjsFreed();						\
    } while (0)

#else    /* TCL_MEM_DEBUG */
#define TclSmallAllocEx(interp, nbytes, memPtr) \
    do {								\
	Tcl_Obj *objPtr;						\
	TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj));			\
	TclNewObj(objPtr);						\
	memPtr = (ClientData) objPtr;					\
    } while (0)

#define TclSmallFreeEx(interp, memPtr) \
    do {								\
	Tcl_Obj *objPtr = (Tcl_Obj *) memPtr;				\
	objPtr->bytes = NULL;						\
	objPtr->typePtr = NULL;						\
	objPtr->refCount = 1;						\
	TclDecrRefCount(objPtr);					\
    } while (0)
#endif   /* TCL_MEM_DEBUG */

/*
 * Support for Clang Static Analyzer <http://clang-analyzer.llvm.org>
 */

#if defined(PURIFY) && defined(__clang__)

#define TOP_CB(iPtr) (((Interp *)(iPtr))->execEnvPtr->callbackPtr)

/*
 * Inline version of Tcl_NRAddCallback.
 */

#define TclNRAddCallback(interp,postProcPtr,data0,data1,data2,data3) \
    do {								\
	TEOV_callback *callbackPtr;					\
	TCLNR_ALLOC((interp), (callbackPtr));				\
	callbackPtr->procPtr = (postProcPtr);				\
	callbackPtr->data[0] = (ClientData)(data0);			\
	callbackPtr->data[1] = (ClientData)(data1);			\
	callbackPtr->data[2] = (ClientData)(data2);			\
	callbackPtr->data[3] = (ClientData)(data3);			\
	callbackPtr->nextPtr = TOP_CB(interp);				\
	TOP_CB(interp) = callbackPtr;					\
    } while (0)

#define TclNRDeferCallback(interp,postProcPtr,data0,data1,data2,data3) \
    do {								\
	TEOV_callback *callbackPtr;					\
	TCLNR_ALLOC((interp), (callbackPtr));				\
	callbackPtr->procPtr = (postProcPtr);				\
	callbackPtr->data[0] = (ClientData)(data0);			\
	callbackPtr->data[1] = (ClientData)(data1);			\
	callbackPtr->data[2] = (ClientData)(data2);			\
	callbackPtr->data[3] = (ClientData)(data3);			\
	callbackPtr->nextPtr = ((Interp *)interp)->deferredCallbacks;	\
	((Interp *)interp)->deferredCallbacks = callbackPtr;		\
    } while (0)

#define TclNRSpliceCallbacks(interp, topPtr) \
    do {					\
	TEOV_callback *bottomPtr = topPtr;	\
	while (bottomPtr->nextPtr) {		\
	    bottomPtr = bottomPtr->nextPtr;	\
	}					\
	bottomPtr->nextPtr = TOP_CB(interp);	\
	TOP_CB(interp) = topPtr;		\
    } while (0)

#define TclNRSpliceDeferred(interp)					\
    if (((Interp *)interp)->deferredCallbacks) {			\
	TclNRSpliceCallbacks(interp, ((Interp *)interp)->deferredCallbacks); \
	((Interp *)interp)->deferredCallbacks = NULL;			\
    }

/*
 * tclInterp.c --
 *
 *	This file implements the "interp" command which allows creation and
 *	manipulation of Tcl interpreters from within Tcl scripts.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 2004 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: tclInterp.c,v 1.112 2010/03/05 14:34:04 dkf Exp $
 */

#include "tclInt.h"

/*
 * A pointer to a string that holds an initialization script that if non-NULL
 * is evaluated in Tcl_Init() prior to the built-in initialization script

	}
	return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3);
    }
    case OPT_CANCEL: {
	int i, flags;
	Tcl_Interp *slaveInterp;
	Tcl_Obj *resultObjPtr;
	static const char *const cancelOptions[] = {
	    "-unwind",	"--",	NULL
	};
	enum option {
	    OPT_UNWIND,	OPT_LAST
	};

	flags = 0;

	for (i = 2; i < objc; i++) {
	    if (TclGetString(objv[i])[0] != '-') {
		break;
	    }
	    if (Tcl_GetIndexFromObj(interp, objv[i], cancelOptions, "option",
		    0, &index) != TCL_OK) {
		return TCL_ERROR;
	    }

	    switch ((enum option) index) {
	    case OPT_UNWIND:
		/*
		 * The evaluation stack in the target interp is to be unwound.

	    return TCL_ERROR;
	}
    }
    case OPT_CREATE: {
	int i, last, safe;
	Tcl_Obj *slavePtr;
	char buf[16 + TCL_INTEGER_SPACE];
	static const char *const createOptions[] = {
	    "-safe",	"--", NULL
	};
	enum option {
	    OPT_SAFE,	OPT_LAST
	};

	safe = Tcl_IsSafe(interp);

	/*
	 * Weird historical rules: "-safe" is accepted at the end, too.
	 */

	slavePtr = NULL;
	last = 0;
	for (i = 2; i < objc; i++) {
	    if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) {
		if (Tcl_GetIndexFromObj(interp, objv[i], createOptions,
			"option", 0, &index) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (index == OPT_SAFE) {
		    safe = 1;
		    continue;
		}
		i++;

	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));
	return TCL_OK;
    }
    case OPT_INVOKEHID: {
	int i;
	const char *namespaceName;
	Tcl_Interp *slaveInterp;
	static const char *const hiddenOptions[] = {
	    "-global",	"-namespace",	"--", NULL
	};
	enum hiddenOption {
	    OPT_GLOBAL,	OPT_NAMESPACE,	OPT_LAST

	if (objc != 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));
	return TCL_OK;
    case OPT_INVOKEHIDDEN: {
	int i;
	const char *namespaceName;
	static const char *const hiddenOptions[] = {
	    "-global",	"-namespace",	"--", NULL
	};
	enum hiddenOption {
	    OPT_GLOBAL,	OPT_NAMESPACE,	OPT_LAST
	};

/*
 * tclLoad.c --
 *
 *	This file provides the generic portion (those that are the same on all
 *	platforms) of Tcl's dynamic loading facilities.
 *
 * Copyright (c) 1995-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: tclLoad.c,v 1.24 2010/03/05 14:34:04 dkf Exp $
 */

#include "tclInt.h"

/*
 * The following structure describes a package that has been loaded either
 * dynamically (with the "load" command) or statically (as indicated by a call

    if (code == TCL_OK) {
	/*
	 * Update the proper reference count.
	 */

	Tcl_MutexLock(&packageMutex);
	if (Tcl_IsSafe(target)) {
	    pkgPtr->safeInterpRefCount++;
	} else {
	    pkgPtr->interpRefCount++;
	}
	Tcl_MutexUnlock(&packageMutex);

	/*
	 * Refetch ipFirstPtr: loading the package may have introduced
	 * additional static packages at the head of the linked list!
	 */

    if (!keepLibrary) {
	Tcl_MutexLock(&packageMutex);
	trustedRefCount = pkgPtr->interpRefCount;
	safeRefCount = pkgPtr->safeInterpRefCount;
	Tcl_MutexUnlock(&packageMutex);

	if (Tcl_IsSafe(target)) {
	    safeRefCount--;
	} else {
	    trustedRefCount--;
	}

	if (safeRefCount <= 0 && trustedRefCount <= 0) {
	    code = TCL_UNLOAD_DETACH_FROM_PROCESS;
	}
    }
    code = unloadProc(target, code);
    if (code != TCL_OK) {
	Tcl_TransferResult(target, code, interp);
	goto done;
    }

    /*
     * The unload function executed fine. Examine the reference count to see
     * if we unload the DLL.
     */

    Tcl_MutexLock(&packageMutex);
    if (Tcl_IsSafe(target)) {
	pkgPtr->safeInterpRefCount--;

	/*
	 * Do not let counter get negative.
	 */

	if (pkgPtr->safeInterpRefCount < 0) {
	    pkgPtr->safeInterpRefCount = 0;
	}
    } else {
	pkgPtr->interpRefCount--;

	/*
	 * Do not let counter get negative.
	 */

	if (pkgPtr->interpRefCount < 0) {
	    pkgPtr->interpRefCount = 0;

 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   mmclennan@lucent.com
 *
 * 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.204 2010/03/05 14:34:04 dkf Exp $
 */

#include "tclInt.h"
#include "tclCompile.h" /* just for NRCommand */

/*
 * Thread-local storage used to avoid having a global lock on data that is not

	 * Check whether creating the new imported command in the current
	 * namespace would create a cycle of imported command references.
	 */

	cmdPtr = Tcl_GetHashValue(hPtr);
	if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) {
	    Command *overwrite = Tcl_GetHashValue(found);
	    Command *linkCmd = cmdPtr;

	    while (linkCmd->deleteProc == DeleteImportedCmd) {
		dataPtr = linkCmd->objClientData;

		linkCmd = dataPtr->realCmdPtr;
		if (overwrite == linkCmd) {
		    Tcl_AppendResult(interp, "import pattern \"", pattern,
			    "\" would create a loop containing command \"",
			    Tcl_DStringValue(&ds), "\"", NULL);
		    Tcl_DStringFree(&ds);
		    return TCL_ERROR;
		}
	    }

/*
 * tclOO.c --
 *
 *	This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
 *
 * Copyright (c) 2005-2008 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: tclOO.c,v 1.35 2010/03/05 14:34:04 dkf Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"

	}
	Tcl_DeleteHashTable(oPtr->metadataPtr);
	ckfree((char *) oPtr->metadataPtr);
	oPtr->metadataPtr = NULL;
    }

    if (clsPtr != NULL) {
	Class *superPtr;

	if (clsPtr->metadataPtr != NULL) {

	    Tcl_ObjectMetadataType *metadataTypePtr;
	    ClientData value;

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

			break;
		    }
		    if (!brace) {
			const char *s;

			for(s=elemStart;size>0;s++,size--) {
			    if ((*s)=='\\') {
				nakedbs = 1;
				break;
			    }
			}
		    }
		    if (elemStart < listEnd) {
			elemCount++;
		    }

	    }
	    if (--numBytes == 0) {
		break;
	    }
	    if (p[1] != '\n') {
		break;
	    }
	    p += 2;
	    if (--numBytes == 0) {
		*incompletePtr = 1;
		break;
	    }
	    continue;
	}
	break;

    while (numBytes--) {
	unsigned char digit = UCHAR(*p);

	if (!isxdigit(digit)) {
	    break;
	}

	p++;
	result <<= 4;

	if (digit >= 'a') {
	    result |= (10 + digit - 'a');
	} else if (digit >= 'A') {
	    result |= (10 + digit - 'A');
	} else {

/*
 * tclPathObj.c --
 *
 *	This file contains the implementation of Tcl's "path" object type used
 *	to represent and manipulate a general (virtual) filesystem entity in
 *	an efficient manner.
 *
 * Copyright (c) 2003 Vince Darley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPathObj.c,v 1.88 2010/03/05 14:34:04 dkf Exp $
 */

#include "tclInt.h"
#include "tclFileSystem.h"

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

		oldDirSep = dirSep;
		if (dirSep[0] != 0 && dirSep[1] == '.') {
		    goto again;
		}
		continue;
	    }
	    if (dirSep[2] == '.' && IsSeparatorOrNull(dirSep[3])) {
		Tcl_Obj *linkObj;
		int curLen;
		char *linkStr;

		/*
		 * Have '..' so need to skip previous directory.
		 */

		if (retVal == NULL) {
		    const char *path = TclGetString(pathPtr);

		    retVal = Tcl_NewStringObj(path, dirSep - path);
		    Tcl_IncrRefCount(retVal);
		}
		Tcl_GetStringFromObj(retVal, &curLen);
		if (curLen == 0) {
		    Tcl_AppendToObj(retVal, dirSep, 1);
		}
		if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) {
		    linkObj = Tcl_FSLink(retVal, NULL, 0);
		    if (linkObj != NULL) {
			/*
			 * Got a link. Need to check if the link is relative
			 * or absolute, for those platforms where relative
			 * links exist.
			 */

			if (tclPlatform != TCL_PLATFORM_WINDOWS
				&& Tcl_FSGetPathType(linkObj)
					== TCL_PATH_RELATIVE) {
			    /*
			     * We need to follow this link which is relative
			     * to retVal's directory. This means concatenating
			     * the link onto the directory of the path so far.
			     */

			    const char *path =

			    }

			    /*
			     * We want the trailing slash.
			     */

			    Tcl_SetObjLength(retVal, curLen+1);
			    Tcl_AppendObjToObj(retVal, linkObj);
			    TclDecrRefCount(linkObj);
			    linkStr = Tcl_GetStringFromObj(retVal, &curLen);
			} else {
			    /*
			     * Absolute link.
			     */

			    TclDecrRefCount(retVal);
			    retVal = linkObj;
			    linkStr = Tcl_GetStringFromObj(retVal, &curLen);

			    /*
			     * Convert to forward-slashes on windows.
			     */

			    if (tclPlatform == TCL_PLATFORM_WINDOWS) {

	 * we are joining a single relative path onto an object that is
	 * already of path type. The 'TclNewFSPathObj' call below creates an
	 * object which can be normalized more efficiently. Currently we only
	 * use the special case when we have exactly two elements, but we
	 * could expand that in the future.
	 */

	if ((i == (elements-2)) && (i == 0)
		&& (elt->typePtr == &tclFsPathType)
		&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))) {
	    Tcl_Obj *tailObj;


	    Tcl_ListObjIndex(NULL, listObj, i+1, &tailObj);
	    type = TclGetPathType(tailObj, NULL, NULL, NULL);
	    if (type == TCL_PATH_RELATIVE) {
		const char *str;
		int len;

		str = Tcl_GetStringFromObj(tailObj, &len);
		if (len == 0) {
		    /*
		     * This happens if we try to handle the root volume '/'.
		     * There's no need to return a special path object, when
		     * the base itself is just fine!
		     */

			}
			return TclNewFSPathObj(elt, str, len);
		    }
		}

		/*
		 * Otherwise we don't have an easy join, and we must let the
		 * more general code below handle things.
		 */
	    } else if (tclPlatform == TCL_PLATFORM_UNIX) {
		if (res != NULL) {
		    TclDecrRefCount(res);
		}
		return tailObj;
	    } else {
		const char *str = TclGetString(tailObj);

		if (tclPlatform == TCL_PLATFORM_WINDOWS) {
		    if (strchr(str, '\\') == NULL) {
			if (res != NULL) {
			    TclDecrRefCount(res);
			}
			return tailObj;
		    }
		}
	    }
	}
	strElt = Tcl_GetStringFromObj(elt, &strEltLen);
	type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
	if (type != TCL_PATH_RELATIVE) {

	 * It is somewhat unusual to reach this code path without the object
	 * being of tclFsPathType. However, we do our best to deal with the
	 * situation.
	 */

	int len;

	(void) Tcl_GetStringFromObj(pathPtr, &len);
	if (len == 0) {
	    /*
	     * We reject the empty path "".
	     */

	    return -1;
	}

 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2004-2006 Miguel Sofer
 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
 *
 * 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.179 2010/03/05 14:34:04 dkf Exp $
 */

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

/*

    procArgs = TclGetString(objv[2]);

    while (*procArgs == ' ') {
	procArgs++;
    }

    if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
	procArgs += 4;
	while (*procArgs != '\0') {
	    if (*procArgs != ' ') {
		goto done;
	    }
	    procArgs++;
	}

	/*

     * Find the level to use for executing the command.
     */

    result = TclObjGetFrame(interp, objv[1], &framePtr);
    if (result == -1) {
	return TCL_ERROR;
    }
    objc -= result + 1;
    if (objc == 0) {
	goto uplevelSyntax;
    }
    objv += result + 1;

    /*
     * Modify the interpreter state to execute in the given frame.
     */

    savedVarFramePtr = iPtr->varFramePtr;
    iPtr->varFramePtr = framePtr;

	if (i < numArgs) {
	    varPtr->flags = (localPtr->flags & VAR_IS_ARGS);
	    varPtr->value.objPtr = localPtr->defValuePtr;
	    varPtr++;
	    i++;
	}
	namePtr++;
	localPtr = localPtr->nextPtr;
    }
    codePtr->localCachePtr = localCachePtr;
    localCachePtr->refCount = 1;
    localCachePtr->numVars = localCt;
}

/*

/*
 * tclScan.c --
 *
 *	This file contains the implementation of the "scan" command.
 *
 * Copyright (c) 1998 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: tclScan.c,v 1.35 2010/03/05 14:34:04 dkf Exp $
 */

#include "tclInt.h"

/*
 * Flag values used by Tcl_ScanObjCmd.
 */

	    }
	    break;
	badSet:
	    Tcl_SetResult(interp, "unmatched [ in format string",
		    TCL_STATIC);
	    goto error;
	default:



	    buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
	    Tcl_AppendResult(interp, "bad scan conversion character \"", buf,
		    "\"", NULL);
	    goto error;

	}
	if (!(flags & SCAN_SUPPRESS)) {
	    if (objIndex >= nspace) {
		/*
		 * Expand the nassign buffer. If we are using XPG specifiers,
		 * make sure that we grow to a large enough size. xpgSize is
		 * guaranteed to be at least one larger than objIndex.

 *	'double' and 'mp_int' types.
 *
 * Copyright (c) 2005 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: tclStrToD.c,v 1.41 2010/03/05 14:34:04 dkf Exp $
 *
 *----------------------------------------------------------------------
 */

#include <tclInt.h>
#include <stdio.h>
#include <stdlib.h>

/*
 * Static functions defined in this file.
 */

static double		AbsoluteValue(double v, int *signum);
static int		AccumulateDecimalDigit(unsigned, int, 
			    Tcl_WideUInt *, mp_int *, int);
static double		BignumToBiasedFrExp(mp_int *big, int *machexp);
static int		GetIntegerTimesPower(double v, mp_int *r, int *e);
static double		MakeHighPrecisionDouble(int signum,
			    mp_int *significand, int nSigDigs, int exponent);
static double		MakeLowPrecisionDouble(int signum,
			    Tcl_WideUInt significand, int nSigDigs,
			    int exponent);
static double		MakeNaN(int signum, Tcl_WideUInt tag);

	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	    /* FALLTHROUGH */
	case ZERO_O:
	zeroo:
	    if (c == '0') {
		numTrailZeros++;
		state = OCTAL;
		break;
	    } else if (c >= '1' && c <= '7') {
		if (objPtr != NULL) {
		    shift = 3 * (numTrailZeros + 1);
		    significandOverflow = AccumulateDecimalDigit(
			    (unsigned)(c-'0'), numTrailZeros,

	    /*
	     * Scanned a number with a leading zero that contains an 8, 9,
	     * radix point or E. This is an invalid octal number, but might
	     * still be floating point.
	     */

	    if (c == '0') {
		numTrailZeros++;
		state = BAD_OCTAL;
		break;
	    } else if (isdigit(UCHAR(c))) {
		if (objPtr != NULL) {
		    significandOverflow = AccumulateDecimalDigit(
			    (unsigned)(c-'0'), numTrailZeros,
			    &significandWide, &significandBig,

	    acceptPoint = p;
	    acceptLen = len;
	    /* FALLTHROUGH */

	case ZERO_X:
	zerox:
	    if (c == '0') {
		numTrailZeros++;
		state = HEXADECIMAL;
		break;
	    } else if (isdigit(UCHAR(c))) {
		d = (c-'0');
	    } else if (c >= 'A' && c <= 'F') {
		d = (c-'A'+10);
	    } else if (c >= 'a' && c <= 'f') {

	case BINARY:
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	case ZERO_B:
	zerob:
	    if (c == '0') {
		numTrailZeros++;
		state = BINARY;
		break;
	    } else if (c != '1') {
		goto endgame;
	    }
	    if (objPtr != NULL) {
		shift = numTrailZeros + 1;

#ifdef KILL_OCTAL
	decimal:
#endif
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	    if (c == '0') {
		numTrailZeros++;
		state = DECIMAL;
		break;
	    } else if (isdigit(UCHAR(c))) {
		if (objPtr != NULL) {
		    significandOverflow = AccumulateDecimalDigit(
			    (unsigned)(c - '0'), numTrailZeros,
			    &significandWide, &significandBig,

		state = EXPONENT_START;
		break;
	    }
	    /* FALLTHROUGH */

	case LEADING_RADIX_POINT:
	    if (c == '0') {
		numDigitsAfterDp++;
		numTrailZeros++;
		state = FRACTION;
		break;
	    } else if (isdigit(UCHAR(c))) {
		numDigitsAfterDp++;
		if (objPtr != NULL) {
		    significandOverflow = AccumulateDecimalDigit(
			    (unsigned)(c-'0'), numTrailZeros,
			    &significandWide, &significandBig,
			    significandOverflow);
		}
		if (numSigDigs != 0) {

	case sINFINITY:
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	    goto endgame;
	}
	p++;
	len--;
    }

  endgame:
    if (acceptState == INITIAL) {
	/*
	 * No numeric string at all found.
	 */

	len = acceptLen;
	if (!(flags & TCL_PARSE_NO_WHITESPACE)) {
	    /*
	     * Accept trailing whitespace.
	     */

	    while (len != 0 && isspace(UCHAR(*p))) {
		p++;
		len--;
	    }
	}
	if (endPtrPtr == NULL) {
	    if ((len != 0) && ((numBytes > 0) || (*p != '\0'))) {
		status = TCL_ERROR;
	    }
	} else {

     */

    mp_init(&temp);
    mp_add(&r, &mplus, &temp);
    i = mp_cmp_mag(&temp, &s);
    if (i>0 || (highOK && i==0)) {
	mp_mul_d(&s, 10, &s);
	k++;
    } else {
	mp_mul_d(&temp, 10, &temp);
	i = mp_cmp_mag(&temp, &s);
	if (i<0 || (highOK && i==0)) {
	    mp_mul_d(&r, 10, &r);
	    mp_mul_d(&mplus, 10, &mplus);
	    mp_mul_d(&mminus, 10, &mminus);
	    k--;
	}
    }

    /*
     * At this point, k contains the power of ten by which we're scaling the
     * result. r/s is at least 1/10 and strictly less than ten, and v = r/s *
     * 10**k. mplus and mminus give the rounding limits.

	    tc1 = (tc1 < 0);
	}
	mp_add(&r, &mplus, &temp);
	tc2 = mp_cmp_mag(&temp, &s);
	if (highOK) {
	    tc2 = (tc2 >= 0);
	} else {
	    tc2 = (tc2 > 0);
	}
	if (!tc1) {
	    if (!tc2) {
		*buffer++ = '0' + i;
	    } else {
		c = (char) (i + '1');
		break;

     * Determine how many bits of precision a double has, and how many
     * decimal digits that represents.
     */

    if (frexp((double) FLT_RADIX, &log2FLT_RADIX) != 0.5) {
	Tcl_Panic("This code doesn't work on a decimal machine!");
    }
    log2FLT_RADIX--;
    mantBits = DBL_MANT_DIG * log2FLT_RADIX;
    d = 1.0;

    /*
     * Initialize a table of powers of ten that can be exactly represented
     * in a double.
     */

 *
 * 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.134 2010/03/05 14:34:04 dkf Exp $ */

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

/*
 * Set COMPAT to 1 to restore the shimmering patterns to those of Tcl 8.5.
 * This is an escape hatch in case the changes have some unexpected unwelcome

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


    p = format;
    Tcl_IncrRefCount(list);
    while (*p != '\0') {
	int size = 0, seekingConversion = 1, gotPrecision = 0;
	int lastNum = -1;

		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': {
		char *end;

		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;

/*
 * tclThreadAlloc.c --
 *
 *	This is a very fast storage allocator for used with threads (designed
 *	avoid lock contention). The basic strategy is to allocate memory in
 *	fixed size blocks from block caches.
 *
 * The Initial Developer of the Original Code is America Online, Inc.
 * Portions created by AOL are Copyright (C) 1999 America Online, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclThreadAlloc.c,v 1.32 2010/03/05 14:34:04 dkf Exp $
 */

#include "tclInt.h"
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)

/*
 * If range checking is enabled, an additional byte will be allocated to store

     * largest block, otherwise pop the smallest block large enough,
     * allocating more blocks if necessary.
     */

    blockPtr = NULL;
    size = reqSize + sizeof(Block);
#if RCHECK
    size++;
#endif
    if (size > MAXALLOC) {
	bucket = NBUCKETS;
	blockPtr = malloc(size);
	if (blockPtr != NULL) {
	    cachePtr->totalAssigned += reqSize;
	}
    } else {
	bucket = 0;
	while (bucketInfo[bucket].blockSize < size) {
	    bucket++;
	}
	if (cachePtr->buckets[bucket].numFree || GetBlocks(cachePtr, bucket)) {
	    blockPtr = cachePtr->buckets[bucket].firstPtr;
	    cachePtr->buckets[bucket].firstPtr = blockPtr->nextBlock;
	    cachePtr->buckets[bucket].numFree--;
	    cachePtr->buckets[bucket].numRemoves++;
	    cachePtr->buckets[bucket].totalAssigned += reqSize;
	}
    }
    if (blockPtr == NULL) {
	return NULL;
    }
    return Block2Ptr(blockPtr, bucket, reqSize);

	free(blockPtr);
	return;
    }

    cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize;
    blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr;
    cachePtr->buckets[bucket].firstPtr = blockPtr;
    cachePtr->buckets[bucket].numFree++;
    cachePtr->buckets[bucket].numInserts++;

    if (cachePtr != sharedPtr &&
	    cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) {
	PutBlocks(cachePtr, bucket, bucketInfo[bucket].numMove);
    }
}


     * existing pointer. Otherwise, if the block is a system block and the new
     * size would also require a system block, call realloc() directly.
     */

    blockPtr = Ptr2Block(ptr);
    size = reqSize + sizeof(Block);
#if RCHECK
    size++;
#endif
    bucket = blockPtr->sourceBucket;
    if (bucket != NBUCKETS) {
	if (bucket > 0) {
	    min = bucketInfo[bucket-1].blockSize;
	} else {
	    min = 0;

    /*
     * Pop the first object.
     */

    objPtr = cachePtr->firstObjPtr;
    cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
    cachePtr->numObjects--;
    return objPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclThreadFreeObj --

    /*
     * Get this thread's list and push on the free Tcl_Obj.
     */

    objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
    cachePtr->firstObjPtr = objPtr;
    cachePtr->numObjects++;

    /*
     * If the number of free objects has exceeded the high water mark, move
     * some blocks to the shared list.
     */

    if (cachePtr->numObjects > NOBJHIGH) {

LockBucket(
    Cache *cachePtr,
    int bucket)
{
#if 0
    if (Tcl_MutexTryLock(bucketInfo[bucket].lockPtr) != TCL_OK) {
	Tcl_MutexLock(bucketInfo[bucket].lockPtr);
	cachePtr->buckets[bucket].numWaits++;
	sharedPtr->buckets[bucket].numWaits++;
    }
#else
    Tcl_MutexLock(bucketInfo[bucket].lockPtr);
#endif
    cachePtr->buckets[bucket].numLocks++;
    sharedPtr->buckets[bucket].numLocks++;
}

static void
UnlockBucket(
    Cache *cachePtr,
    int bucket)
{

	n = NBUCKETS;
	size = 0; /* lint */
	while (--n > bucket) {
	    if (cachePtr->buckets[n].numFree > 0) {
		size = bucketInfo[n].blockSize;
		blockPtr = cachePtr->buckets[n].firstPtr;
		cachePtr->buckets[n].firstPtr = blockPtr->nextBlock;
		cachePtr->buckets[n].numFree--;
		break;
	    }
	}

	/*
	 * Otherwise, allocate a big new block directly.
	 */

/*
 * tclUtil.c --
 *
 *	This file contains utility functions that are used by many Tcl
 *	commands.
 *
 * 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.114 2010/03/05 14:34:04 dkf Exp $
 */

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

/*

	    while (1) {
		char next = *(l + 1);

		if (next == '\0') {
		    break;
		}
		l++;
		if (isspace(UCHAR(next))) {		/* INTL: ISO space. */
		    continue;
		}
		break;
	    }
	}
    }

	    while (1) {
		char next = *(l + 1);

		if ((l+1) == end) {
		    break;
		}
		l++;
		if (isspace(UCHAR(next))) {		/* INTL: ISO space. */
		    continue;
		}
		break;
	    }
	}
    }

				 * used to be used to control printing. It's
				 * ignored now. */
    double value,		/* Value to print as string. */
    char *dst)			/* Where to store converted value; must have
				 * at least TCL_DOUBLE_SPACE characters. */
{
    char *p, c;
    int exponent;
    int signum;
    char buffer[TCL_DOUBLE_SPACE];
    Tcl_UniChar ch;

    int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int));

    /*

	    return;
	}

	/*
	 * Ordinary (normal and denormal) values.
	 */

	exponent = TclDoubleDigits(buffer, value, &signum);
	if (signum) {
	    *dst++ = '-';
	}
	p = buffer;
	if (exponent < -3 || exponent > 17) {
	    /*
	     * E format for numbers < 1e-3 or >= 1e17.
	     */

	    *dst++ = *p++;
	    c = *p;
	    if (c != '\0') {
		*dst++ = '.';
		while (c != '\0') {
		    *dst++ = c;
		    c = *++p;
		}
	    }
	    sprintf(dst, "e%+d", exponent-1);
	} else {
	    /*
	     * F format for others.
	     */

	    if (exponent <= 0) {
		*dst++ = '0';
	    }
	    c = *p;
	    while (exponent-- > 0) {
		if (c != '\0') {
		    *dst++ = c;
		    c = *++p;
		} else {
		    *dst++ = '0';
		}
	    }
	    *dst++ = '.';
	    if (c == '\0') {
		*dst++ = '0';
	    } else {
		while (++exponent < 0) {
		    *dst++ = '0';
		}
		while (c != '\0') {
		    *dst++ = c;
		    c = *++p;
		}
	    }

    /*
     * Report a parse error.
     */

  parseError:
    if (interp != NULL) {


	/*
	 * The result might not be empty; this resets it which should be both
	 * a cheap operation, and of little problem because this is an
	 * error-generation path anyway.
	 */

	bytes = Tcl_GetString(objPtr);
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "bad index \"", bytes,
		"\": must be integer?[+-]integer? or end?[+-]integer?", NULL);
	if (!strncmp(bytes, "end-", 4)) {
	    bytes += 4;
	}
	TclCheckBadOctal(interp, bytes);

	p++;
    }
    if (*p == '+' || *p == '-') {
	p++;
    }
    if (*p == '0') {
	if ((p[1] == 'o') || p[1] == 'O') {
	    p += 2;
	}
	while (isdigit(UCHAR(*p))) {	/* INTL: digit. */
	    p++;
	}
	while (isspace(UCHAR(*p))) {	/* INTL: ISO space. */
	    p++;
	}

 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
 * Copyright (c) 2007 Miguel Sofer
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclVar.c,v 1.198 2010/03/05 14:34:04 dkf Exp $
 */

#include "tclInt.h"

/*
 * Prototypes for the variable hash key methods.
 */

     *    will use dummyVar so it won't increment varPtr's refCount itself.
     * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to call
     *    unset traces even if other traces are pending.
     */

    if (traced) {
	VarTrace *tracePtr = NULL;
	Tcl_HashEntry *tPtr;

	if (TclIsVarTraced(&dummyVar)) {
	    /*
	     * Transfer any existing traces on var, IF there are unset traces.
	     * Otherwise just delete them.
	     */

	    int isNew;

	    tPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);

	    tracePtr = Tcl_GetHashValue(tPtr);
	    varPtr->flags &= ~VAR_ALL_TRACES;
	    Tcl_DeleteHashEntry(tPtr);
	    if (dummyVar.flags & VAR_TRACED_UNSET) {
		tPtr = Tcl_CreateHashEntry(&iPtr->varTraces,
			(char *) &dummyVar, &isNew);
		Tcl_SetHashValue(tPtr, tracePtr);


	    }
	}

	if ((dummyVar.flags & VAR_TRACED_UNSET)
		|| (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET))) {
	    dummyVar.flags &= ~VAR_TRACE_ACTIVE;
	    TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr,
		    (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
			    | TCL_TRACE_UNSETS,
		    /* leaveErrMsg */ 0, index);

	    /*
	     * The traces that we just called may have triggered a change in
	     * the set of traces. If so, reload the traces to manipulate.
	     */

	    tracePtr = NULL;
	    if (TclIsVarTraced(&dummyVar)) {
		tPtr = Tcl_FindHashEntry(&iPtr->varTraces,
			(char *) &dummyVar);
		tracePtr = Tcl_GetHashValue(tPtr);


		if (tPtr) {
		    Tcl_DeleteHashEntry(tPtr);
		}
	    }
	}

	if (tracePtr) {
	    ActiveVarTrace *activePtr;

	    while (tracePtr) {

 *
 * Parts written by Jean-Claude Wippler, as part of Tclkit, placed in the
 * public domain March 2003.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclZlib.c,v 1.36 2010/03/05 14:34:04 dkf Exp $
 */

#include "tclInt.h"
#ifdef HAVE_ZLIB
#ifdef _WIN32
#   ifndef STATIC_BUILD
/*

    const char *extraInfoStr = NULL;
    static const char *const commands[] = {
	"adler32", "compress", "crc32", "decompress", "deflate", "gunzip",
	"gzip", "inflate", "push", "stream",
	NULL
    };
    enum zlibCommands {
	CMD_ADLER, CMD_COMPRESS, CMD_CRC, CMD_DECOMPRESS, CMD_DEFLATE,
	CMD_GUNZIP, CMD_GZIP, CMD_INFLATE, CMD_PUSH, CMD_STREAM
    };
    static const char *const stream_formats[] = {
	"compress", "decompress", "deflate", "gunzip", "gzip", "inflate",
	NULL
    };
    enum zlibFormats {
	FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP,
	FMT_INFLATE
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "command arg ?...?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], commands, "command", 0,
	    &command) != TCL_OK) {
	return TCL_ERROR;
    }

    switch ((enum zlibCommands) command) {
    case CMD_ADLER:			/* adler32 str ?startvalue?
					 * -> checksum */
	if (objc < 3 || objc > 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
	    return TCL_ERROR;
	}
	if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
		(int *) &start) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (objc < 4) {
	    start = Tcl_ZlibAdler32(0, NULL, 0);
	}
	data = Tcl_GetByteArrayFromObj(objv[2], &dlen);
	Tcl_SetWideIntObj(obj,
		(Tcl_WideInt) Tcl_ZlibAdler32(start, data, dlen));
	return TCL_OK;
    case CMD_CRC:			/* crc32 str ?startvalue?
					 * -> checksum */
	if (objc < 3 || objc > 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
	    return TCL_ERROR;
	}
	if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
		(int *) &start) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (objc < 4) {
	    start = Tcl_ZlibCRC32(0, NULL, 0);
	}
	data = Tcl_GetByteArrayFromObj(objv[2], &dlen);
	Tcl_SetWideIntObj(obj,
		(Tcl_WideInt) Tcl_ZlibCRC32(start, data, dlen));
	return TCL_OK;
    case CMD_DEFLATE:			/* deflate data ?level?
					 * -> rawCompressedData */
	if (objc < 3 || objc > 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "data ?level?");
	    return TCL_ERROR;
	}
	if (objc > 3) {
	    if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (level < 0 || level > 9) {
		goto badLevel;
	    }
	}
	return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_RAW, objv[2], level,
		NULL);
    case CMD_COMPRESS:			/* compress data ?level?
					 * -> zlibCompressedData */
	if (objc < 3 || objc > 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "data ?level?");
	    return TCL_ERROR;
	}
	if (objc > 3) {
	    if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (level < 0 || level > 9) {
		goto badLevel;
	    }
	}
	return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2], level,
		NULL);
    case CMD_GZIP:			/* gzip data ?level?
					 * -> gzippedCompressedData */
	if (objc < 3 || objc > 7 || ((objc & 1) == 0)) {
	    Tcl_WrongNumArgs(interp, 2, objv,
		    "data ?-level level? ?-header header?");
	    return TCL_ERROR;
	}
	headerDictObj = NULL;

		    goto badLevel;
		}
		break;
	    }
	}
	return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2], level,
		headerDictObj);
    case CMD_INFLATE:			/* inflate rawcomprdata ?bufferSize?
					 *	-> decompressedData */
	if (objc < 3 || objc > 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "data ?bufferSize?");
	    return TCL_ERROR;
	}
	if (objc > 3) {
	    if (Tcl_GetIntFromObj(interp, objv[3],
		    (int *) &buffersize) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (buffersize < 16 || buffersize > 65536) {
		goto badBuffer;
	    }
	}
	return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_RAW, objv[2],
		buffersize, NULL);
    case CMD_DECOMPRESS:		/* decompress zlibcomprdata \
					 *    ?bufferSize?
					 *	-> decompressedData */
	if (objc < 3 || objc > 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "data ?bufferSize?");
	    return TCL_ERROR;
	}
	if (objc > 3) {
	    if (Tcl_GetIntFromObj(interp, objv[3],
		    (int *) &buffersize) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (buffersize < 16 || buffersize > 65536) {
		goto badBuffer;
	    }
	}
	return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2],
		buffersize, NULL);
    case CMD_GUNZIP:			/* gunzip gzippeddata ?bufferSize?
					 *	-> decompressedData */
	if (objc < 3 || objc > 5 || ((objc & 1) == 0)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "data ?-headerVar varName?");
	    return TCL_ERROR;
	}
	headerDictObj = headerVarObj = NULL;
	for (i=3 ; i<objc ; i+=2) {

		headerDictObj, TCL_LEAVE_ERR_MSG) == NULL) {
	    if (headerDictObj) {
		TclDecrRefCount(headerDictObj);
	    }
	    return TCL_ERROR;
	}
	return TCL_OK;
    case CMD_STREAM:			/* stream deflate/inflate/...gunzip \
					 *    ?level?
					 *	-> handleCmd */
	if (objc < 3 || objc > 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?");
	    return TCL_ERROR;
	}
	if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0,
		&format) != TCL_OK) {
	    return TCL_ERROR;
	}
	mode = TCL_ZLIB_STREAM_INFLATE;
	switch ((enum zlibFormats) format) {
	case FMT_DEFLATE:
	    mode = TCL_ZLIB_STREAM_DEFLATE;
	case FMT_INFLATE:
	    format = TCL_ZLIB_FORMAT_RAW;
	    break;
	case FMT_COMPRESS:
	    mode = TCL_ZLIB_STREAM_DEFLATE;
	case FMT_DECOMPRESS:
	    format = TCL_ZLIB_FORMAT_ZLIB;
	    break;
	case FMT_GZIP:
	    mode = TCL_ZLIB_STREAM_DEFLATE;
	case FMT_GUNZIP:
	    format = TCL_ZLIB_FORMAT_GZIP;
	    break;
	}
	if (objc == 4) {
	    if (Tcl_GetIntFromObj(interp, objv[3],
		    (int *) &level) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (level < 0 || level > 9) {
		goto badLevel;
	    }
	} else {
	    level = Z_DEFAULT_COMPRESSION;
	}
	if (Tcl_ZlibStreamInit(interp, mode, format, level, NULL,
		&zh) != TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh));
	return TCL_OK;
    case CMD_PUSH: {			/* push mode channel options...
					 *	-> channel */
	Tcl_Channel chan;
	int chanMode;
	static const char *const pushOptions[] = {
	    "-header", "-level", "-limit",
	    NULL
	};
	enum pushOptions {poHeader, poLevel, poLimit};
	Tcl_Obj *headerObj = NULL;
	int limit = 1, dummy;

	if (objc < 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?");
	    return TCL_ERROR;
	}

	if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0,
		&format) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum zlibFormats) format) {
	case FMT_DEFLATE:
	    mode = TCL_ZLIB_STREAM_DEFLATE;
	    format = TCL_ZLIB_FORMAT_RAW;
	    break;
	case FMT_INFLATE:
	    mode = TCL_ZLIB_STREAM_INFLATE;
	    format = TCL_ZLIB_FORMAT_RAW;
	    break;
	case FMT_COMPRESS:
	    mode = TCL_ZLIB_STREAM_DEFLATE;
	    format = TCL_ZLIB_FORMAT_ZLIB;
	    break;
	case FMT_DECOMPRESS:
	    mode = TCL_ZLIB_STREAM_INFLATE;
	    format = TCL_ZLIB_FORMAT_ZLIB;
	    break;
	case FMT_GZIP:
	    mode = TCL_ZLIB_STREAM_DEFLATE;
	    format = TCL_ZLIB_FORMAT_GZIP;
	    break;
	case FMT_GUNZIP:
	    mode = TCL_ZLIB_STREAM_INFLATE;
	    format = TCL_ZLIB_FORMAT_GZIP;
	    break;
	default:
	    Tcl_AppendResult(interp, "IMPOSSIBLE", NULL);
	    return TCL_ERROR;
	}

    char *buf,
    int toRead,
    int *errorCodePtr)
{
    ZlibChannelData *cd = instanceData;
    Tcl_DriverInputProc *inProc =
	    Tcl_ChannelInputProc(Tcl_GetChannelType(cd->parent));
    int e, readBytes, flush = Z_NO_FLUSH;

    if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
	return inProc(Tcl_GetChannelInstanceData(cd->parent), buf, toRead,
		errorCodePtr);
    }

    cd->inStream.next_out = (Bytef *) buf;

	 * loops in DoReadChars() would react to that by stopping, despite the
	 * transform still having data which could be read.
	 *
	 * This is only a hack because other transforms may not be able to
	 * work around the general problem in this way.
	 */

	readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, 1);
	if (readBytes < 0) {
	    *errorCodePtr = Tcl_GetErrno();
	    return -1;
	} else if (readBytes == 0) {
	    flush = Z_SYNC_FLUSH;
	}

	cd->inStream.next_in = (Bytef *) cd->inBuffer;
	cd->inStream.avail_in = readBytes;
    }
}

static int
ZlibTransformOutput(
    ClientData instanceData,
    const char *buf,

/*
 * tclMacOSXFCmd.c
 *
 *	This file implements the MacOSX specific portion of file manipulation
 *	subcommands of the "file" command.
 *
 * Copyright (c) 2003-2007 Daniel A. Steffen <das@users.sourceforge.net>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMacOSXFCmd.c,v 1.18 2010/03/05 14:34:04 dkf Exp $
 */

#include "tclInt.h"

#ifdef HAVE_GETATTRLIST
#include <sys/attr.h>
#include <sys/paths.h>

    SetOSTypeFromAny			/* setFromAnyProc */
};

enum {
   kIsInvisible = 0x4000,
};

#define kFinfoIsInvisible	(OSSwapHostToBigConstInt16(kIsInvisible))

typedef	struct finderinfo {
    u_int32_t type;
    u_int32_t creator;
    u_int16_t fdFlags;
    u_int32_t location;
    u_int16_t reserved;

    Tcl_Obj *objPtr,		/* The object from which to get an OSType. */
    OSType *osTypePtr)		/* Place to store resulting OSType. */
{
    int result = TCL_OK;

    if (objPtr->typePtr != &tclOSTypeType) {
	result = tclOSTypeType.setFromAnyProc(interp, objPtr);

    }
    *osTypePtr = (OSType) objPtr->internalRep.longValue;
    return result;
}

/*
 *----------------------------------------------------------------------
 *

    string = Tcl_GetStringFromObj(objPtr, &length);
    Tcl_UtfToExternalDString(encoding, string, length, &ds);

    if (Tcl_DStringLength(&ds) > 4) {
	Tcl_AppendResult(interp, "expected Macintosh OS type but got \"",
		string, "\": ", NULL);
	Tcl_SetErrorCode(interp, "TCL", "VALUE", "MAC_OSTYPE", NULL);
	result = TCL_ERROR;
    } else {
	OSType osType;
	char bytes[4] = {'\0','\0','\0','\0'};

	memcpy(bytes, Tcl_DStringValue(&ds), (size_t)Tcl_DStringLength(&ds));
	osType = (OSType) bytes[0] << 24 |
		 (OSType) bytes[1] << 16 |
		 (OSType) bytes[2] <<  8 |
		 (OSType) bytes[3];
	TclFreeIntRep(objPtr);
	objPtr->internalRep.longValue = (long) osType;
	objPtr->typePtr = &tclOSTypeType;
    }
    Tcl_DStringFree(&ds);
    Tcl_FreeEncoding(encoding);
    return result;

/*
 * tclUnixFCmd.c
 *
 *	This file implements the unix specific portion of file manipulation
 *	subcommands of the "file" command. All filename arguments should
 *	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.75 2010/03/05 14:34:04 dkf 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.
 *

	    return TCL_ERROR;
	}
    }

    switch ((int) (statBufPtr->st_mode & S_IFMT)) {
#ifndef DJGPP
    case S_IFLNK: {
	char linkBuf[MAXPATHLEN];
	int length;

	length = readlink(src, linkBuf, sizeof(linkBuf));
							/* INTL: Native. */
	if (length == -1) {
	    return TCL_ERROR;
	}
	linkBuf[length] = '\0';
	if (symlink(linkBuf, dst) < 0) {		/* INTL: Native. */
	    return TCL_ERROR;
	}
#ifdef MAC_OSX_TCL
	TclMacOSXCopyFileAttributes(src, dst, statBufPtr);
#endif
	break;
    }

    Tcl_Obj *pathPtr,
    int nextCheckpoint)
{
    const char *currentPathEndPosition;
    int pathLen;
    char cur;
    const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);


    Tcl_DString ds;
    const char *nativePath;
#ifndef NO_REALPATH
    char normPath[MAXPATHLEN];
#endif

    /*
     * We add '1' here because if nextCheckpoint is zero we know that '/'
     * exists, and if it isn't zero, it must point at a directory separator
     * which we also know exists.
     */

    while (1) {
	cur = *currentPathEndPosition;
	if ((cur == '/') && (path != currentPathEndPosition)) {
	    /*
	     * Reached directory separator.
	     */



	    int accessOk;

	    nativePath = Tcl_UtfToExternalDString(NULL, path,
		    currentPathEndPosition - path, &ds);
	    accessOk = access(nativePath, F_OK);
	    Tcl_DStringFree(&ds);

	 * normalized pwd, which is not what we want at all!
	 */

	if (nextCheckpoint == 0) {
	    return 0;
	}

	nativePath = Tcl_UtfToExternalDString(NULL, path,nextCheckpoint, &ds);
	if (Realpath(nativePath, normPath) != NULL) {
	    int newNormLen;

	wholeStringOk:
	    newNormLen = strlen(normPath);
	    if ((newNormLen == Tcl_DStringLength(&ds))
		    && (strcmp(normPath, nativePath) == 0)) {

/*
 * tclUnixThrd.c --
 *
 *	This file implements the UNIX-specific thread support.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2008 by George Peter Staplin
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixThrd.c,v 1.62 2010/03/05 14:34:04 dkf Exp $
 */

#include "tclInt.h"

#ifdef TCL_THREADS

#include <pthread.h>

 * These are for the critical sections inside this file.
 */

#define MASTER_LOCK	pthread_mutex_lock(&masterLock)
#define MASTER_UNLOCK	pthread_mutex_unlock(&masterLock)

#endif /* TCL_THREADS */


/*
 *----------------------------------------------------------------------
 *
 * TclpThreadCreate --
 *
 *	This procedure creates a new thread.

	 *
	 * This solution is not optimal, as we should allow the user to
	 * specify a size at runtime, but we don't want to slow this function
	 * down, and that would still leave the main thread at the default.
	 */

	size_t size;

	result = pthread_attr_getstacksize(&attr, &size);
	if (!result && (size < TCL_THREAD_STACK_MIN)) {
	    pthread_attr_setstacksize(&attr, (size_t) TCL_THREAD_STACK_MIN);
	}
#endif /* TCL_THREAD_STACK_MIN */
    }
#endif /* HAVE_PTHREAD_ATTR_SETSTACKSIZE */

    if (! (flags & TCL_THREAD_JOINABLE)) {
	pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED);
    }


    if (pthread_create(&theThread, &attr,
	    (void * (*)(void *))proc, (void *)clientData) &&
	    pthread_create(&theThread, NULL,
		    (void * (*)(void *))proc, (void *)clientData)) {
	result = TCL_ERROR;
    } else {

 */

void
Tcl_MutexLock(
    Tcl_Mutex *mutexPtr)	/* Really (pthread_mutex_t **) */
{
    pthread_mutex_t *pmutexPtr;

    if (*mutexPtr == NULL) {
	MASTER_LOCK;
	if (*mutexPtr == NULL) {
	    /*
	     * Double inside master lock check to avoid a race condition.
	     */

	    pmutexPtr = (pthread_mutex_t *) ckalloc(sizeof(pthread_mutex_t));
	    pthread_mutex_init(pmutexPtr, NULL);
	    *mutexPtr = (Tcl_Mutex)pmutexPtr;
	    TclRememberMutex(mutexPtr);
	}
	MASTER_UNLOCK;
    }
    pmutexPtr = *((pthread_mutex_t **)mutexPtr);

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

void
Tcl_MutexUnlock(
    Tcl_Mutex *mutexPtr)	/* Really (pthread_mutex_t **) */
{
    pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **) mutexPtr;

    pthread_mutex_unlock(pmutexPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeMutex --

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

void
TclpFinalizeMutex(
    Tcl_Mutex *mutexPtr)
{
    pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **) mutexPtr;

    if (pmutexPtr != NULL) {
	pthread_mutex_destroy(pmutexPtr);
	ckfree((char *) pmutexPtr);
	*mutexPtr = NULL;
    }
}


TclpSetAllocCache(
    void *arg)
{
    pthread_setspecific(key, arg);
}
#endif /* USE_THREAD_ALLOC */

void *
TclpThreadCreateKey(void)
{

    pthread_key_t *ptkeyPtr;

    ptkeyPtr = TclpSysAlloc(sizeof *ptkeyPtr, 0);
    if (NULL == ptkeyPtr) {
	Tcl_Panic("unable to allocate thread key!");
    }

    if (pthread_key_create(ptkeyPtr, NULL)) {
	Tcl_Panic("unable to create pthread key!");
    }

    return ptkeyPtr;
}

void
TclpThreadDeleteKey(
    void *keyPtr)
{
    pthread_key_t *ptkeyPtr = keyPtr;

    if (pthread_key_delete(*ptkeyPtr)) {
	Tcl_Panic("unable to delete key!");
    }

    TclpSysFree(keyPtr);
}

void
TclpThreadSetMasterTSD(
    void *tsdKeyPtr,
    void *ptr)
{
    pthread_key_t *ptkeyPtr = tsdKeyPtr;

    if (pthread_setspecific(*ptkeyPtr, ptr)) {
	Tcl_Panic("unable to set master TSD value");
    }
}

void *
TclpThreadGetMasterTSD(
    void *tsdKeyPtr)
{
    pthread_key_t *ptkeyPtr = tsdKeyPtr;

    return pthread_getspecific(*ptkeyPtr);
}

#endif /* TCL_THREADS */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */