Tcl Source Code

2009-08-25  Andreas Kupries  <[email protected]>

	* generic/tclBasic.c (Tcl_CreateInterp, Tcl_EvalTokensStandard,
	Tcl_EvalEx, TclEvalEx, TclAdvanceContinuations, TclNREvalObjEx):
	* generic/tclCmdMZ.c (Tcl_SwitchObjCmd, TclListLines):
	* generic/tclCompCmds.c (*):
	* generic/tclCompile.c (TclSetByteCodeFromAny, TclInitCompileEnv,
	TclFreeCompileEnv, TclCompileScript, TclCompileTokens):
	* generic/tclCompile.h (CompileEnv):
	* generic/tclInt.h (ContLineLoc, Interp):
	* generic/tclObj.c (ThreadSpecificData, ContLineLocFree,
	TclThreadFinalizeObjects, TclInitObjSubsystem,
	TclContinuationsEnter, TclContinuationsEnterDerived,
	TclContinuationsCopy, TclContinuationsGet, TclFreeObj):
	* generic/tclParse.c (TclSubstTokens, Tcl_SubstObj):
	* generic/tclProc.c (TclCreateProc):
	* generic/tclVar.c (TclPtrSetVar):
	* tests/info.test (info-30.0-24):

	Extended the parser, compiler, and execution engine with code and
	attendant data structures tracking the position of continuation
	lines which are not visible in the resulting script Tcl_Obj*'s, to
	properly account for them while counting lines for #280.

2009-08-24  Daniel Steffen  <[email protected]>

	* generic/tclInt.h: Annotate Tcl_Panic as noreturn for clang static
	analyzer in PURIFY builds, replacing preprocessor/assert technique.

	* macosx/tclMacOSXNotify.c: Fix multiple issues with nested event loops
	when CoreFoundation notifier is running in embedded mode. (Fixes

 * Copyright (c) 2007 Daniel A. Steffen <[email protected]>
 * Copyright (c) 2006-2008 by Joe Mistachkin.  All rights reserved.
 * Copyright (c) 2008 Miguel Sofer <[email protected]>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBasic.c,v 1.402 2009/08/25 21:03:25 andreas_kupries Exp $
 */

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

    iPtr->lineBCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
    iPtr->lineLAPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
    iPtr->lineLABCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
    Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
    Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);
    Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS);
    Tcl_InitHashTable(iPtr->lineLABCPtr, TCL_ONE_WORD_KEYS);
    iPtr->scriptCLLocPtr = NULL;

    iPtr->activeVarTracePtr = NULL;

    iPtr->returnOpts = NULL;
    iPtr->errorInfo = NULL;
    TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo");
    Tcl_IncrRefCount(iPtr->eiVar);

				 * execute nested commands, and report
				 * errors. */
    Tcl_Token *tokenPtr,	/* Pointer to first in an array of tokens to
				 * evaluate and concatenate. */
    int count)			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
{
    return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1,
			  NULL, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalTokens --
 *

    int numBytes,		/* Number of bytes in script. If < 0, the
				 * script consists of all bytes up to the
				 * first null character. */
    int flags)			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Only
				 * TCL_EVAL_GLOBAL is currently supported. */
{
    return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script);
}

int
TclEvalEx(
    Tcl_Interp *interp,		/* Interpreter in which to evaluate the
				 * script. Also used for error reporting. */
    const char *script,		/* First character of script to evaluate. */
    int numBytes,		/* Number of bytes in script. If < 0, the
				 * script consists of all bytes up to the
				 * first NUL character. */
    int flags,			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Only
				 * TCL_EVAL_GLOBAL is currently supported. */
    int line,			/* The line the script starts on. */
    int*  clNextOuter,       /* Information about an outer context for */
    CONST char* outerScript) /* continuation line data. This is set only in
			      * EvalTokensStandard(), to properly handle
			      * [...]-nested commands. The 'outerScript'
			      * refers to the most-outer script containing the
			      * embedded command, which is refered to by
			      * 'script'. The 'clNextOuter' refers to the
			      * current entry in the table of continuation
			      * lines in this "master script", and the
			      * character offsets are relative to the
			      * 'outerScript' as well.
			      *
			      * If outerScript == script, then this call is
			      * for the outer-most script/command. See
			      * Tcl_EvalEx() and TclEvalObjEx() for places
			      * generating arguments for which this is true.
			      */
{
    Interp *iPtr = (Interp *) interp;
    const char *p, *next;
    const unsigned int minObjs = 20;
    Tcl_Obj **objv, **objvSpace;
    int *expand, *lines, *lineSpace;
    Tcl_Token *tokenPtr;

    CmdFrame *eeFramePtr = TclStackAlloc(interp, sizeof(CmdFrame));
    Tcl_Obj **stackObjArray =
	    TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *));
    int *expandStack = TclStackAlloc(interp, minObjs * sizeof(int));
    int *linesStack = TclStackAlloc(interp, minObjs * sizeof(int));
				/* TIP #280 Structures for tracking of command
				 * locations. */
    /*
     * Pointer for the tracking of invisible continuation lines. Initialized
     * only if the caller gave us a table of locations to track, via
     * scriptCLLocPtr. It always refers to the table entry holding the
     * location of the next invisible continuation line to look for, while
     * parsing the script.
     */

    int* clNext = NULL;

    if (iPtr->scriptCLLocPtr) {
	if (clNextOuter) {
	    clNext = clNextOuter;
	} else {
	    clNext = &iPtr->scriptCLLocPtr->loc[0];
	}
    }

    if (numBytes < 0) {
	numBytes = strlen(script);
    }
    Tcl_ResetResult(interp);

    savedVarFramePtr = iPtr->varFramePtr;

    expand = expandStack;
    p = script;
    bytesLeft = numBytes;

    /*
     * TIP #280 Initialize tracking. Do not push on the frame stack yet.
     *
     * We may continue counting based on a specific context (CTX), or open a
     * new context, either for a sourced script, or 'eval'. For sourced files
     * we always have a path object, even if nothing was specified in the
     * interp itself. That makes code using it simpler as NULL checks can be
     * left out. Sourced file without path in the 'scriptFile' is possible
     * during Tcl initialization.
     */

    eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1;
    eeFramePtr->numLevels = iPtr->numLevels;
    eeFramePtr->framePtr = iPtr->framePtr;
    eeFramePtr->nextPtr = iPtr->cmdFramePtr;
    eeFramePtr->nline = 0;

	    code = TCL_ERROR;
	    goto error;
	}

	/*
	 * TIP #280 Track lines. The parser may have skipped text till it
	 * found the command we are now at. We have to count the lines in this
	 * block, and do not forget invisible continuation lines.
	 */

	TclAdvanceLines(&line, p, parsePtr->commandStart);
	TclAdvanceContinuations (&line, &clNext,
				 parsePtr->commandStart - outerScript);

	gotParse = 1;
	if (parsePtr->numWords > 0) {
	    /*
	     * TIP #280. Track lines within the words of the current
	     * command. We use a separate pointer into the table of
	     * continuation line locations to not lose our position for the
	     * per-command parsing.
	     */

	    int wordLine = line;
	    const char *wordStart = parsePtr->commandStart;
	    int*        wordCLNext = clNext;

	    /*
	     * Generate an array of objects for the words of the command.
	     */

 	    unsigned int objectsNeeded = 0;
	    unsigned int numWords = parsePtr->numWords;

		 * on a per-word basis, signaling dynamic words as needed.
		 * Make the information available to the recursively called
		 * evaluator as well, including the type of context (source
		 * vs. eval).
		 */

		TclAdvanceLines(&wordLine, wordStart, tokenPtr->start);
		TclAdvanceContinuations (&wordLine, &wordCLNext,
					 tokenPtr->start - outerScript);
		wordStart = tokenPtr->start;

		lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL)
			? wordLine : -1;

		if (eeFramePtr->type == TCL_LOCATION_SOURCE) {
		    iPtr->evalFlags |= TCL_EVAL_FILE;
		}

		code = TclSubstTokens(interp, tokenPtr+1,
			tokenPtr->numComponents, NULL, wordLine,
		        wordCLNext, outerScript);

		iPtr->evalFlags = 0;

		if (code != TCL_OK) {
		    break;
		}
		objv[objectsUsed] = Tcl_GetObjResult(interp);

		    expand[objectsUsed] = 1;

		    objectsNeeded += (numElements ? numElements : 1);
		} else {
		    expand[objectsUsed] = 0;
		    objectsNeeded++;
		}

		if (wordCLNext) {
		    TclContinuationsEnterDerived (objv[objectsUsed],
				  wordStart - outerScript, wordCLNext);
		}
	    } /* for loop */
	    iPtr->cmdFramePtr = eeFramePtr;
	    if (code != TCL_OK) {
		goto error;
	    }
	    if (expandRequested) {
		/*

    for (p = start; p < end; p++) {
	if (*p == '\n') {
	    (*line)++;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclAdvanceContinuations --
 *
 *	This procedure is a helper which counts the number of continuation
 *	lines (CL) in a block of text using a table of CL locations and
 *	advances an external counter, and the pointer into the table.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The specified counter is advanced per the number of continuation lines
 *	found.
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

void
TclAdvanceContinuations (line,clNextPtrPtr,loc)
     int* line;
     int** clNextPtrPtr;
     int loc;
{
    /*
     * Track the invisible continuation lines embedded in a script, if
     * any. Here they are just spaces (already). They were removed by
     * EvalTokensStandard() via Tcl_UtfBackslash().
     *
     * *clNextPtrPtr         <=> We have continuation lines to track.
     * **clNextPtrPtr >= 0   <=> We are not beyond the last possible location.
     * loc >= **clNextPtrPtr <=> We stepped beyond the current cont. line.
     */

    while (*clNextPtrPtr && (**clNextPtrPtr >= 0) && (loc >= **clNextPtrPtr)) {
	/*
	 * We just stepped over an invisible continuation line. Adjust the
	 * line counter and step to the table entry holding the location of
	 * the next continuation line to track.
	 */
	(*line) ++;
	(*clNextPtrPtr) ++;
    }
}

/*
 *----------------------------------------------------------------------
 * Note: The whole data structure access for argument location tracking is
 * hidden behind these three functions. The only parts open are the lineLAPtr
 * field in the Interp structure. The CFWord definition is internal to here.
 * Should make it easier to redo the data structures if we find something more

	 *
	 * See also tclCompile.c, TclInitCompileEnv, for the equivalent code
	 * in the bytecode compiler.
	 */

	const char *script;
	int numSrcBytes;

	/*
	 * Now we check if we have data about invisible continuation lines for
	 * the script, and make it available to the direct script parser and
	 * evaluator we are about to call, if so.
	 *
	 * It may be possible that the script Tcl_Obj* can be free'd while the
	 * evaluator is using it, leading to the release of the associated
	 * ContLineLoc structure as well. To ensure that the latter doesn't
	 * happen we set a lock on it. We release this lock later in this
	 * function, after the evaluator is done.  The relevant "lineCLPtr"
	 * hashtable is managed in the file "tclObj.c".
	 *
	 * Another important action is to save (and later restore) the
	 * continuation line information of the caller, in case we are
	 * executing nested commands in the eval/direct path.
	 */

	ContLineLoc* saveCLLocPtr = iPtr->scriptCLLocPtr;
	ContLineLoc* clLocPtr = TclContinuationsGet (objPtr);

	if (clLocPtr) {
	    iPtr->scriptCLLocPtr = clLocPtr;
	    Tcl_Preserve (iPtr->scriptCLLocPtr);
	} else {
	    iPtr->scriptCLLocPtr = NULL;
	}

	Tcl_IncrRefCount(objPtr);
	if (invoker == NULL) {
	    /*
	     * No context, force opening of our own.
	     */

		 * Absolute context to reuse.
		 */

		iPtr->invokeCmdFramePtr = ctxPtr;
		iPtr->evalFlags |= TCL_EVAL_CTX;

		result = TclEvalEx(interp, script, numSrcBytes, flags,
			ctxPtr->line[word], NULL, script);

		if (pc) {
		    /*
		     * Death of SrcInfo reference.
		     */

		    Tcl_DecrRefCount(ctxPtr->data.eval.path);
		}
	    }
	    TclStackFree(interp, ctxPtr);

	    /*
	     * Now release the lock on the continuation line information, if
	     * any, and restore the caller's settings.
	     */

	    if (iPtr->scriptCLLocPtr) {
		Tcl_Release (iPtr->scriptCLLocPtr);
	    }
	    iPtr->scriptCLLocPtr = saveCLLocPtr;
	}
	TclDecrRefCount(objPtr);
	return result;
    }
}

static int

 * 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.191 2009/08/25 21:03:25 andreas_kupries Exp $
 */

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

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

	}

	if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) {
	    int bline = ctxPtr->line[bidx];

	    ctxPtr->line = (int *) ckalloc(objc * sizeof(int));
	    ctxPtr->nline = objc;
	    TclListLines(blist, bline, objc, ctxPtr->line, objv);
	} else {
	    /*
	     * This is either a dynamic code word, when all elements are
	     * relative to themselves, or something else less expected and
	     * where we have no information. The result is the same in both
	     * cases; tell the code to come that it doesn't know where it is,
	     * which triggers reversion to the old behavior.

    /*
     * TIP #280: Make invoking context available to switch branch.
     */

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

 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclListLines(
    Tcl_Obj* listObj,          /* Pointer to obj holding a string with list
				* structure.  Assumed to be valid. Assumed to
				* contain n elements.
				*/
    int line,			/* Line the list as a whole starts on. */
    int n,			/* #elements in lines */
    int *lines,			/* Array of line numbers, to fill. */
    Tcl_Obj* const* elems)      /* The list elems as Tcl_Obj*, in need of
				 * derived continuation data */
{
    CONST char*  listStr  = Tcl_GetString (listObj);
    CONST char*  listHead = listStr;
    int i, length = strlen(listStr);
    const char *element = NULL, *next = NULL;
    ContLineLoc* clLocPtr = TclContinuationsGet(listObj);
    int* clNext   = (clLocPtr ? &clLocPtr->loc[0] : NULL);

    for (i = 0; i < n; i++) {
	TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL);

	TclAdvanceLines(&line, listStr, element);
				/* Leading whitespace */
	TclAdvanceContinuations (&line, &clNext, element - listHead);
	if (elems && clNext) {
	    TclContinuationsEnterDerived (elems[i],
					  element - listHead,
					  clNext);
	}
	lines[i] = line;
	length -= (next - listStr);
	TclAdvanceLines(&line, element, next);
				/* Element */
	listStr = next;

	if (*element == 0) {

 * 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.153 2009/08/25 21:03:25 andreas_kupries Exp $
 */

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

/*
 * Macro that encapsulates an efficiency trick that avoids a function call for
 * the simplest of compiles. The ANSI C "prototype" for this macro is:
 *
 * static void		CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr,
 *			    Tcl_Interp *interp, int word);
 */

#define CompileWord(envPtr, tokenPtr, interp, word) \
    if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \
	TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \
		(tokenPtr)[1].size), (envPtr)); \
    } else { \
	envPtr->line = mapPtr->loc[eclIndex].line[word]; \
	envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \
	TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
		(envPtr)); \
    }

/*
 * TIP #280: Remember the per-word line information of the current command. An
 * index is used instead of a pointer as recursive compilation may reallocate,
 * i.e. move, the array. This is also the reason to save the nuloc now, it may
 * change during the course of the function.
 *
 * Macro to encapsulate the variable definition and setup.
 */

#define DefineLineInformation \
    ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
    int eclIndex = mapPtr->nuloc - 1

#define SetLineInformation(word) \
    envPtr->line   = mapPtr->loc [eclIndex].line [(word)]; \
    envPtr->clNext = mapPtr->loc [eclIndex].next [(word)]

/*
 * Convenience macro for use when compiling bodies of commands. The ANSI C
 * "prototype" for this macro is:
 *
 * static void		CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr,
 *			    Tcl_Interp *interp);
 */

static void		FreeJumptableInfo(ClientData clientData);
static void		PrintJumptableInfo(ClientData clientData,
			    Tcl_Obj *appendObj, ByteCode *codePtr,
			    unsigned int pcOffset);
static int		PushVarName(Tcl_Interp *interp,
			    Tcl_Token *varTokenPtr, CompileEnv *envPtr,
			    int flags, int *localIndexPtr,
			    int *simpleVarNamePtr, int *isScalarPtr,
			    int line, int* clNext);
static int		CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, const char *identity,
			    int instruction, CompileEnv *envPtr);
static int		CompileComparisonOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, int instruction,
			    CompileEnv *envPtr);
static int		CompileStrictlyBinaryOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, int instruction,
			    CompileEnv *envPtr);
static int		CompileUnaryOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, int instruction,
			    CompileEnv *envPtr);
static void		CompileReturnInternal(CompileEnv *envPtr,
			    unsigned char op, int code, int level,
			    Tcl_Obj *returnOpts);

#define PushVarNameWord(i,v,e,f,l,s,sc,word) \
    PushVarName (i,v,e,f,l,s,sc,                       \
                    mapPtr->loc [eclIndex].line [(word)], \
	            mapPtr->loc [eclIndex].next [(word)])

/*
 * Flags bits used by PushVarName.
 */

#define TCL_NO_LARGE_INDEX 1	/* Do not return localIndex value > 255 */

/*

     * slot (entry in the array of local vars) if we are compiling a procedure
     * body and if the name is simple text that does not include namespace
     * qualifiers.
     */

    varTokenPtr = TokenAfter(parsePtr->tokenPtr);

    PushVarNameWord(interp, varTokenPtr, envPtr, 0,
		&localIndex, &simpleVarName, &isScalar, 1);


    /*
     * We are doing an assignment, otherwise TclCompileSetCmd was called, so
     * push the new value. This will need to be extended to push a value for
     * each argument.
     */

     * Otherwise, compile instructions to substitute its text without
     * catching, a catch instruction that resets the stack to what it was
     * before substituting the body, and then an instruction to eval the body.
     * Care has to be taken to register the correct startOffset for the catch
     * range so that errors in the substitution are not catched [Bug 219184]
     */

    SetLineInformation (1);
    if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	ExceptionRangeStarts(envPtr, range);
	CompileBody(envPtr, cmdTokenPtr, interp);
	ExceptionRangeEnds(envPtr, range);
    } else {
	CompileTokens(envPtr, cmdTokenPtr, interp);
	ExceptionRangeStarts(envPtr, range);

    loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
    ExceptionRangeStarts(envPtr, loopRange);

    /*
     * Compile the loop body itself. It should be stack-neutral.
     */

    SetLineInformation (4);
    CompileBody(envPtr, bodyTokenPtr, interp);
    TclEmitOpcode(   INST_POP,					envPtr);

    /*
     * Both exception target ranges (error and loop) end here.
     */

    bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
    nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);

    /*
     * Inline compile the initial command.
     */

    SetLineInformation (1);
    CompileBody(envPtr, startTokenPtr, interp);
    TclEmitOpcode(INST_POP, envPtr);

    /*
     * Jump to the evaluation of the condition. This code uses the "loop
     * rotation" optimisation (which eliminates one branch from the loop).
     * "for start cond next body" produces then:

    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);

    /*
     * Compile the loop body.
     */

    bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange);
    SetLineInformation (4);
    CompileBody(envPtr, bodyTokenPtr, interp);
    ExceptionRangeEnds(envPtr, bodyRange);
    envPtr->currStackDepth = savedStackDepth + 1;
    TclEmitOpcode(INST_POP, envPtr);

    /*
     * Compile the "next" subcommand.
     */

    envPtr->currStackDepth = savedStackDepth;
    nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange);
    SetLineInformation (3);
    CompileBody(envPtr, nextTokenPtr, interp);
    ExceptionRangeEnds(envPtr, nextRange);
    envPtr->currStackDepth = savedStackDepth + 1;
    TclEmitOpcode(INST_POP, envPtr);
    envPtr->currStackDepth = savedStackDepth;

    /*
     * Compile the test expression then emit the conditional jump that
     * terminates the for.
     */

    testCodeOffset = CurrentOffset(envPtr);

    jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
    if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
	bodyCodeOffset += 3;
	nextCodeOffset += 3;
	testCodeOffset += 3;
    }

    SetLineInformation (2);
    envPtr->currStackDepth = savedStackDepth;
    TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;

    jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
    if (jumpDist > 127) {
	TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);

     */

    loopIndex = 0;
    for (i = 0, tokenPtr = parsePtr->tokenPtr;
	    i < numWords-1;
	    i++, tokenPtr = TokenAfter(tokenPtr)) {
	if ((i%2 == 0) && (i > 0)) {
	    SetLineInformation (i);
	    CompileTokens(envPtr, tokenPtr, interp);
	    tempVar = (firstValueTemp + loopIndex);
	    if (tempVar <= 255) {
		TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);
	    } else {
		TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr);
	    }

    TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
    TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);

    /*
     * Inline compile the loop body.
     */

    SetLineInformation (bodyIndex);
    ExceptionRangeStarts(envPtr, range);
    CompileBody(envPtr, bodyTokenPtr, interp);
    ExceptionRangeEnds(envPtr, range);
    envPtr->currStackDepth = savedStackDepth + 1;
    TclEmitOpcode(INST_POP, envPtr);

    /*

		 */

		realCond = 0;
		if (!boolVal) {
		    compileScripts = 0;
		}
	    } else {
		SetLineInformation (wordIdx);
		Tcl_ResetResult(interp);
		TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
		if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
		    TclExpandJumpFixupArray(&jumpFalseFixupArray);
		}
		jumpIndex = jumpFalseFixupArray.next;
		jumpFalseFixupArray.next++;

	}

	/*
	 * Compile the "then" command body.
	 */

	if (compileScripts) {
	    SetLineInformation (wordIdx);
	    envPtr->currStackDepth = savedStackDepth;
	    CompileBody(envPtr, tokenPtr, interp);
	}

	if (realCond) {
	    /*
	     * Jump to the end of the "if" command. Both jumpFalseFixupArray

	}

	if (compileScripts) {
	    /*
	     * Compile the else command body.
	     */

	    SetLineInformation (wordIdx);
	    CompileBody(envPtr, tokenPtr, interp);
	}

	/*
	 * Make sure there are no words after the else clause.
	 */

    if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
	return TCL_ERROR;
    }

    varTokenPtr = TokenAfter(parsePtr->tokenPtr);

    PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX,
		    &localIndex, &simpleVarName, &isScalar, 1);


    /*
     * If an increment is given, push it, but see first if it's a small
     * integer.
     */

    haveImmValue = 0;

	    if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) {
		haveImmValue = 1;
	    }
	    if (!haveImmValue) {
		PushLiteral(envPtr, word, numBytes);
	    }
	} else {
	    SetLineInformation (2);
	    CompileTokens(envPtr, incrTokenPtr, interp);
	}
    } else {			/* No incr amount given so use 1. */
	haveImmValue = 1;
    }

    /*

     * frame slot (entry in the array of local vars) if we are compiling a
     * procedure body and if the name is simple text that does not include
     * namespace qualifiers.
     */

    varTokenPtr = TokenAfter(parsePtr->tokenPtr);

    PushVarNameWord(interp, varTokenPtr, envPtr, 0,
		    &localIndex, &simpleVarName, &isScalar, 1);


    /*
     * If we are doing an assignment, push the new value. In the no values
     * case, create an empty object.
     */

    if (numWords > 2) {

    for (idx=0 ; idx<numWords-2 ; idx++) {
	tokenPtr = TokenAfter(tokenPtr);

	/*
	 * Generate the next variable name.
	 */

	PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
			&simpleVarName, &isScalar, idx+2);

	/*
	 * Emit instructions to get the idx'th item out of the list value on
	 * the stack and assign it to the variable.
	 */

	if (simpleVarName) {

     * to emit code to compute and push the name at runtime. We use a frame
     * slot (entry in the array of local vars) if we are compiling a procedure
     * body and if the name is simple text that does not include namespace
     * qualifiers.
     */

    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
    PushVarNameWord(interp, varTokenPtr, envPtr, 0,
		    &localIndex, &simpleVarName, &isScalar, 1);


    /*
     * Push the "index" args and the new element value.
     */

    for (i=2 ; i<parsePtr->numWords ; ++i) {
	varTokenPtr = TokenAfter(varTokenPtr);

     * to emit code to compute and push the name at runtime. We use a frame
     * slot (entry in the array of local vars) if we are compiling a procedure
     * body and if the name is simple text that does not include namespace
     * qualifiers.
     */

    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
    PushVarNameWord(interp, varTokenPtr, envPtr, 0,
		    &localIndex, &simpleVarName, &isScalar, 1);


    /*
     * If we are doing an assignment, push the new value.
     */

    if (isAssignment) {
	valueTokenPtr = TokenAfter(varTokenPtr);

		Tcl_IncrRefCount(copy);
		exactMatch = TclMatchIsTrivial(TclGetString(copy));
		TclDecrRefCount(copy);
	    }
	    PushLiteral(envPtr, str, length);
	} else {
	    SetLineInformation (i+1+nocase);
	    CompileTokens(envPtr, tokenPtr, interp);
	}
	tokenPtr = TokenAfter(tokenPtr);
    }

    /*
     * Push the matcher.

	char buf[TCL_INTEGER_SPACE];
	int len = Tcl_NumUtfChars(tokenPtr[1].start, tokenPtr[1].size);

	len = sprintf(buf, "%d", len);
	PushLiteral(envPtr, buf, len);
    } else {
	SetLineInformation (1);
	CompileTokens(envPtr, tokenPtr, interp);
	TclEmitOpcode(INST_STR_LEN, envPtr);
    }
    return TCL_OK;
}

/*

    enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode;
				/* What kind of switch are we doing? */

    Tcl_Token *bodyTokenArray;	/* Array of real pattern list items. */
    Tcl_Token **bodyToken;	/* Array of pointers to pattern list items. */
    int *bodyLines;		/* Array of line numbers for body list
				 * items. */
    int** bodyNext;
    int foundDefault;		/* Flag to indicate whether a "default" clause
				 * is present. */

    JumpFixup *fixupArray;	/* Array of forward-jump fixup records. */
    int *fixupTargetArray;	/* Array of places for fixups to point at. */
    int fixupCount;		/* Number of places to fix up. */
    int contFixIndex;		/* Where the first of the jumps due to a group
				 * of continuation bodies starts, or -1 if
				 * there aren't any. */
    int contFixCount;		/* Number of continuation bodies pointing to
				 * the current (or next) real body. */

    int savedStackDepth = envPtr->currStackDepth;
    int noCase;			/* Has the -nocase flag been given? */
    int foundMode = 0;		/* Have we seen a mode flag yet? */
    int isListedArms = 0;
    int i, valueIndex;
    DefineLineInformation;	/* TIP #280 */
    int* clNext = envPtr->clNext;

    /*
     * Only handle the following versions:
     *   switch         ?--? word {pattern body ...}
     *   switch -exact  ?--? word {pattern body ...}
     *   switch -glob   ?--? word {pattern body ...}
     *   switch -regexp ?--? word {pattern body ...}

	    return TCL_ERROR;
	}

	isListedArms = 1;
	bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords);
	bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords);
	bodyLines = (int *) ckalloc(sizeof(int) * numWords);
	bodyNext = (int **) ckalloc(sizeof(int*) * numWords);

	/*
	 * Locate the start of the arms within the overall word.
	 */

	bline = mapPtr->loc[eclIndex].line[valueIndex+1];
	p = tokenStartPtr = tokenPtr[1].start;

	    if ((isTokenBraced && *(tokenStartPtr++) != '}') ||
		    (tokenStartPtr < tokenPtr[1].start+tokenPtr[1].size
		    && !isspace(UCHAR(*tokenStartPtr)))) {
		ckfree((char *) argv);
		ckfree((char *) bodyToken);
		ckfree((char *) bodyTokenArray);
		ckfree((char *) bodyLines);
		ckfree((char *) bodyNext);
		return TCL_ERROR;
	    }

	    /*
	     * TIP #280: Now determine the line the list element starts on
	     * (there is no need to do it earlier, due to the possibility of
	     * aborting, see above).
	     */

	    TclAdvanceLines(&bline, p, bodyTokenArray[i].start);
	    TclAdvanceContinuations (&bline, &clNext,
				 bodyTokenArray[i].start - envPtr->source);
	    bodyLines[i] = bline;
	    bodyNext[i] = clNext;
	    p = bodyTokenArray[i].start;

	    while (isspace(UCHAR(*tokenStartPtr))) {
		tokenStartPtr++;
		if (tokenStartPtr >= tokenPtr[1].start+tokenPtr[1].size) {
		    break;
		}

	 * to defeat the code above) and we should bail out.
	 */

	if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) {
	    ckfree((char *) bodyToken);
	    ckfree((char *) bodyTokenArray);
	    ckfree((char *) bodyLines);
	    ckfree((char *) bodyNext);
	    return TCL_ERROR;
	}

    } else if (numWords % 2 || numWords == 0) {
	/*
	 * Odd number of words (>1) available, or no words at all available.
	 * Both are error cases, so punt and let the interpreted-version
	 * generate the error message. Note that the second case probably
	 * should get caught earlier, but it's easy to check here again anyway
	 * because it'd cause a nasty crash otherwise.
	 */

	return TCL_ERROR;
    } else {
	/*
	 * Multi-word definition of patterns & actions.
	 */

	bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords);
	bodyLines = (int *) ckalloc(sizeof(int) * numWords);
	bodyNext = (int **) ckalloc(sizeof(int*) * numWords);
	bodyTokenArray = NULL;
	for (i=0 ; i<numWords ; i++) {
	    /*
	     * We only handle the very simplest case. Anything more complex is
	     * a good reason to go to the interpreted case anyway due to
	     * traces, etc.
	     */

	    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD ||
		    tokenPtr->numComponents != 1) {
		ckfree((char *) bodyToken);
		ckfree((char *) bodyLines);
		ckfree((char *) bodyNext);
		return TCL_ERROR;
	    }
	    bodyToken[i] = tokenPtr+1;

	    /*
	     * TIP #280: Copy line information from regular cmd info.
	     */

	    bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i];
	    bodyNext[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i];
	    tokenPtr = TokenAfter(tokenPtr);
	}
    }

    /*
     * Fall back to interpreted if the last body is a continuation (it's
     * illegal, but this makes the error happen at the right time).
     */

    if (bodyToken[numWords-1]->size == 1 &&
	    bodyToken[numWords-1]->start[0] == '-') {
	ckfree((char *) bodyToken);
	ckfree((char *) bodyLines);
	ckfree((char *) bodyNext);
	if (bodyTokenArray != NULL) {
	    ckfree((char *) bodyTokenArray);
	}
	return TCL_ERROR;
    }

    /*
     * Now we commit to generating code; the parsing stage per se is done.
     * First, we push the value we're matching against on the stack.
     */

    SetLineInformation (valueIndex);
    CompileTokens(envPtr, valueTokenPtr, interp);

    /*
     * Check if we can generate a jump table, since if so that's faster than
     * doing an explicit compare with each body. Note that we're definitely
     * over-conservative with determining whether we can do the jump table,
     * but it handles the most common case well enough.

	    mustGenerate = 0;

	    /*
	     * Compile the body of the arm.
	     */

	    envPtr->line = bodyLines[i+1];	/* TIP #280 */
	    envPtr->clNext = bodyNext[i+1];	/* TIP #280 */
	    TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);

	    /*
	     * Compile a jump in to the end of the command if this body is
	     * anything other than a user-supplied default arm (to either skip
	     * over the remaining bodies or the code that generates an empty
	     * result).

	/*
	 * Clean up all our temporary space and return.
	 */

	ckfree((char *) finalFixups);
	ckfree((char *) bodyToken);
	ckfree((char *) bodyLines);
	ckfree((char *) bodyNext);
	if (bodyTokenArray != NULL) {
	    ckfree((char *) bodyTokenArray);
	}
	return TCL_OK;
    }

    /*

	 * because we may have synthesized the tokens in a non-standard
	 * pattern.
	 */

	TclEmitOpcode(INST_POP, envPtr);
	envPtr->currStackDepth = savedStackDepth + 1;
	envPtr->line = bodyLines[i+1];		/* TIP #280 */
	envPtr->clNext = bodyNext[i+1];		/* TIP #280 */
	TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);

	if (!foundDefault) {
	    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
		    fixupArray+fixupCount);
	    fixupCount++;
	    fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr);
	}
    }

    /*
     * Clean up all our temporary space and return.
     */

    ckfree((char *) bodyToken);
    ckfree((char *) bodyLines);
    ckfree((char *) bodyNext);
    if (bodyTokenArray != NULL) {
	ckfree((char *) bodyTokenArray);
    }

    /*
     * Discard the value we are matching against unless we've had a default
     * clause (in which case it will already be gone due to the code at the

	testCodeOffset = CurrentOffset(envPtr);
    }

    /*
     * Compile the loop body.
     */

    SetLineInformation (2);
    bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
    CompileBody(envPtr, bodyTokenPtr, interp);
    ExceptionRangeEnds(envPtr, range);
    envPtr->currStackDepth = savedStackDepth + 1;
    TclEmitOpcode(INST_POP, envPtr);

    /*
     * Compile the test expression then emit the conditional jump that
     * terminates the while. We already know it's a simple word.
     */

    if (loopMayEnd) {
	testCodeOffset = CurrentOffset(envPtr);
	jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
	if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
	    bodyCodeOffset += 3;
	    testCodeOffset += 3;
	}
	envPtr->currStackDepth = savedStackDepth;
	SetLineInformation (1);
	TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
	envPtr->currStackDepth = savedStackDepth + 1;

	jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
	if (jumpDist > 127) {
	    TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
	} else {

    Tcl_Interp *interp,		/* Used for error reporting. */
    Tcl_Token *varTokenPtr,	/* Points to a variable token. */
    CompileEnv *envPtr,		/* Holds resulting instructions. */
    int flags,			/* TCL_NO_LARGE_INDEX. */
    int *localIndexPtr,		/* Must not be NULL. */
    int *simpleVarNamePtr,	/* Must not be NULL. */
    int *isScalarPtr,		/* Must not be NULL. */
    int line,			/* Line the token starts on. */
    int* clNext)                /* Reference to offset of next hidden cont. line */
{
    register const char *p;
    const char *name, *elName;
    register int i, n;
    Tcl_Token *elemTokenPtr = NULL;
    int nameChars, elNameChars, simpleVarName, localIndex;
    int elemTokenCount = 0, allocedTokens = 0, removedParen = 0;

	/*
	 * Compile the element script, if any.
	 */

	if (elName != NULL) {
	    if (elNameChars) {
		envPtr->line = line;
		envPtr->clNext = clNext;
		TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr);
	    } else {
		PushLiteral(envPtr, "", 0);
	    }
	}
    } else {
	/*
	 * The var name isn't simple: compile and push it.
	 */

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

    if (removedParen) {
	++varTokenPtr[removedParen].size;
    }
    if (allocedTokens) {

     * be called at runtime.
     */

    for(; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) {
	localTokenPtr = TokenAfter(otherTokenPtr);

	CompileWord(envPtr, otherTokenPtr, interp, 1);
	PushVarNameWord(interp, localTokenPtr, envPtr, 0,
			&localIndex, &simpleVarName, &isScalar, 1);


	if((localIndex < 0) || !isScalar) {
	    return TCL_ERROR;
	}
	TclEmitInstInt4(INST_UPVAR, localIndex, envPtr);
    }

    localTokenPtr = tokenPtr;
    for(i=4; i<=numWords; i+=2) {
	otherTokenPtr = TokenAfter(localTokenPtr);
	localTokenPtr = TokenAfter(otherTokenPtr);

	CompileWord(envPtr, otherTokenPtr, interp, 1);
	PushVarNameWord(interp, localTokenPtr, envPtr, 0,
			&localIndex, &simpleVarName, &isScalar, 1);


	if((localIndex < 0) || !isScalar) {
	    return TCL_ERROR;
	}
	TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr);
    }

     * to emit code to compute and push the name at runtime. We use a frame
     * slot (entry in the array of local vars) if we are compiling a procedure
     * body and if the name is simple text that does not include namespace
     * qualifiers.
     */

    tokenPtr = TokenAfter(parsePtr->tokenPtr);
    PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
		    &simpleVarName, &isScalar, 1);

    /*
     * Emit instruction to check the variable for existence.
     */

    if (simpleVarName) {
	if (isScalar) {

/*
 * 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.171 2009/08/25 21:03:25 andreas_kupries Exp $
 */

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

/*
 * Table of all AuxData types.

			    const char *stringPtr, int maxChars);
/*
 * TIP #280: Helper for building the per-word line information of all compiled
 * commands.
 */
static void		EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset,
			    Tcl_Token *tokenPtr, const char *cmd, int len,
			    int numWords, int line, int* clNext, int **lines,
			    CompileEnv* envPtr);

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

const Tcl_ObjType tclByteCodeType = {

    CompileEnv compEnv;		/* Compilation environment structure allocated
				 * in frame. */
    register const AuxData *auxDataPtr;
    LiteralEntry *entryPtr;
    register int i;
    int length, result = TCL_OK;
    const char *stringPtr;
    ContLineLoc* clLocPtr;

#ifdef TCL_COMPILE_DEBUG
    if (!traceInitialized) {
	if (Tcl_LinkVar(interp, "tcl_traceCompile",
		(char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
	    Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
	}

     * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and
     * use to initialize the tracking in the compiler. This information was
     * stored by TclCompEvalObj and ProcCompileProc.
     */

    TclInitCompileEnv(interp, &compEnv, stringPtr, length,
	    iPtr->invokeCmdFramePtr, iPtr->invokeWord);
    /*
     * Now we check if we have data about invisible continuation lines for the
     * script, and make it available to the compile environment, if so.
     *
     * It is not clear if the script Tcl_Obj* can be free'd while the compiler
     * is using it, leading to the release of the associated ContLineLoc
     * structure as well. To ensure that the latter doesn't happen we set a
     * lock on it. We release this lock in the function TclFreeCompileEnv (),
     * found in this file. The "lineCLPtr" hashtable is managed in the file
     * "tclObj.c".
     */

    clLocPtr = TclContinuationsGet (objPtr);
    if (clLocPtr) {
	compEnv.clLoc  = clLocPtr;
	compEnv.clNext = &compEnv.clLoc->loc[0];
	Tcl_Preserve (compEnv.clLoc);
    }

    TclCompileScript(interp, stringPtr, length, &compEnv);

    /*
     * Successful compilation. Add a "done" instruction at the end.
     */

    TclEmitOpcode(INST_DONE, &compEnv);

	}

	TclStackFree(interp, ctxPtr);
    }

    envPtr->extCmdMapPtr->start = envPtr->line;

    /*
     * Initialize the data about invisible continuation lines as empty,
     * i.e. not used. The caller (TclSetByteCodeFromAny) will set this up, if
     * such data is available.
     */

    envPtr->clLoc  = NULL;
    envPtr->clNext = NULL;

    envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
    envPtr->auxDataArrayNext = 0;
    envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
    envPtr->mallocedAuxDataArray = 0;
}

/*

    }
    if (envPtr->mallocedAuxDataArray) {
	ckfree((char *) envPtr->auxDataArrayPtr);
    }
    if (envPtr->extCmdMapPtr) {
	ckfree((char *) envPtr->extCmdMapPtr);
    }

    /*
     * If we used data about invisible continuation lines, then now is the
     * time to release on our hold on it. The lock was set in function
     * TclSetByteCodeFromAny(), found in this file.
     */

    if (envPtr->clLoc) {
	Tcl_Release (envPtr->clLoc);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclWordKnownAtCompileTime --
 *

    Tcl_Token *tokenPtr;
    int bytesLeft, isFirstCmd, wordIdx, currCmdIndex;
    int commandLength, objIndex;
    Tcl_DString ds;
    /* TIP #280 */
    ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr;
    int *wlines, wlineat, cmdLine;
    int* clNext;
    Tcl_Parse *parsePtr = (Tcl_Parse *)
	    TclStackAlloc(interp, sizeof(Tcl_Parse));

    Tcl_DStringInit(&ds);

    if (numBytes < 0) {
	numBytes = strlen(script);

     * Each iteration through the following loop compiles the next command
     * from the script.
     */

    p = script;
    bytesLeft = numBytes;
    cmdLine = envPtr->line;
    clNext = envPtr->clNext;
    do {
	if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) {
	    /*
	     * Compile bytecodes to report the parse error at runtime.
	     */

	    Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,

	     * information. The map first contain full per-word line
	     * information for use by the compiler. This is later replaced by
	     * a reduced form which signals non-literal words, stored in
	     * 'wlines'.
	     */

	    TclAdvanceLines(&cmdLine, p, parsePtr->commandStart);
	    TclAdvanceContinuations (&cmdLine, &clNext,
				     parsePtr->commandStart - envPtr->source);
	    EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source,
		    parsePtr->tokenPtr, parsePtr->commandStart,
		    parsePtr->commandSize, parsePtr->numWords, cmdLine,
		    clNext, &wlines, envPtr);
	    wlineat = eclPtr->nuloc - 1;

	    /*
	     * Each iteration of the following loop compiles one word from the
	     * command.
	     */

	    for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr;
		    wordIdx < parsePtr->numWords; wordIdx++,
		    tokenPtr += (tokenPtr->numComponents + 1)) {

		envPtr->line = eclPtr->loc[wlineat].line[wordIdx];
		envPtr->clNext = eclPtr->loc [wlineat].next [wordIdx];
		if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
		    /*
		     * The word is not a simple string of characters.
		     */

		    TclCompileTokens(interp, tokenPtr+1,
			    tokenPtr->numComponents, envPtr);

		     * reason. Register the literal's location for use by
		     * uplevel, etc. commands, should they encounter it
		     * unmodified. We care only if the we are in a context
		     * which already allows absolute counting.
		     */
		    objIndex = TclRegisterNewLiteral(envPtr,
			    tokenPtr[1].start, tokenPtr[1].size);

		    if (envPtr->clNext) {
			TclContinuationsEnterDerived (envPtr->literalArrayPtr[objIndex].objPtr,
						      tokenPtr[1].start - envPtr->source,
						      eclPtr->loc [wlineat].next [wordIdx]);
		    }
		}
		TclEmitPush(objIndex, envPtr);
	    } /* for loop */

	    /*
	     * Emit an invoke instruction for the command. We skip this if a
	     * compile procedure was found for the command.

	    /*
	     * TIP #280: Free full form of per-word line data and insert the
	     * reduced form now
	     */

	    ckfree((char *) eclPtr->loc[wlineat].line);
	    ckfree((char *) eclPtr->loc[wlineat].next);
	    eclPtr->loc[wlineat].line = wlines;
	    eclPtr->loc[wlineat].next = NULL;
	} /* end if parsePtr->numWords > 0 */

	/*
	 * Advance to the next command in the script.
	 */

	next = parsePtr->commandStart + parsePtr->commandSize;
	bytesLeft -= next - p;
	p = next;

	/*
	 * TIP #280: Track lines in the just compiled command.
	 */

	TclAdvanceLines(&cmdLine, parsePtr->commandStart, p);
	TclAdvanceContinuations (&cmdLine, &clNext, p - envPtr->source);
	Tcl_FreeParse(parsePtr);
    } while (bytesLeft > 0);

    /*
     * If the source script yielded no instructions (e.g., if it was empty),
     * push an empty string as the command's result.
     *

    Tcl_DString textBuffer;	/* Holds concatenated chars from adjacent
				 * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
    char buffer[TCL_UTF_MAX];
    const char *name, *p;
    int numObjsToConcat, nameBytes, localVarName, localVar;
    int length, i;
    unsigned char *entryCodeNext = envPtr->codeNext;
#define NUM_STATIC_POS 20
    int isLiteral, maxNumCL, numCL;
    int* clPosition;

    /*
     * For the handling of continuation lines in literals we first check if
     * this is actually a literal. For if not we can forego the additional
     * processing. Otherwise we pre-allocate a small table to store the
     * locations of all continuation lines we find in this literal, if
     * any. The table is extended if needed.
     *
     * Note: Different to the equivalent code in function 'TclSubstTokens()'
     * (see file "tclParse.c") we do not seem to need the 'adjust'
     * variable. We also do not seem to need code which merges continuation
     * line information of multiple words which concat'd at runtime. Either
     * that or I have not managed to find a test case for these two
     * possibilities yet. It might be a difference between compile- versus
     * runtime processing.
     */

    numCL     = 0;
    maxNumCL  = 0;
    isLiteral = 1;
    for (i=0 ; i < count; i++) {
	if ((tokenPtr[i].type != TCL_TOKEN_TEXT) &&
	    (tokenPtr[i].type != TCL_TOKEN_BS)) {
	    isLiteral = 0;
	    break;
	}
    }

    if (isLiteral) {
	maxNumCL   = NUM_STATIC_POS;
	clPosition = (int*) ckalloc (maxNumCL*sizeof(int));
    }

    Tcl_DStringInit(&textBuffer);
    numObjsToConcat = 0;
    for ( ;  count > 0;  count--, tokenPtr++) {
	switch (tokenPtr->type) {
	case TCL_TOKEN_TEXT:
	    Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size);
	    break;

	case TCL_TOKEN_BS:
	    length = Tcl_UtfBackslash(tokenPtr->start, NULL, buffer);
	    Tcl_DStringAppend(&textBuffer, buffer, length);

	    /*
	     * If the backslash sequence we found is in a literal, and
	     * represented a continuation line, we compute and store its
	     * location (as char offset to the beginning of the _result_
	     * script). We may have to extend the table of locations.
	     *
	     * Note that the continuation line information is relevant even if
	     * the word we are processing is not a literal, as it can affect
	     * nested commands. See the branch for TCL_TOKEN_COMMAND below,
	     * where the adjustment we are tracking here is taken into
	     * account. The good thing is that we do not need a table of
	     * everything, just the number of lines we have to add as
	     * correction.
	     */

	    if ((length == 1) && (buffer[0] == ' ') &&
		(tokenPtr->start[1] == '\n')) {
		if (isLiteral) {
		    int clPos = Tcl_DStringLength (&textBuffer);

		    if (numCL >= maxNumCL) {
			maxNumCL *= 2;
			clPosition = (int*) ckrealloc ((char*)clPosition,
						       maxNumCL*sizeof(int));
		    }
		    clPosition[numCL] = clPos;
		    numCL ++;
		}
	    }
	    break;

	case TCL_TOKEN_COMMAND:
	    /*
	     * Push any accumulated chars appearing before the command.
	     */

	    if (Tcl_DStringLength(&textBuffer) > 0) {
		int literal = TclRegisterNewLiteral(envPtr,
			Tcl_DStringValue(&textBuffer),
			Tcl_DStringLength(&textBuffer));

		TclEmitPush(literal, envPtr);
		numObjsToConcat++;
		Tcl_DStringFree(&textBuffer);

		if (numCL) {
		    TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr,
					  numCL, clPosition);
		}
		numCL = 0;
	    }

	    TclCompileScript(interp, tokenPtr->start+1,
		    tokenPtr->size-2, envPtr);
	    numObjsToConcat++;
	    break;

    if (Tcl_DStringLength(&textBuffer) > 0) {
	int literal;

	literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer),
		Tcl_DStringLength(&textBuffer));
	TclEmitPush(literal, envPtr);
	numObjsToConcat++;

	if (numCL) {
	    TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr,
				  numCL, clPosition);
	}
	numCL = 0;
    }

    /*
     * If necessary, concatenate the parts of the word.
     */

    while (numObjsToConcat > 255) {

     * If the tokens yielded no instructions, push an empty string.
     */

    if (envPtr->codeNext == entryCodeNext) {
	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    }
    Tcl_DStringFree(&textBuffer);

    /*
     * Release the temp table we used to collect the locations of
     * continuation lines, if any.
     */

    if (maxNumCL) {
	ckfree ((char*) clPosition);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileCmdWord --
 *

				 * information. */
    int srcOffset,		/* Offset of first char of the command. */
    Tcl_Token *tokenPtr,
    const char *cmd,
    int len,
    int numWords,
    int line,
    int* clNext,
    int **wlines,
    CompileEnv* envPtr)
{
    ECL *ePtr;
    const char *last;
    int wordIdx, wordLine, *wwlines;
    int* wordNext;

    if (eclPtr->nuloc >= eclPtr->nloc) {
	/*
	 * Expand the ECL array by allocating more storage from the heap. The
	 * currently allocated ECL entries are stored from eclPtr->loc[0] up
	 * to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
	 */

	size_t currElems = eclPtr->nloc;
	size_t newElems = (currElems ? 2*currElems : 1);
	size_t newBytes = newElems * sizeof(ECL);

	eclPtr->loc = (ECL *) ckrealloc((char *) eclPtr->loc, newBytes);
	eclPtr->nloc = newElems;
    }

    ePtr = &eclPtr->loc[eclPtr->nuloc];
    ePtr->srcOffset = srcOffset;
    ePtr->line = (int *) ckalloc(numWords * sizeof(int));
    ePtr->next = (int**) ckalloc (numWords * sizeof (int*));
    ePtr->nline = numWords;
    wwlines = (int *) ckalloc(numWords * sizeof(int));

    last = cmd;
    wordLine = line;
    wordNext = clNext;
    for (wordIdx=0 ; wordIdx<numWords;
	    wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
	TclAdvanceLines(&wordLine, last, tokenPtr->start);
	TclAdvanceContinuations (&wordLine, &wordNext,
				 tokenPtr->start - envPtr->source);
	wwlines[wordIdx] =
		(TclWordKnownAtCompileTime(tokenPtr, NULL) ? wordLine : -1);
	ePtr->line[wordIdx] = wordLine;
	ePtr->next[wordIdx] = wordNext;
	last = tokenPtr->start;
    }

    *wlines = wwlines;
    eclPtr->nuloc ++;
}


/*
 * tclCompile.h --
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
 * Copyright (c) 2007 Daniel A. Steffen <[email protected]>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompile.h,v 1.118 2009/08/25 21:03:25 andreas_kupries Exp $
 */

#ifndef _TCLCOMPILATION
#define _TCLCOMPILATION 1

#include "tclInt.h"

 */

typedef struct ECL {
    int srcOffset;		/* Command location to find the entry. */
    int nline;                  /* Number of words in the command */
    int *line;			/* Line information for all words in the
				 * command. */
    int** next;                 /* Transient information used by the compiler
				 * for tracking of hidden continuation
				 * lines. */
} ECL;

typedef struct ExtCmdLoc {
    int type;			/* Context type. */
    int start;                  /* Starting line for compiled script. Needed
				 * for the extended recompile check in
				 * tclCompileObj. */

    int line;			/* First line of the script, based on the
				 * invoking context, then the line of the
				 * command currently compiled. */
    int atCmdStart;		/* Flag to say whether an INST_START_CMD
				 * should be issued; they should never be
				 * issued repeatedly, as that is significantly
				 * inefficient. */
    ContLineLoc* clLoc;  /* If not NULL, the table holding the
			  * locations of the invisible continuation
			  * lines in the input script, to adjust the
			  * line counter. */
    int*         clNext; /* If not NULL, it refers to the next slot in
			  * clLoc to check for an invisible
			  * continuation line. */
} CompileEnv;

/*
 * The structure defining the bytecode instructions resulting from compiling a
 * Tcl script. Note that this structure is variable length: a single heap
 * object is allocated to hold the ByteCode structure immediately followed by
 * the code bytes, the literal object array, the ExceptionRange array, the

 * Copyright (c) 2007 Daniel A. Steffen <[email protected]>
 * 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.437 2009/08/25 21:03:25 andreas_kupries Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options.

    int word;			/* Index of word in
				 * ExtCmdLoc.loc[cmd]->line[.] */
    struct CFWordBC* prevPtr;   /* Previous entry in stack for same Tcl_Obj */
    struct CFWordBC* nextPtr;   /* Next entry for same command call. See
				 * CmdFrame litarg field for the list start. */
} CFWordBC;

/*
 * Structure to record the locations of invisible continuation lines in
 * literal scripts, as character offset from the beginning of the script. Both
 * compiler and direct evaluator use this information to adjust their line
 * counters when tracking through the script, because when it is invoked the
 * continuation line marker as a whole has been removed already, meaning that
 * the \n which was part of it is gone as well, breaking regular line
 * tracking.
 *
 * These structures are allocated and filled by both the function
 * TclSubstTokens() in the file "tclParse.c" and its caller TclEvalEx() in the
 * file "tclBasic.c", and stored in the thread-global hashtable "lineCLPtr" in
 * file "tclObj.c". They are used by the functions TclSetByteCodeFromAny() and
 * TclCompileScript(), both found in the file "tclCompile.c". Their memory is
 * released by the function TclFreeObj(), in the file "tclObj.c", and also by
 * the function TclThreadFinalizeObjects(), in the same file.
 */

#define CLL_END (-1)

typedef struct ContLineLoc {
  int num;      /* Number of entries in loc, not counting the final -1
		 * marker entry */
  int loc[1];   /* Table of locations, as character offsets. The table
		 * is allocated as part of the structure, i.e. the loc
		 * array extends behind the nominal end of the
		 * structure. An entry containing the value -1 is put
		 * after the last location, as end-marker/sentinel. */
} ContLineLoc;

/*
 * The following macros define the allowed values for the type field of the
 * CmdFrame structure above. Some of the values occur only in the extended
 * location data referenced via the 'baseLocPtr'.
 *
 * TCL_LOCATION_EVAL	  : Frame is for a script evaluated by EvalEx.
 * TCL_LOCATION_EVAL_LIST : Frame is for a script evaluated by the list

				 * CFWord*" (See tclBasic.c). This allows
				 * commands like uplevel, eval, etc. to find
				 * location information for their arguments,
				 * if they are a proper literal argument to an
				 * invoking command. Alt view: An index to the
				 * CmdFrame stack keyed by command argument
				 * holders. */
    ContLineLoc* scriptCLLocPtr;
                                /* This table points to the location data for
				 * invisible continuation lines in the script,
				 * if any. This pointer is set by the function
				 * TclEvalObjEx() in file "tclBasic.c", and
				 * used by function ...() in the same file.
				 * It does for the eval/direct path of script
				 * execution what CompileEnv.clLoc does for
				 * the bytecode compiler.
				 */
    /*
     * TIP #268. The currently active selection mode, i.e. the package require
     * preferences.
     */

    int packagePrefer;		/* Current package selection mode. */

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

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,
			    int* clNextOuter, CONST char* outerScript);
MODULE_SCOPE int	TclFileAttrsCmd(Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclFileCopyCmd(Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclFileDeleteCmd(Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclFileMakeDirsCmd(Tcl_Interp *interp,

MODULE_SCOPE int	TclJoinThread(Tcl_ThreadId id, int *result);
MODULE_SCOPE void	TclLimitRemoveAllHandlers(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj *	TclLindexList(Tcl_Interp *interp,
			    Tcl_Obj *listPtr, Tcl_Obj *argPtr);
MODULE_SCOPE Tcl_Obj *	TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    int indexCount, Tcl_Obj *const indexArray[]);
/* TIP #280 */
MODULE_SCOPE void	TclListLines(Tcl_Obj *listObj, int line, int n,
				int *lines, Tcl_Obj* const* elems);
MODULE_SCOPE Tcl_Obj *	TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr);
MODULE_SCOPE int	TclLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    int symc, const char *symbols[],
			    Tcl_PackageInitProc **procPtrs[],
			    Tcl_LoadHandle *handlePtr,
			    ClientData *clientDataPtr,
			    Tcl_FSUnloadFileProc **unloadProcPtr);

			    int numBytes);
MODULE_SCOPE int	TclStringMatch(const char *str, int strLen,
			    const char *pattern, int ptnLen, int flags);
MODULE_SCOPE int	TclStringMatchObj(Tcl_Obj *stringObj,
			    Tcl_Obj *patternObj, int flags);
MODULE_SCOPE Tcl_Obj *	TclStringObjReverse(Tcl_Obj *objPtr);
MODULE_SCOPE int	TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
			    int count, int *tokensLeftPtr, int line,
			    int* clNextOuter, CONST char* outerScript);
MODULE_SCOPE Tcl_Obj *	TclpNativeToNormalized(ClientData clientData);
MODULE_SCOPE Tcl_Obj *	TclpFilesystemPathType(Tcl_Obj *pathPtr);
MODULE_SCOPE Tcl_PackageInitProc *TclpFindSymbol(Tcl_Interp *interp,
			    Tcl_LoadHandle loadHandle, const char *symbol);
MODULE_SCOPE int	TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    Tcl_LoadHandle *loadHandle,
			    Tcl_FSUnloadFileProc **unloadProcPtr);

 * Copyright (c) 2001 by ActiveState Corporation.
 * Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2007 Daniel A. Steffen <[email protected]>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclObj.c,v 1.156 2009/08/25 21:03:25 andreas_kupries Exp $
 */

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

typedef struct ObjData {
    Tcl_Obj *objPtr;		/* The pointer to the allocated Tcl_Obj. */
    const char *file;		/* The name of the source file calling this
				 * function; used for debugging. */
    int line;			/* Line number in the source file; used for
				 * debugging. */
} ObjData;
#endif /* TCL_MEM_DEBUG && TCL_THREADS */

/*
 * All static variables used in this file are collected into a single instance
 * of the following structure.  For multi-threaded implementations, there is
 * one instance of this structure for each thread.
 *
 * Notice that different structures with the same name appear in other files.
 * The structure defined below is used in this file only.
 */

typedef struct ThreadSpecificData {
    Tcl_HashTable* lineCLPtr; /* This table remembers for each Tcl_Obj
			       * generated by a call to the function
			       * EvalTokensStandard() from a literal text
			       * where bs+nl sequences occured in it, if
			       * any. I.e. this table keeps track of
			       * invisible/stripped continuation lines. Its
			       * keys are Tcl_Obj pointers, the values are
			       * ContLineLoc pointers.  See the file
			       * tclCompile.h for the definition of this
			       * structure, and for references to all related
			       * places in the core.
			       */
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
    /*
     * Thread local table that is used to check that a Tcl_Obj was not
     * allocated by some other thread.
     */


    Tcl_HashTable *objThreadMap;
#endif /* TCL_MEM_DEBUG && TCL_THREADS */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

static void ContLineLocFree (char* clientData);
static void TclThreadFinalizeObjects (ClientData clientData);
static ThreadSpecificData* TclGetTables (void);

/*
 * Nested Tcl_Obj deletion management support
 *
 * All context references used in the object freeing code are pointers to this
 * structure; every thread will have its own structure instance. The purpose
 * of this structure is to allow deeply nested collections of Tcl_Objs to be

void
TclFinalizeThreadObjects(void)
{
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch hSearch;
    ThreadSpecificData *tsdPtr = TclGetTables();
    Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;

    if (tablePtr != NULL) {
	for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch);
		hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
	    ObjData *objData = Tcl_GetHashValue(hPtr);

     * Tcl_Obj's to NULL; the memory finalization will take care of releasing
     * memory for us.
     */
    Tcl_MutexLock(&tclObjMutex);
    tclFreeObjList = NULL;
    Tcl_MutexUnlock(&tclObjMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetTables --
 *
 *	This procedure is a helper which returns the thread-specific
 *	hash-table used to track continuation line information associated with
 *	Tcl_Obj*, and the objThreadMap, etc.
 *
 * Results:
 *	A reference to the thread-data.
 *
 * Side effects:
 *	May allocate memory for the thread-data.
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

static ThreadSpecificData*
TclGetTables()
{
    /*
     * Initialize the hashtable tracking invisible continuation lines.  For
     * the release we use a thread exit handler to ensure that this is done
     * before TSD blocks are made invalid. The TclFinalizeObjects() which
     * would be the natural place for this is invoked afterwards, meaning that
     * we try to operate on a data structure already gone.
     */

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    if (!tsdPtr->lineCLPtr) {
	tsdPtr->lineCLPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
	Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
	Tcl_CreateThreadExitHandler (TclThreadFinalizeObjects,NULL);
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
	tsdPtr->objThreadMap = NULL;
#endif /* TCL_MEM_DEBUG && TCL_THREADS */
    }
    return tsdPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclContinuationsEnter --
 *
 *	This procedure is a helper which saves the continuation line
 *	information associated with a Tcl_Obj*.
 *
 * Results:
 *	A reference to the newly created continuation line location table.
 *
 * Side effects:
 *	Allocates memory for the table of continuation line locations.
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

ContLineLoc*
TclContinuationsEnter(Tcl_Obj* objPtr,
		      int num,
		      int* loc)
{
    int newEntry;
    ThreadSpecificData *tsdPtr = TclGetTables();
    Tcl_HashEntry* hPtr =
	Tcl_CreateHashEntry (tsdPtr->lineCLPtr, (char*) objPtr, &newEntry);

    ContLineLoc* clLocPtr = 
	(ContLineLoc*) ckalloc (sizeof(ContLineLoc) + num*sizeof(int));

    clLocPtr->num = num;
    memcpy (&clLocPtr->loc, loc, num*sizeof(int));
    clLocPtr->loc[num] = CLL_END; /* Sentinel */
    Tcl_SetHashValue (hPtr, clLocPtr);

    return clLocPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclContinuationsEnterDerived --
 *
 *	This procedure is a helper which computes the continuation line
 *	information associated with a Tcl_Obj* cut from the middle of a
 *	script.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Allocates memory for the table of continuation line locations.
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

void
TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext)
{
    /*
     * We have to handle invisible continuations lines here as well, despite
     * the code we have in TclSubstTokens (TST) for that. Why ?  Nesting. If
     * our script is the sole argument to an 'eval' command, for example, the
     * scriptCLLocPtr we are using was generated by a previous call to TST,
     * and while the words we have here may contain continuation lines they
     * are invisible already, and the inner call to TST had no bs+nl sequences
     * to trigger its code.
     *
     * Luckily for us, the table we have to create here for the current word
     * has to be a slice of the table currently in use, with the locations
     * suitably modified to be relative to the start of the word instead of
     * relative to the script.
     *
     * That is what we are doing now. Determine the slice we need, and if not
     * empty, wrap it into a new table, and save the result into our
     * thread-global hashtable, as usual.
     */

    /*
     * First compute the range of the word within the script.
     */

    int length, end, num;
    int* wordCLLast = clNext;

    Tcl_GetStringFromObj(objPtr, &length);
    /* Is there a better way which doesn't shimmer ? */

    end = start + length; /* first char after the word */

    /*
     * Then compute the table slice covering the range of
     * the word.
     */

    while (*wordCLLast >= 0 && *wordCLLast < end) {
	wordCLLast++;
    }

    /*
     * And generate the table from the slice, if it was
     * not empty.
     */

    num = wordCLLast - clNext;
    if (num) {
	int i;
	ContLineLoc* clLocPtr = 
	    TclContinuationsEnter(objPtr, num, clNext);

	/*
	 * Re-base the locations.
	 */

	for (i=0;i<num;i++) {
	    clLocPtr->loc[i] -= start;

	    /*
	     * Continuation lines coming before the string and affecting us
	     * should not happen, due to the proper maintenance of clNext
	     * during compilation.
	     */

	    if (clLocPtr->loc[i] < 0) {
		Tcl_Panic("Derived ICL data for object using offsets from before the script");
	    }
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclContinuationsCopy --
 *
 *	This procedure is a helper which copies the continuation line
 *	information associated with a Tcl_Obj* to another Tcl_Obj*.
 *	It is assumed that both contain the same string/script. Use
 *	this when a script is duplicated because it was shared.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Allocates memory for the table of continuation line locations.
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

void
TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr)
{
    ThreadSpecificData *tsdPtr = TclGetTables();
    Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) originObjPtr);

    if (hPtr) {
	ContLineLoc* clLocPtr = (ContLineLoc*) Tcl_GetHashValue (hPtr);

	TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclContinuationsGet --
 *
 *	This procedure is a helper which retrieves the continuation line
 *	information associated with a Tcl_Obj*, if it has any.
 *
 * Results:
 *	A reference to the continuation line location table, or NULL
 *	if the Tcl_Obj* has no such information associated with it.
 *
 * Side effects:
 *	None.
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

ContLineLoc*
TclContinuationsGet(Tcl_Obj* objPtr)
{
    ThreadSpecificData *tsdPtr = TclGetTables();
    Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) objPtr);

    if (hPtr) {
	return (ContLineLoc*) Tcl_GetHashValue (hPtr);
    } else {
	return NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclThreadFinalizeObjects --
 *
 *	This procedure is a helper which releases all continuation line
 *	information currently known. It is run as a thread exit handler.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Releases memory.
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

static void
TclThreadFinalizeObjects (ClientData clientData)
{
    /*
     * Release the hashtable tracking invisible continuation lines.
     */

    Tcl_HashEntry *hPtr;
    Tcl_HashSearch hSearch;
    ThreadSpecificData *tsdPtr = TclGetTables();

    for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch);
	 hPtr != NULL;
	 hPtr = Tcl_NextHashEntry(&hSearch)) {
	/*
	 * We are not using Tcl_EventuallyFree (as in TclFreeObj()) because
	 * here we can be sure that the compiler will not hold references to
	 * the data in the hashtable, and using TEF might bork the
	 * finalization sequence.
	 */
	ContLineLocFree (Tcl_GetHashValue (hPtr));
	Tcl_DeleteHashEntry (hPtr);
    }
    Tcl_DeleteHashTable (tsdPtr->lineCLPtr);
    tsdPtr->lineCLPtr = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * ContLineLocFree --
 *
 *	The freProc for continuation line location tables.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Releases memory.
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

static void
ContLineLocFree (char* clientData)
{
    ckfree (clientData);
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_RegisterObjType --
 *
 *	This function is called to register a new Tcl object type in the table

TclDbDumpActiveObjects(
    FILE *outFile)
{
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
    Tcl_HashSearch hSearch;
    Tcl_HashEntry *hPtr;
    Tcl_HashTable *tablePtr;
    ThreadSpecificData *tsdPtr = TclGetTables();

    tablePtr = tsdPtr->objThreadMap;

    if (tablePtr != NULL) {
	fprintf(outFile, "total objects: %d\n", tablePtr->numEntries);
	for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL;
		hPtr = Tcl_NextHashEntry(&hSearch)) {

     */

    if (!TclInExit()) {
	Tcl_HashEntry *hPtr;
	Tcl_HashTable *tablePtr;
	int isNew;
	ObjData *objData;
	ThreadSpecificData *tsdPtr = TclGetTables();

	if (tsdPtr->objThreadMap == NULL) {
	    tsdPtr->objThreadMap = (Tcl_HashTable *)
		    ckalloc(sizeof(Tcl_HashTable));
	    Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS);
	}
	tablePtr = tsdPtr->objThreadMap;

	    Tcl_MutexLock(&tclObjMutex);
	    ckfree((char *) objToFree);
	    Tcl_MutexUnlock(&tclObjMutex);
	    TclIncrObjsFreed();
	}
	ObjDeletionUnlock(context);
    }

    /*
     * We cannot use TclGetContinuationTable() here, because that may
     * re-initialize the thread-data for calls coming after the
     * finalization. We have to access it using the low-level call and then
     * check for validity. This function can be called after
     * TclFinalizeThreadData() has already killed the thread-global data
     * structures. Performing TCL_TSD_INIT will leave us with an
     * un-initialized memory block upon which we crash (if we where to access
     * the uninitialized hashtable).
     */

    {
	ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey);
	if (tsdPtr->lineCLPtr) {
	    Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr);
	    if (hPtr) {
		Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree);
		Tcl_DeleteHashEntry (hPtr);
	    }
	}
    }
}
#else /* TCL_MEM_DEBUG */

void
TclFreeObj(
    register Tcl_Obj *objPtr)	/* The object to be freed. */
{

		}
		TclFreeObjStorage(objToFree);
		TclIncrObjsFreed();
	    }
	    ObjDeletionUnlock(context);
	}
    }

    /*
     * We cannot use TclGetContinuationTable() here, because that may
     * re-initialize the thread-data for calls coming after the
     * finalization. We have to access it using the low-level call and then
     * check for validity. This function can be called after
     * TclFinalizeThreadData() has already killed the thread-global data
     * structures. Performing TCL_TSD_INIT will leave us with an
     * un-initialized memory block upon which we crash (if we where to access
     * the uninitialized hashtable).
     */

    {
	ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey);
	if (tsdPtr->lineCLPtr) {
	    Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr);
	    if (hPtr) {
		Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree);
		Tcl_DeleteHashEntry (hPtr);
	    }
	}
    }
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * TclObjBeingDeleted --

     * thread. Don't do this check when shutting down since thread local
     * storage can be finalized before the last Tcl_Obj is freed.
     */

    if (!TclInExit()) {
	Tcl_HashTable *tablePtr;
	Tcl_HashEntry *hPtr;
	ThreadSpecificData *tsdPtr = TclGetTables();

	tablePtr = tsdPtr->objThreadMap;
	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
	if (!hPtr) {

     * thread. Don't do this check when shutting down since thread local
     * storage can be finalized before the last Tcl_Obj is freed.
     */

    if (!TclInExit()) {
	Tcl_HashTable *tablePtr;
	Tcl_HashEntry *hPtr;
	ThreadSpecificData *tsdPtr = TclGetTables();

	tablePtr = tsdPtr->objThreadMap;
	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
	if (!hPtr) {

     * thread. Don't do this check when shutting down since thread local
     * storage can be finalized before the last Tcl_Obj is freed.
     */

    if (!TclInExit()) {
	Tcl_HashTable *tablePtr;
	Tcl_HashEntry *hPtr;
	ThreadSpecificData *tsdPtr = TclGetTables();
	tablePtr = tsdPtr->objThreadMap;
	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
	if (!hPtr) {
	    Tcl_Panic("%s%s",

	 */

	TclStackFree(interp, parsePtr);
	return "$";
    }

    code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens,
	    NULL, 1, NULL, NULL);
    TclStackFree(interp, parsePtr);
    if (code != TCL_OK) {
	return NULL;
    }
    objPtr = Tcl_GetObjResult(interp);

    /*

    /*
     * Next, substitute the parsed tokens just as in normal Tcl evaluation.
     */

    endTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
    tokensLeft = parsePtr->numTokens;
    code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
	    &tokensLeft, 1, NULL, NULL);
    if (code == TCL_OK) {
	Tcl_FreeParse(parsePtr);
	TclStackFree(interp, parsePtr);
	if (errMsg != NULL) {
	    Tcl_SetObjResult(interp, errMsg);
	    Tcl_DecrRefCount(errMsg);
	    return NULL;

		}
		Tcl_DecrRefCount(errMsg);
	    }
	    return result;
	}

	code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
		&tokensLeft, 1, NULL, NULL);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclSubstTokens --

    Tcl_Token *tokenPtr,	/* Pointer to first in an array of tokens to
				 * evaluate and concatenate. */
    int count,			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
    int *tokensLeftPtr,		/* If not NULL, points to memory where an
				 * integer representing the number of tokens
				 * left to be substituted will be written */
    int line,			/* The line the script starts on. */
    int*  clNextOuter,       /* Information about an outer context for */
    CONST char* outerScript) /* continuation line data. This is set by
			      * EvalEx() to properly handle [...]-nested
			      * commands. The 'outerScript' refers to the
			      * most-outer script containing the embedded
			      * command, which is refered to by 'script'. The
			      * 'clNextOuter' refers to the current entry in
			      * the table of continuation lines in this
			      * "master script", and the character offsets are
			      * relative to the 'outerScript' as well.
			      *
			      * If outerScript == script, then this call is for
			      * words in the outer-most script/command. See
			      * Tcl_EvalEx() and TclEvalObjEx() for the places
			      * generating arguments for which this is true.
			      */
{
    Tcl_Obj *result;
    int code = TCL_OK;
#define NUM_STATIC_POS 20
    int isLiteral, maxNumCL, numCL, i, adjust;
    int* clPosition;
    Interp* iPtr = (Interp*) interp;
    int inFile = iPtr->evalFlags & TCL_EVAL_FILE;

    /*
     * Each pass through this loop will substitute one token, and its
     * components, if any. The only thing tricky here is that we go to some
     * effort to pass Tcl_Obj's through untouched, to avoid string copying and
     * Tcl_Obj creation if possible, to aid performance and limit shimmering.
     *
     * Further optimization opportunities might be to check for the equivalent
     * of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp)) and omit them.
     */

    /*
     * For the handling of continuation lines in literals we first check if
     * this is actually a literal. For if not we can forego the additional
     * processing. Otherwise we pre-allocate a small table to store the
     * locations of all continuation lines we find in this literal, if
     * any. The table is extended if needed.
     */

    numCL     = 0;
    maxNumCL  = 0;
    isLiteral = 1;
    for (i=0 ; i < count; i++) {
	if ((tokenPtr[i].type != TCL_TOKEN_TEXT) &&
	    (tokenPtr[i].type != TCL_TOKEN_BS)) {
	    isLiteral = 0;
	    break;
	}
    }

    if (isLiteral) {
	maxNumCL   = NUM_STATIC_POS;
	clPosition = (int*) ckalloc (maxNumCL*sizeof(int));
    }

    adjust = 0;
    result = NULL;
    for (; count>0 && code==TCL_OK ; count--, tokenPtr++) {
	Tcl_Obj *appendObj = NULL;
	const char *append = NULL;
	int appendByteLength = 0;
	char utfCharBytes[TCL_UTF_MAX];

	switch (tokenPtr->type) {
	case TCL_TOKEN_TEXT:
	    append = tokenPtr->start;
	    appendByteLength = tokenPtr->size;
	    break;

	case TCL_TOKEN_BS:
	    appendByteLength = Tcl_UtfBackslash(tokenPtr->start, NULL,
		    utfCharBytes);
	    append = utfCharBytes;

	    /*
	     * If the backslash sequence we found is in a literal, and
	     * represented a continuation line, we compute and store its
	     * location (as char offset to the beginning of the _result_
	     * script). We may have to extend the table of locations.
	     *
	     * Note that the continuation line information is relevant even if
	     * the word we are processing is not a literal, as it can affect
	     * nested commands. See the branch for TCL_TOKEN_COMMAND below,
	     * where the adjustment we are tracking here is taken into
	     * account. The good thing is that we do not need a table of
	     * everything, just the number of lines we have to add as
	     * correction.
	     */

	    if ((appendByteLength == 1) && (utfCharBytes[0] == ' ') &&
		(tokenPtr->start[1] == '\n')) {
		if (isLiteral) {
		    int clPos;
		    if (result == 0) {
			clPos = 0;
		    } else {
			Tcl_GetStringFromObj(result, &clPos);
		    }

		    if (numCL >= maxNumCL) {
			maxNumCL *= 2;
			clPosition = (int*) ckrealloc ((char*)clPosition,
						       maxNumCL*sizeof(int));
		    }
		    clPosition[numCL] = clPos;
		    numCL ++;
		}
		adjust ++;
	    }
	    break;

	case TCL_TOKEN_COMMAND: {
	    /* TIP #280: Transfer line information to nested command */
 	    iPtr->numLevels++;
  	    code = TclInterpReady(interp);
  	    if (code == TCL_OK) {
		/*
		 * Test cases: info-30.{6,8,9}
		 */

		int theline;
		TclAdvanceContinuations (&line, &clNextOuter,
					 tokenPtr->start - outerScript);
		theline = line + adjust;
		code = TclEvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
			0, theline, clNextOuter, outerScript);
		/*
		 * Restore flag reset by nested eval for future bracketed
		 * commands and their cmdframe setup
		 */
	        if (inFile) {
		    iPtr->evalFlags |= TCL_EVAL_FILE;
		}
	    }
	    iPtr->numLevels--;
	    TclResetCancellation(interp, 0);
	    appendObj = Tcl_GetObjResult(interp);
	    break;
	}

	case TCL_TOKEN_VARIABLE: {
	    Tcl_Obj *arrayIndex = NULL;
	    Tcl_Obj *varName = NULL;

	    if (tokenPtr->numComponents > 1) {
		/*
		 * Subst the index part of an array variable reference.
		 */

		code = TclSubstTokens(interp, tokenPtr+2,
			tokenPtr->numComponents - 1, NULL, line, NULL, NULL);
		arrayIndex = Tcl_GetObjResult(interp);
		Tcl_IncrRefCount(arrayIndex);
	    }

	    if (code == TCL_OK) {
		varName = Tcl_NewStringObj(tokenPtr[1].start,
			tokenPtr[1].size);

	    }
	}
    }

    if (code != TCL_ERROR) {		/* Keep error message in result! */
	if (result != NULL) {
	    Tcl_SetObjResult(interp, result);
	    /*
	     * If the code found continuation lines (which implies that this
	     * word is a literal), then we store the accumulated table of
	     * locations in the thread-global data structure for the bytecode
	     * compiler to find later, assuming that the literal is a script
	     * which will be compiled.
	     */

	    if (numCL) {
		TclContinuationsEnter(result, numCL, clPosition);
	    }

	    /*
	     * Release the temp table we used to collect the locations of
	     * continuation lines, if any.
	     */

	    if (maxNumCL) {
		ckfree ((char*) clPosition);
	    }
	} else {
	    Tcl_ResetResult(interp);
	}
    }
    if (tokensLeftPtr != NULL) {
	*tokensLeftPtr = count;
    }

 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2004-2006 Miguel Sofer
 * Copyright (c) 2007 Daniel A. Steffen <[email protected]>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclProc.c,v 1.174 2009/08/25 21:03:25 andreas_kupries Exp $
 */

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

/*

	 * means that the same code can not be shared by two procedures that
	 * have a different number of arguments, even if their bodies are
	 * identical. Note that we don't use Tcl_DuplicateObj since we would
	 * not want any bytecode internal representation.
	 */

	if (Tcl_IsShared(bodyPtr)) {
	    Tcl_Obj* sharedBodyPtr = bodyPtr;

	    bytes = TclGetStringFromObj(bodyPtr, &length);
	    bodyPtr = Tcl_NewStringObj(bytes, length);

	    /*
	     * TIP #280.
	     * Ensure that the continuation line data for the original body is
	     * not lost and applies to the new body as well.
	     */

	    TclContinuationsCopy (bodyPtr, sharedBodyPtr);
	}

	/*
	 * Create and initialize a Proc structure for the procedure. We
	 * increment the ref count of the procedure's body object since there
	 * will be a reference to it in the Proc structure.
	 */

		CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));

		/*
		 * Move from approximation (line of list cmd word) to actual
		 * location (line of 2nd list element).
		 */

		TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL);

		cfPtr->level = -1;
		cfPtr->type = contextPtr->type;
		cfPtr->line = (int *) ckalloc(sizeof(int));
		cfPtr->line[0] = buf[1];
		cfPtr->nline = 1;
		cfPtr->framePtr = NULL;

 * 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.182 2009/08/25 21:03:25 andreas_kupries Exp $
 */

#include "tclInt.h"

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

	    if (oldValuePtr == NULL) {
		varPtr->value.objPtr = newValuePtr;
		Tcl_IncrRefCount(newValuePtr);
	    } else {
		if (Tcl_IsShared(oldValuePtr)) {	/* Append to copy. */
		    varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);

		    TclContinuationsCopy (varPtr->value.objPtr, oldValuePtr);

		    TclDecrRefCount(oldValuePtr);
		    oldValuePtr = varPtr->value.objPtr;
		    Tcl_IncrRefCount(oldValuePtr);	/* Since var is ref */
		}
		Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
	    }
	}

# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2006      ActiveState
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: info.test,v 1.65 2009/08/25 21:03:25 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Set up namespaces needed to test operation of "info args", "info body",

} {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0}
test info-22.8 {info frame, basic trace} -match glob -body {
    join [lrange [etrace] 0 2] \n
} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}


test info-23.0.0 {eval'd info frame} {!singleTestInterp} {
    eval {info frame}
} 8
test info-23.0.1 {eval'd info frame} -constraints {singleTestInterp} -match glob -body {
    eval {info frame}
} -result {1[12]} ;# SingleTestInterp results changes depending on running the whole suite, or info.test alone.
test info-23.1.0 {eval'd info frame, semi-dynamic} {!singleTestInterp} {

} {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}
test info-23.6 {eval'd info frame, trace} -match glob -body {
    set script {etrace}
    join [lrange [eval $script] 0 2] \n
} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 805 file info.test cmd {eval $script} proc ::tcltest::RunTest}}

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

# Procedures defined in scripts which are arguments to control
# structures (like 'namespace eval', 'interp eval', 'if', 'while',
# 'switch', 'catch', 'for', 'foreach', etc.) have no absolute
# location. The command implementations execute such scripts through
# Tcl_EvalObjEx. Flag 0 causes it to use the bytecode compiler. This

test info-25.1 {info frame, regular proc} {
    reduce [bar]
} {type source line 1005 file info.test cmd {info frame 0} proc ::bar level 0}

rename bar {}

# -------------------------------------------------------------------------
# More info-30.x test cases at the end of the file.
test info-30.0 {bs+nl in literal words} {
    if {1} {
	set res \
	    [reduce [info frame 0]];#1018
    }
    set res
    # This was reporting line 3 instead of the correct 4 because the
    # bs+nl combination is subst by the parser before the 'if'
    # command, and the bcc, see the word. Fixed by recording the
    # offsets of all bs+nl sequences in literal words, then using the
    # information in the bcc and other places to bump line numbers when
    # parsing over the location. Also affected: testcases 22.8 and 23.6.
} {type source line 1018 file info.test cmd {info frame 0} proc ::tcltest::RunTest}

# -------------------------------------------------------------------------
# See 24.0 - 24.5 for similar situations, using literal scripts.

set body {set flag 0
    set a c
    set res [info frame 0]} ;# line 3!

    }
    set res [::foo::bar]
    namespace delete ::foo
    join $res \n
} -result {
type source line 1427 file info.test cmd {info frame 0} proc ::foo::bar level 0
type source line 1428 file info.test cmd {info frame 0} proc ::foo::bar level 0}

# -------------------------------------------------------------------------
# Additional tests for info-30.*, handling of continuation lines (bs+nl sequences).

test info-30.1 {bs+nl in literal words, procedure body, compiled} {
    proc abra {} {
	if {1} \
	    {
		return \
		    [reduce [info frame 0]];# line 1446
	    }
    }
    set res [abra]
    rename abra {}
    set res
} {type source line 1446 file info.test cmd {info frame 0} proc ::abra level 0}

test info-30.2 {bs+nl in literal words, namespace script} {
    namespace eval xxx {
	set res \
	    [reduce [info frame 0]];# line 1457
    }
    set res
} {type source line 1457 file info.test cmd {info frame 0} level 0}

test info-30.3 {bs+nl in literal words, namespace multi-word script} {
    namespace eval xxx set res \
	[list [reduce [info frame 0]]];# line 1464
    set res
} {type source line 1464 file info.test cmd {info frame 0} proc ::tcltest::RunTest}

test info-30.4 {bs+nl in literal words, eval script} {
    eval {
	set ::res \
	    [reduce [info frame 0]];# line 1471
    }
    set res
} {type source line 1471 file info.test cmd {info frame 0} proc ::tcltest::RunTest}

test info-30.5 {bs+nl in literal words, eval script, with nested words} {
    eval {
	if {1} \
	    {
		set ::res \
		    [reduce [info frame 0]];# line 1481
	    }
    }
    set res
} {type source line 1481 file info.test cmd {info frame 0} proc ::tcltest::RunTest}

test info-30.6 {bs+nl in computed word} {
    set res "\
[reduce [info frame 0]]";# line 1489
} { type source line 1489 file info.test cmd {info frame 0} proc ::tcltest::RunTest}

test info-30.7 {bs+nl in computed word, in proc} {
    proc abra {} {
	return "\
[reduce [info frame 0]]";# line 1495
    }
    set res [abra]
    rename abra {}
    set res
} { type source line 1495 file info.test cmd {info frame 0} proc ::abra level 0}

test info-30.8 {bs+nl in computed word, nested eval} {
    eval {
	set \
	    res "\
[reduce [info frame 0]]";# line 1506
}
} { type source line 1506 file info.test cmd {info frame 0} proc ::tcltest::RunTest}

test info-30.9 {bs+nl in computed word, nested eval} {
    eval {
	set \
	    res "\
[reduce \
     [info frame 0]]";# line 1515
}
} { type source line 1515 file info.test cmd {info frame 0} proc ::tcltest::RunTest}

test info-30.10 {bs+nl in computed word, key to array} {
    set tmp([set \
	    res "\
[reduce \
     [info frame 0]]"]) x ; #1523
    unset tmp
    set res
} { type source line 1523 file info.test cmd {info frame 0} proc ::tcltest::RunTest}

test info-30.11 {bs+nl in subst arguments, no true counting} {
    subst {[set \
	    res "\
[reduce \
     [info frame 0]]"]}
} { type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}

test info-30.12 {bs+nl in computed word, nested eval} {
    eval {
	set \
	    res "\
[set x {}] \
[reduce \
     [info frame 0]]";# line 1541
}
} {   type source line 1541 file info.test cmd {info frame 0} proc ::tcltest::RunTest}

test info-30.13 {bs+nl in literal words, uplevel script, with nested words} {
    uplevel #0 {
	if {1} \
	    {
		set ::res \
		    [reduce [info frame 0]];# line 1550
	    }
    }
    set res
} {type source line 1550 file info.test cmd {info frame 0} proc ::tcltest::RunTest}

test info-30.14 {bs+nl, literal word, uplevel through proc} {
    proc abra {script} {
	uplevel 1 $script
    }
    set res [abra {
	return "\
[reduce [info frame 0]]";# line 1562
    }]
    rename abra {}
    set res
} { type source line 1562 file info.test cmd {info frame 0} proc ::abra}

test info-30.15 {bs+nl in literal words, nested proc body, compiled} {
    proc a {} {
	proc b {} {
	    if {1} \
		{
		    return \
			[reduce [info frame 0]];# line 1574
		}
	}
    }
    a ; set res [b]
    rename a {}
    rename b {}
    set res
} {type source line 1574 file info.test cmd {info frame 0} proc ::b level 0}

test info-30.16 {bs+nl in multi-body switch, compiled} {
    proc a {value} {
	switch -regexp -- $value \
	    ^key     { info frame 0; # 1587 } \
	    \t###    { info frame 0; # 1588 } \
	    {[0-9]*} { info frame 0; # 1589 }
    }
    set res {}
    lappend res [reduce [a {key   }]]
    lappend res [reduce [a {1alpha}]]
    set res "\n[join $res \n]"
} {
type source line 1587 file info.test cmd {info frame 0} proc ::a level 0
type source line 1589 file info.test cmd {info frame 0} proc ::a level 0}

test info-30.17 {bs+nl in multi-body switch, direct} {
    switch -regexp -- {key    } \
	^key     { reduce [info frame 0] ;# 1601 } \
        \t###    { } \
        {[0-9]*} { }
} {type source line 1601 file info.test cmd {info frame 0} proc ::tcltest::RunTest}

test info-30.18 {bs+nl, literal word, uplevel through proc, appended, loss of primary tracking data} {
    proc abra {script} {
	append script "\n# end of script"
	uplevel 1 $script
    }
    set res [abra {
	return "\
[reduce [info frame 0]]";# line 1613, still line of 3 appended script
    }]
    rename abra {}
    set res
} { type eval line 3 cmd {info frame 0} proc ::abra}
# { type source line 1606 file info.test cmd {info frame 0} proc ::abra}

test info-30.19 {bs+nl in single-body switch, compiled} {
    proc a {value} {
	switch -regexp -- $value {
	    ^key     { reduce \
			   [info frame 0] }
	    \t       { reduce \
			   [info frame 0] }
	    {[0-9]*} { reduce \
			   [info frame 0] }
	}
    }
    set res {}
    lappend res [a {key   }]
    lappend res [a {1alpha}]
    set res "\n[join $res \n]"
} {
type source line 1624 file info.test cmd {info frame 0} proc ::a level 0
type source line 1628 file info.test cmd {info frame 0} proc ::a level 0}

test info-30.20 {bs+nl in single-body switch, direct} {
    switch -regexp -- {key    } { \

	^key     { reduce \
		       [info frame 0] }
	\t###    { }
        {[0-9]*} { }
    }
} {type source line 1643 file info.test cmd {info frame 0} proc ::tcltest::RunTest}

test info-30.21 {bs+nl in if, full compiled} {
    proc a {value} {
	if {$value} \
	    {info frame 0} \
	    {info frame 0} ; # 1653
    }
    set res {}
    lappend res [reduce [a 1]]
    lappend res [reduce [a 0]]
    set res "\n[join $res \n]"
} {
type source line 1652 file info.test cmd {info frame 0} proc ::a level 0
type source line 1653 file info.test cmd {info frame 0} proc ::a level 0}

test info-30.22 {bs+nl in computed word, key to array, compiled} {
    proc a {} {
	set tmp([set \
		     res "\
[reduce \
     [info frame 0]]"]) x ; #1668
    unset tmp
    set res
    }
    set res [a]
    rename a {}
    set res
} { type source line 1668 file info.test cmd {info frame 0} proc ::a level 0}

test info-30.23 {bs+nl in multi-body switch, full compiled} {
    proc a {value} {
	switch -exact -- $value \
	    key     { info frame 0; # 1680 } \
	    xxx     { info frame 0; # 1681 } \
	    000     { info frame 0; # 1682 }
    }
    set res {}
    lappend res [reduce [a key]]
    lappend res [reduce [a 000]]
    set res "\n[join $res \n]"
} {
type source line 1680 file info.test cmd {info frame 0} proc ::a level 0
type source line 1682 file info.test cmd {info frame 0} proc ::a level 0}

test info-30.24 {bs+nl in single-body switch, full compiled} {
    proc a {value} {
	switch -exact -- $value {
	    key { reduce \
		      [info frame 0] }
	    xxx { reduce \
		      [info frame 0] }
	    000 { reduce \
		      [info frame 0] }
	}
    }
    set res {}
    lappend res [a key]
    lappend res [a 000]
    set res "\n[join $res \n]"
} {
type source line 1696 file info.test cmd {info frame 0} proc ::a level 0
type source line 1700 file info.test cmd {info frame 0} proc ::a level 0}

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

# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return