Tcl Source Code

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

	* generic/tclBasic.c (Tcl_CreateInterp, Tcl_EvalTokensStandard,
	EvalTokensStandard, Tcl_EvalEx, EvalEx, TclAdvanceContinuations,
	TclEvalObjEx):
	* generic/tclCmdMZ.c (Tcl_SwitchObjCmd, ListLines):
	* generic/tclCompCmds.c (*):
	* generic/tclCompile.c (TclSetByteCodeFromAny, TclInitCompileEnv,
	TclFreeCompileEnv, TclCompileScript):
	* generic/tclCompile.h (CompileEnv):
	* generic/tclInt.h (ContLineLoc, Interp):
	* generic/tclObj.c (ThreadSpecificData, ContLineLocFree,
	TclThreadFinalizeObjects, TclInitObjSubsystem,
	TclContinuationsEnter, TclContinuationsEnterDerived,
	TclContinuationsCopy, TclContinuationsGet, TclFreeObj):
	* generic/tclProc.c (TclCreateProc):
	* generic/tclVar.c (TclPtrSetVar):
	* tests/info.test (info-30.0-22):

	Extended parser, compiler, and execution with code and attendant
	data structures tracking the positions of continuation lines which
	are not visible in script's, to properly account for them while
	counting lines for #280, during direct and compiled execution.

2009-08-17  Don Porter  <[email protected]>

	* generic/tclFileName.c: Correct result from [glob */test] when *
	* tests/fileName.test:	matches something like ~foo.  [Bug 2837800]

2009-07-23  Joe Mistachkin  <[email protected]>

 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 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: tclBasic.c,v 1.75.2.37 2009/08/25 20:59:10 andreas_kupries Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#ifndef TCL_GENERIC_ONLY
#   include "tclPort.h"
#endif

						     CONST char* command,
						    Tcl_Command commandInfo,
						    int objc,
						    Tcl_Obj *CONST objv[]));
static void           StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData));

#ifdef TCL_TIP280
/* TIP #280 - Modified token based evaluation, with line information */
static int            EvalEx _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script,
					  int numBytes, int flags, int line,
					  int* clNextOuter, CONST char* outerScript));

static int            EvalTokensStandard _ANSI_ARGS_((Tcl_Interp *interp,
						      Tcl_Token *tokenPtr,
						      int count, int line,
						      int* clNextOuter, CONST char* outerScript));
#endif

#ifdef USE_DTRACE
static int	DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc,
		    Tcl_Obj *CONST objv[]);
#endif

    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;
#endif

    iPtr->activeVarTracePtr = NULL;
    iPtr->returnCode = TCL_OK;
    iPtr->errorInfo = NULL;
    iPtr->errorCode = NULL;

				 * 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. */
{
#ifdef TCL_TIP280
  return EvalTokensStandard (interp, tokenPtr, count, 1, NULL, NULL);
}

static int
EvalTokensStandard(interp, tokenPtr, count, line, clNextOuter, outerScript)
    Tcl_Interp *interp;		/* Interpreter in which to lookup
				 * variables, 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. */
    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.
			      */
{
#endif
    Tcl_Obj *resultPtr, *indexPtr, *valuePtr;
    char buffer[TCL_UTF_MAX];
#ifdef TCL_MEM_DEBUG
#   define  MAX_VAR_CHARS 5
#else
#   define  MAX_VAR_CHARS 30
#endif
    char nameBuffer[MAX_VAR_CHARS+1];
    char *varName, *index;
    CONST char *p = NULL;	/* Initialized to avoid compiler warning. */
    int length, code;
#ifdef TCL_TIP280
#define NUM_STATIC_POS 20
    int isLiteral, maxNumCL, numCL, i, adjust;
    int* clPosition;
    Interp* iPtr = (Interp*) interp;
    int inFile = iPtr->evalFlags & TCL_EVAL_FILE;
#endif

    /*
     * The only tricky thing about this procedure is that it attempts to
     * avoid object creation and string copying whenever possible.  For
     * example, if the value is just a nested command, then use the
     * command's result object directly.
     */

    code = TCL_OK;
    resultPtr = NULL;
    Tcl_ResetResult(interp);
#ifdef TCL_TIP280
    /*
     * 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;
#endif
    for ( ; count > 0; count--, tokenPtr++) {
	valuePtr = NULL;

	/*
	 * The switch statement below computes the next value to be
	 * concat to the result, as either a range of text or an
	 * object.
	 */

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

	    case TCL_TOKEN_BS:
		length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
			buffer);
		p = buffer;
#ifdef TCL_TIP280
		/*
		 * 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;
			if (resultPtr == 0) {
			    clPos = 0;
			} else {
			    Tcl_GetStringFromObj(resultPtr, &clPos);
			}

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

	    case TCL_TOKEN_COMMAND: {
		Interp *iPtr = (Interp *) interp;
		iPtr->numLevels++;
		code = TclInterpReady(interp);
		if (code == TCL_OK) {
#ifndef TCL_TIP280
		    code = Tcl_EvalEx(interp,
			    tokenPtr->start+1, tokenPtr->size-2, 0);
#else
		    /* TIP #280: Transfer line information to nested command */
		    TclAdvanceContinuations (&line, &clNextOuter,
					     tokenPtr->start - outerScript);
		    code = EvalEx(interp,
				  tokenPtr->start+1, tokenPtr->size-2, 0,
				  line + adjust, clNextOuter, outerScript);

		    /*
		     * Restore flag reset by the nested eval for future
		     * bracketed commands and their CmdFrame setup
		     */
		    if (inFile) {
			iPtr->evalFlags |= TCL_EVAL_FILE;
		    }
#endif
		}
		iPtr->numLevels--;
		if (code != TCL_OK) {
		    goto done;
		}
		valuePtr = Tcl_GetObjResult(interp);

		} else {
#ifndef TCL_TIP280
		    code = Tcl_EvalTokensStandard(interp, tokenPtr+2,
			    tokenPtr->numComponents - 1);
#else
		    /* TIP #280: Transfer line information to nested command */
		    code = EvalTokensStandard(interp, tokenPtr+2,
			    tokenPtr->numComponents - 1, line, NULL, NULL);
#endif
		    if (code != TCL_OK) {
			goto done;
		    }
		    indexPtr = Tcl_GetObjResult(interp);
		    Tcl_IncrRefCount(indexPtr);
		    index = Tcl_GetString(indexPtr);

		p = Tcl_GetStringFromObj(valuePtr, &length);
	    }
	    Tcl_AppendToObj(resultPtr, p, length);
	}
    }
    if (resultPtr != NULL) {
	Tcl_SetObjResult(interp, resultPtr);
#ifdef TCL_TIP280
	/*
	 * 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(resultPtr, numCL, clPosition);
	}

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

	if (maxNumCL) {
	    ckfree ((char*) clPosition);
	}
#endif
    } else {
	code = TCL_ERROR;
    }

    done:
    if (resultPtr != NULL) {
	Tcl_DecrRefCount(resultPtr);

				 * first null character. */
    int flags;			/* Collection of OR-ed bits that control
				 * the evaluation of the script.  Only
				 * TCL_EVAL_GLOBAL is currently
				 * supported. */
{
#ifdef TCL_TIP280
  return EvalEx (interp, script, numBytes, flags, 1, NULL, script);
}

static int
EvalEx(interp, script, numBytes, flags, line, clNextOuter, outerScript)
    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 null 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.
			      */
{
#endif
    Interp *iPtr = (Interp *) interp;
    CONST char *p, *next;
    Tcl_Parse parse;
#define NUM_STATIC_OBJS 20
    Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;

     */

    int gotParse = 0, objectsUsed = 0;

#ifdef TCL_TIP280
    /* TIP #280 Structures for tracking of command locations. */
    CmdFrame eeFrame;

    /*
     * 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];
	}
    }
#endif

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

	} else {
	    eeFrame.data.eval.path = Tcl_NewStringObj ("",-1);
	}
	Tcl_IncrRefCount (eeFrame.data.eval.path);
    } else {
	/* Set up for plain eval */

	eeFrame.type           = TCL_LOCATION_EVAL;
	eeFrame.data.eval.path = NULL;
    }

    eeFrame.level     = (iPtr->cmdFramePtr == NULL
			 ? 1
			 : iPtr->cmdFramePtr->level + 1);
    eeFrame.framePtr  = iPtr->framePtr;

	    goto error;
	}

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

	TclAdvanceLines         (&line, p, parse.commandStart);
	TclAdvanceContinuations (&line, &clNext,
				 parse.commandStart - outerScript);
#endif

	if (parse.numWords > 0) {
#ifdef TCL_TIP280
	    /*
	     * 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  = parse.commandStart;
	    int*        wordCLNext = clNext;
#endif

	    /*
	     * Generate an array of objects for the words of the command.
	     */
    
	    if (parse.numWords <= NUM_STATIC_OBJS) {

		 * TIP #280. Track lines to current word. Save the
		 * information 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;

		eeFrame.line [objectsUsed] = (TclWordKnownAtCompileTime (tokenPtr)
					      ? wordLine
					      : -1);

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

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

		iPtr->evalFlags = 0;
#endif

		if (code == TCL_OK) {
		    objv[objectsUsed] = Tcl_GetObjResult(interp);
		    Tcl_IncrRefCount(objv[objectsUsed]);
#ifdef TCL_TIP280
		    if (wordCLNext) {
			TclContinuationsEnterDerived (objv[objectsUsed],
				      wordStart - outerScript, wordCLNext);
		    }
#endif
		} else {
		    goto error;
		}
	    }
    
	    /*
	     * Execute the command and free the objects for its words.

    CONST char* p;
    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

     */

    hPtr = Tcl_FindHashEntry (iPtr->lineLABCPtr, (char *) obj);
    if (hPtr) {
	CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr);

	framePtr = cfwPtr->framePtr;
	framePtr->data.tebc.pc = (char*) ((ByteCode*)
		  framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc;
	*cfPtrPtr = cfwPtr->framePtr;
	*wordPtr  = cfwPtr->word;
	return;
    }
}
#endif

	     * the script to evaluate is a single literal it makes sense to
	     * look if our context is one with absolute line numbers we can
	     * then track into the literal itself too.
	     *
	     * See also tclCompile.c, TclInitCompileEnv, for the equivalent
	     * code in the bytecode compiler.
	     */

	    /*
	     * 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;
	    }

	    if (invoker == NULL) {
	        /* No context, force opening of our own */
	        script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
		result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
	    } else {
		/* We have an invoker, describing the command asking for the

		    result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
		} else {
		    /* Absolute context available to reuse. */

		    iPtr->invokeCmdFramePtr = &ctx;
		    iPtr->evalFlags |= TCL_EVAL_CTX;

		    result = EvalEx(interp, script, numSrcBytes, flags,
				    ctx.line [word], NULL, script);

		    if (pc) {
			/* Death of SrcInfo reference */
			Tcl_DecrRefCount (ctx.data.eval.path);
		    }
		}
	    }

	    /*
	     * 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;
#endif
	}
    } else {
	/*
	 * Let the compiler/engine subsystem do the evaluation.
	 *
	 * TIP #280 The invoker provides us with the context for the

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

 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Scriptics Corporation.
 * Copyright (c) 2002 ActiveState Corporation.
 *
 * 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.82.2.30 2009/08/25 20:59:10 andreas_kupries Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"
#include "tclCompile.h"

                            CONST char *name2, int flags));
static void		TraceCommandProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *oldName,
                            CONST char *newName, int flags));
static Tcl_CmdObjTraceProc TraceExecutionProc;

#ifdef TCL_TIP280
static void             ListLines _ANSI_ARGS_((Tcl_Obj* listObj, int line,
					       int n, int* lines,
					       Tcl_Obj* const* elems));
#endif
/*
 *----------------------------------------------------------------------
 *
 * Tcl_PwdObjCmd --
 *
 *	This procedure is invoked to process the "pwd" Tcl command.

	    if (ctx.type == TCL_LOCATION_SOURCE) {
		int bline = ctx.line [bidx];
		if (bline >= 0) {
		    ctx.line  = (int*) ckalloc (objc * sizeof(int));
		    ctx.nline = objc;

		    ListLines (blist, bline, objc, ctx.line, objv);
		} else {
		    int k;
		    /* Dynamic code word ... All elements are relative to themselves */

		    ctx.line  = (int*) ckalloc (objc * sizeof(int));
		    ctx.nline = objc;
		    for (k=0; k < objc; k++) {ctx.line[k] = -1;}

		break;
	    }
	}
#ifndef TCL_TIP280
	result = Tcl_EvalObjEx(interp, objv[j], 0);
#else
	/* TIP #280. Make invoking context available to switch branch */
	result = TclEvalObjEx(interp, objv[j], 0, &ctx, splitObjs ? j : bidx+j);
	if (splitObjs) {
	    ckfree ((char*) ctx.line);
	    if (pc && (ctx.type == TCL_LOCATION_SOURCE)) {
		/* Death of SrcInfo reference */
		Tcl_DecrRefCount (ctx.data.eval.path);
	    }
	}

        Tcl_ResetResult(interp);
    }
    return result;
}

#ifdef TCL_TIP280
static void
ListLines(listObj, line, n, lines, elems)
     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 */
{
    int          i;
    CONST char*  listStr  = Tcl_GetString (listObj);
    CONST char*  listHead = listStr;
    int          length   = strlen( listStr);
    CONST char*  element  = NULL;
    CONST char*  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 (clNext) {
	    TclContinuationsEnterDerived (elems[i], element - listHead, clNext);
	}

	lines [i] = line;
	length   -= (next - listStr);
	TclAdvanceLines (&line, element, next); /* Element */
	listStr   = next;

	if (*element == 0) {
	    /* ASSERT i == n */

/* 
 * tclCompCmds.c --
 *
 *	This file contains compilation procedures that compile various
 *	Tcl commands into a sequence of instructions ("bytecodes"). 
 *
 * Copyright (c) 1997-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002 ActiveState Corporation.
 *
 * 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.39.2.8 2009/08/25 20:59:10 andreas_kupries Exp $
 */

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

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

static ClientData	DupForeachInfo _ANSI_ARGS_((ClientData clientData));
static void		FreeForeachInfo _ANSI_ARGS_((ClientData clientData));
#ifndef TCL_TIP280
static int		TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
	Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags,
	int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr));

#define TclPushVarNameWord(i,v,e,f,l,s,sc,word) \
    TclPushVarName (i,v,e,f,l,s,sc) /* ignoring word */

#define DefineLineInformation /**/
#define SetLineInformation(word) /**/
#else
static int		TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
	Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags,
	int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr,
	int line, int* clNext));

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

/* 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.
 *
 * Macros to encapsulate the variable definition and setup, and their use.
 */
#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)]
#endif

/*
 * Flags bits used by TclPushVarName.
 */

#define TCL_CREATE_VAR     1 /* Create a compiled local if none is found */

				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr, *valueTokenPtr;
    int simpleVarName, isScalar, localIndex, numWords;
    int code = TCL_OK;


    DefineLineInformation;








    numWords = parsePtr->numWords;
    if (numWords == 1) {
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
		"wrong # args: should be \"append varName ?value value ...?\"",
		-1);

     * procedure body and if the name is simple text that does not include
     * namespace qualifiers. 
     */

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);

    code = TclPushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,

	    &localIndex, &simpleVarName, &isScalar, 1);




    if (code != TCL_OK) {
	goto done;
    }

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

    if (numWords > 2) {
	valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(TclRegisterNewLiteral(envPtr, 
		    valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
	} else {
	    SetLineInformation (2);


	    code = TclCompileTokens(interp, valueTokenPtr+1,
	            valueTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		goto done;
	    }
	}
    }

    JumpFixup jumpFixup;
    Tcl_Token *cmdTokenPtr, *nameTokenPtr;
    CONST char *name;
    int localIndex, nameChars, range, startOffset, jumpDist;
    int code;
    int savedStackDepth = envPtr->currStackDepth;


    DefineLineInformation;








    if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
	        "wrong # args: should be \"catch command ?varName?\"", -1);
	return TCL_ERROR;
    }

     * 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) {
	startOffset = (envPtr->codeNext - envPtr->codeStart);
	code = TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr);
    } else {
	code = TclCompileTokens(interp, cmdTokenPtr+1,
	        cmdTokenPtr->numComponents, envPtr);
	startOffset = (envPtr->codeNext - envPtr->codeStart);

TclCompileExprCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *firstWordPtr;

    DefineLineInformation;

    if (parsePtr->numWords == 1) {
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
	        "wrong # args: should be \"expr arg ?arg ...?\"", -1);
        return TCL_ERROR;
    }


    SetLineInformation (1);



    firstWordPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);
    return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1),
	    envPtr);
}

/*

    Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
    JumpFixup jumpEvalCondFixup;
    int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
    int bodyRange, nextRange, code;
    char buffer[32 + TCL_INTEGER_SPACE];
    int savedStackDepth = envPtr->currStackDepth;


    DefineLineInformation;








    if (parsePtr->numWords != 5) {
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
	        "wrong # args: should be \"for start test next command\"", -1);
	return TCL_ERROR;
    }

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

    /*
     * Inline compile the initial command.
     */

    SetLineInformation (1);


    code = TclCompileCmdWord(interp, startTokenPtr+1,
	    startTokenPtr->numComponents, envPtr);
    if (code != TCL_OK) {
	if (code == TCL_ERROR) {
            Tcl_AddObjErrorInfo(interp,
	            "\n    (\"for\" initial command)", -1);
        }

    /*
     * Compile the loop body.
     */

    bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);

    SetLineInformation (4);


    code = TclCompileCmdWord(interp, bodyTokenPtr+1,
	    bodyTokenPtr->numComponents, envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;
    if (code != TCL_OK) {
	if (code == TCL_ERROR) {
	    sprintf(buffer, "\n    (\"for\" body line %d)",
		    interp->errorLine);

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

    nextCodeOffset = (envPtr->codeNext - envPtr->codeStart);

    SetLineInformation (3);


    envPtr->currStackDepth = savedStackDepth;
    code = TclCompileCmdWord(interp, nextTokenPtr+1,
	    nextTokenPtr->numComponents, envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;
    if (code != TCL_OK) {
	if (code == TCL_ERROR) {
	    Tcl_AddObjErrorInfo(interp,

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


    envPtr->currStackDepth = savedStackDepth;
    code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
    if (code != TCL_OK) {
	if (code == TCL_ERROR) {
	    Tcl_AddObjErrorInfo(interp,
				"\n    (\"for\" test expression)", -1);
	}

    unsigned char *jumpPc;
    JumpFixup jumpFalseFixup;
    int jumpDist, jumpBackDist, jumpBackOffset, infoIndex, range;
    int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
    char buffer[32 + TCL_INTEGER_SPACE];
    int savedStackDepth = envPtr->currStackDepth;

    DefineLineInformation;
#ifdef TCL_TIP280







    int        bodyIndex;
#endif

    /*
     * We parse the variable list argument words and create two arrays:
     *    varcList[i] is number of variables in i-th var list
     *    varvList[i] points to array of var names in i-th var list

    range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
    
    loopIndex = 0;
    for (i = 0, tokenPtr = parsePtr->tokenPtr;
	    i < numWords-1;
	    i++, tokenPtr += (tokenPtr->numComponents + 1)) {
	if ((i%2 == 0) && (i > 0)) {
	    SetLineInformation (i);


	    code = TclCompileTokens(interp, tokenPtr+1,
		    tokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		goto done;
	    }

	    tempVar = (firstValueTemp + loopIndex);

    TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
    TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
    
    /*
     * Inline compile the loop body.
     */


    SetLineInformation (bodyIndex);

    envPtr->exceptArrayPtr[range].codeOffset =
	    (envPtr->codeNext - envPtr->codeStart);
    code = TclCompileCmdWord(interp, bodyTokenPtr+1,
	    bodyTokenPtr->numComponents, envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;
    if (code != TCL_OK) {
	if (code == TCL_ERROR) {

                                /* Saved stack depth at the start of the first
				 * test; the envPtr current depth is restored
				 * to this value at the start of each test. */
    int realCond = 1;           /* set to 0 for static conditions: "if 0 {..}" */
    int boolVal;                /* value of static condition */
    int compileScripts = 1;            


    DefineLineInformation;








    /*
     * Only compile the "if" command if all arguments are simple
     * words, in order to insure correct substitution [Bug 219166]
     */

    tokenPtr = parsePtr->tokenPtr;

		 */
		realCond = 0;
		if (!boolVal) {
		    compileScripts = 0;
		}
	    } else {
		Tcl_ResetResult(interp);

		SetLineInformation (wordIdx);

		code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
		if (code != TCL_OK) {
		    if (code == TCL_ERROR) {
			Tcl_AddObjErrorInfo(interp,
			        "\n    (\"if\" test expression)", -1);
		    }
		    goto done;

	}

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

	if (compileScripts) {

	    SetLineInformation (wordIdx);

	    envPtr->currStackDepth = savedStackDepth;
	    code = TclCompileCmdWord(interp, tokenPtr+1,
	            tokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		if (code == TCL_ERROR) {
		    sprintf(buffer, "\n    (\"if\" then script line %d)",
		            interp->errorLine);

	    }
	}

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

	    SetLineInformation (wordIdx);

	    code = TclCompileCmdWord(interp, tokenPtr+1,
		    tokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		if (code == TCL_ERROR) {
		    sprintf(buffer, "\n    (\"if\" else script line %d)",
			    interp->errorLine);
		    Tcl_AddObjErrorInfo(interp, buffer, -1);

				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr, *incrTokenPtr;
    int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
    int code = TCL_OK;


    DefineLineInformation;








    if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
	        "wrong # args: should be \"incr varName ?increment?\"", -1);
	return TCL_ERROR;
    }

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);

    code = TclPushVarNameWord(interp, varTokenPtr, envPtr, 
	    (TCL_NO_LARGE_INDEX | TCL_CREATE_VAR),

	    &localIndex, &simpleVarName, &isScalar, 1);




    if (code != TCL_OK) {
	goto done;
    }

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

		}
	    }
	    if (!haveImmValue) {
		TclEmitPush(
			TclRegisterNewLiteral(envPtr, word, numBytes), envPtr);
	    }
	} else {
	    SetLineInformation (2);


	    code = TclCompileTokens(interp, incrTokenPtr+1, 
	            incrTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		goto done;
	    }
	}
    } else {			/* no incr amount given so use 1 */

				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr, *valueTokenPtr;
    int simpleVarName, isScalar, localIndex, numWords;
    int code = TCL_OK;


    DefineLineInformation;








    /*
     * If we're not in a procedure, don't compile.
     */
    if (envPtr->procPtr == NULL) {
	return TCL_OUT_LINE_COMPILE;
    }

     * procedure body and if the name is simple text that does not include
     * namespace qualifiers. 
     */

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);

    code = TclPushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,

	    &localIndex, &simpleVarName, &isScalar, 1);




    if (code != TCL_OK) {
	goto done;
    }

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

    if (numWords > 2) {
	valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(TclRegisterNewLiteral(envPtr, 
		    valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
	} else {
	    SetLineInformation (2);


	    code = TclCompileTokens(interp, valueTokenPtr+1,
	            valueTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		goto done;
	    }
	}
    }

    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr;
    int code, i;


    DefineLineInformation;








    int numWords;
    numWords = parsePtr->numWords;

    /*
     * Quit if too few args
     */

	
    for ( i = 1 ; i < numWords ; i++ ) {
	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(
		    TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
		    varTokenPtr[1].size), envPtr);
	} else {
	    SetLineInformation (i);


	    code = TclCompileTokens(interp, varTokenPtr+1,
				    varTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		return code;
	    }
	}
	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);

int
TclCompileListCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{

    DefineLineInformation;








    /*
     * If we're not in a procedure, don't compile.
     */
    if (envPtr->procPtr == NULL) {
	return TCL_OUT_LINE_COMPILE;
    }

	valueTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);
	for (i = 1; i < numWords; i++) {
	    if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		TclEmitPush(TclRegisterNewLiteral(envPtr,
			valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
	    } else {
		SetLineInformation (i);


		code = TclCompileTokens(interp, valueTokenPtr+1,
			valueTokenPtr->numComponents, envPtr);
		if (code != TCL_OK) {
		    return code;
		}
	    }
	    valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1);

    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr;
    int code;


    DefineLineInformation;








    if (parsePtr->numWords != 2) {
	Tcl_SetResult(interp, "wrong # args: should be \"llength list\"",
		TCL_STATIC);
	return TCL_ERROR;
    }
    varTokenPtr = parsePtr->tokenPtr
	+ (parsePtr->tokenPtr->numComponents + 1);

    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	/*
	 * We could simply count the number of elements here and push
	 * that value, but that is too rare a case to waste the code space.
	 */
	TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
		varTokenPtr[1].size), envPtr);
    } else {
	SetLineInformation (1);


	code = TclCompileTokens(interp, varTokenPtr+1,
		varTokenPtr->numComponents, envPtr);
	if (code != TCL_OK) {
	    return code;
	}
    }
    TclEmitOpcode(INST_LIST_LENGTH, envPtr);

    int localIndex;		/* Index of var in local var table */
    int simpleVarName;		/* Flag == 1 if var name is simple */
    int isScalar;		/* Flag == 1 if scalar, 0 if array */

    int i;


    DefineLineInformation;








    /* Check argument count */

    if ( parsePtr->numWords < 3 ) {
	/* Fail at run time, not in compilation */
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Decide if we can use a frame slot for the var/array name or if we
     * need 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 = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);
    result = TclPushVarNameWord( interp, varTokenPtr, envPtr, 

            TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, 1);




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

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

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

	/* Advance to next arg */

	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);

	/* Push an arg */

	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
		    varTokenPtr[1].size), envPtr);
	} else {
	    SetLineInformation (i);


	    result = TclCompileTokens(interp, varTokenPtr+1,
				      varTokenPtr->numComponents, envPtr);
	    if ( result != TCL_OK ) {
		return result;
	    }
	}
    }

    CompileEnv* envPtr;		/* Holds the resulting instructions */
{
    Tcl_Token *varTokenPtr;	/* Pointer to the Tcl_Token representing
				 * the parse of the RE or string */
    int i, len, code, nocase, anchorLeft, anchorRight, start;
    char *str;


    DefineLineInformation;








    /*
     * We are only interested in compiling simple regexp cases.
     * Currently supported compile cases are:
     *   regexp ?-nocase? ?--? staticString $var
     *   regexp ?-nocase? ?--? {^staticString$} $var
     */

     * Push the string arg
     */
    varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	TclEmitPush(TclRegisterNewLiteral(envPtr,
		varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
    } else {

	SetLineInformation (parsePtr->numWords-1);

	code = TclCompileTokens(interp, varTokenPtr+1,
		varTokenPtr->numComponents, envPtr);
	if (code != TCL_OK) {
	    return code;
	}
    }

				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr;
    int code;
    int index = envPtr->exceptArrayNext - 1;


    DefineLineInformation;








    /*
     * If we're not in a procedure, don't compile.
     */

    if (envPtr->procPtr == NULL) {
	return TCL_OUT_LINE_COMPILE;

		/*
		 * Parse token is more complex, so compile it; this handles the
		 * variable reference and nested command cases.  If the
		 * parse token can be byte-compiled, then this instance of
		 * "return" will be byte-compiled; otherwise it will be
		 * out line compiled.
		 */
		SetLineInformation (1);


		code = TclCompileTokens(interp, varTokenPtr+1,
			varTokenPtr->numComponents, envPtr);
		if (code != TCL_OK) {
		    return code;
		}
	    }
	    break;

				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr, *valueTokenPtr;
    int isAssignment, isScalar, simpleVarName, localIndex, numWords;
    int code = TCL_OK;


    DefineLineInformation;








    numWords = parsePtr->numWords;
    if ((numWords != 2) && (numWords != 3)) {
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
	        "wrong # args: should be \"set varName ?newValue?\"", -1);
        return TCL_ERROR;

     * procedure body and if the name is simple text that does not include
     * namespace qualifiers. 
     */

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);

    code = TclPushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,

	    &localIndex, &simpleVarName, &isScalar, 1);




    if (code != TCL_OK) {
	goto done;
    }

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

    if (isAssignment) {
	valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start,
		    valueTokenPtr[1].size), envPtr);
	} else {
	    SetLineInformation (2);


	    code = TclCompileTokens(interp, valueTokenPtr+1,
	            valueTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		goto done;
	    }
	}
    }

	STR_INDEX,	STR_IS,		STR_LAST,	STR_LENGTH,
	STR_MAP,	STR_MATCH,	STR_RANGE,	STR_REPEAT,
	STR_REPLACE,	STR_TOLOWER,	STR_TOUPPER,	STR_TOTITLE,
	STR_TRIM,	STR_TRIMLEFT,	STR_TRIMRIGHT,
	STR_WORDEND,	STR_WORDSTART
    };	  


    DefineLineInformation;








    if (parsePtr->numWords < 2) {
	/* Fail at run time, not in compilation */
	return TCL_OUT_LINE_COMPILE;
    }
    opTokenPtr = parsePtr->tokenPtr
	+ (parsePtr->tokenPtr->numComponents + 1);

	     */

	    for (i = 0; i < 2; i++) {
		if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		    TclEmitPush(TclRegisterNewLiteral(envPtr,
			    varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
		} else {
		    SetLineInformation (i);


		    code = TclCompileTokens(interp, varTokenPtr+1,
			    varTokenPtr->numComponents, envPtr);
		    if (code != TCL_OK) {
			return code;
		    }
		}
		varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);

	     */

	    for (i = 0; i < 2; i++) {
		if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		    TclEmitPush(TclRegisterNewLiteral(envPtr,
			    varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
		} else {
		    SetLineInformation (i);


		    code = TclCompileTokens(interp, varTokenPtr+1,
			    varTokenPtr->numComponents, envPtr);
		    if (code != TCL_OK) {
			return code;
		    }
		}
		varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);

		char buf[TCL_INTEGER_SPACE];
		int len = Tcl_NumUtfChars(varTokenPtr[1].start,
			varTokenPtr[1].size);
		len = sprintf(buf, "%d", len);
		TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr);
		return TCL_OK;
	    } else {
		SetLineInformation (2);


		code = TclCompileTokens(interp, varTokenPtr+1,
			varTokenPtr->numComponents, envPtr);
		if (code != TCL_OK) {
		    return code;
		}
	    }
	    TclEmitOpcode(INST_STR_LEN, envPtr);

			exactMatch = (strpbrk(Tcl_GetString(copy),
				"*[]?\\") == NULL);
			Tcl_DecrRefCount(copy);
		    }
		    TclEmitPush(
			    TclRegisterNewLiteral(envPtr, str, length), envPtr);
		} else {
		    SetLineInformation (i);


		    code = TclCompileTokens(interp, varTokenPtr+1,
			    varTokenPtr->numComponents, envPtr);
		    if (code != TCL_OK) {
			return code;
		    }
		}
		varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);

    char buffer[32 + TCL_INTEGER_SPACE];
    int savedStackDepth = envPtr->currStackDepth;
    int loopMayEnd = 1;         /* This is set to 0 if it is recognized as
				 * an infinite loop. */
    Tcl_Obj *boolObj;
    int boolVal;


    DefineLineInformation;








    if (parsePtr->numWords != 3) {
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
	        "wrong # args: should be \"while test command\"", -1);
	return TCL_ERROR;
    }

    }
    

    /*
     * Compile the loop body.
     */

    SetLineInformation (2);


    bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
    code = TclCompileCmdWord(interp, bodyTokenPtr+1,
	    bodyTokenPtr->numComponents, envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;
    if (code != TCL_OK) {
	if (code == TCL_ERROR) {
	    sprintf(buffer, "\n    (\"while\" body line %d)",

	testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
	jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
	if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
	    bodyCodeOffset += 3;
	    testCodeOffset += 3;
	}
	envPtr->currStackDepth = savedStackDepth;
	SetLineInformation (1);


	code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
	if (code != TCL_OK) {
	    if (code == TCL_ERROR) {
		Tcl_AddObjErrorInfo(interp,
				    "\n    (\"while\" test expression)", -1);
	    }
	    goto error;

 */

static int
TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
#ifndef TCL_TIP280
	simpleVarNamePtr, isScalarPtr)
#else
	simpleVarNamePtr, isScalarPtr, line, clNext)
#endif
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Token *varTokenPtr;	/* Points to a variable token. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
    int flags;			/* takes TCL_CREATE_VAR or
				 * TCL_NO_LARGE_INDEX */
    int *localIndexPtr;		/* must not be NULL */
    int *simpleVarNamePtr;	/* must not be NULL */
    int *isScalarPtr;		/* must not be NULL */
#ifdef TCL_TIP280
    int line;                   /* line the token starts on */
    int* clNext;
#endif
{
    register CONST char *p;
    CONST char *name, *elName;
    register int i, n;
    int nameChars, elNameChars, simpleVarName, localIndex;
    int code = TCL_OK;

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

	if (elName != NULL) {
	    if (elNameChars) {
#ifdef TCL_TIP280
	        envPtr->line   = line;
	        envPtr->clNext = clNext;
#endif
		code = TclCompileTokens(interp, elemTokenPtr,
                        elemTokenCount, envPtr);
		if (code != TCL_OK) {
		    goto done;
		}
	    } else {
		TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
	    }
	}
    } else {
	/*
	 * The var name isn't simple: compile and push it.
	 */

#ifdef TCL_TIP280
        envPtr->line   = line;
        envPtr->clNext = clNext;
#endif
	code = TclCompileTokens(interp, varTokenPtr+1,
		varTokenPtr->numComponents, envPtr);
	if (code != TCL_OK) {
	    goto done;
	}
    }

/* 
 * 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.43.2.16 2009/08/25 20:59:10 andreas_kupries Exp $
 */

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

/*
 * Table of all AuxData types.

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


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

				 * allocated in frame. */
    LiteralTable *localTablePtr = &(compEnv.localLitTable);
    register AuxData *auxDataPtr;
    LiteralEntry *entryPtr;
    register int i;
    int length, nested, result;
    char *string;
#ifdef TCL_TIP280
    ContLineLoc* clLocPtr;
#endif
#ifdef TCL_COMPILE_DEBUG
    if (!traceInitialized) {
        if (Tcl_LinkVar(interp, "tcl_traceCompile",
	            (char *) &tclTraceCompile,  TCL_LINK_INT) != TCL_OK) {
            panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
        }
        traceInitialized = 1;

     * and use to initialize the tracking in the compiler. This information
     * was stored by TclCompEvalObj (tclExecute.c), and ProcCompileProc
     * (tclProc.c).
     */

    TclInitCompileEnv(interp, &compEnv, string, 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);
    }
#endif
    result = TclCompileScript(interp, string, length, nested, &compEnv);

    if (result == TCL_OK) {
	/*
	 * Successful compilation. Add a "done" instruction at the end.
	 */

		    Tcl_IncrRefCount (ctx.data.eval.path);
		}
	    }
	}

	/* ctx going out of scope */
    }

    /*
     * 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;
#endif

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

    }
    if (envPtr->mallocedCmdMap) {
	ckfree((char *) envPtr->cmdMapPtr);
    }
    if (envPtr->mallocedAuxDataArray) {
	ckfree((char *) envPtr->auxDataArrayPtr);
    }
#ifdef TCL_TIP280
    /*
     * 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);
    }
#endif
}

#ifdef TCL_TIP280
/*
 *----------------------------------------------------------------------
 *
 * TclWordKnownAtCompileTime --

    Tcl_DString ds;

#ifdef TCL_TIP280
    /* TIP #280 */
    ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr;
    int* wlines;
    int  wlineat, cmdLine;
    int* clNext;
#endif

    Tcl_DStringInit(&ds);

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

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

    p = script;
    bytesLeft = numBytes;
    gotParse = 0;
#ifdef TCL_TIP280
    cmdLine = envPtr->line;
    clNext  = envPtr->clNext;
#endif

    do {
	if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {
	    code = TCL_ERROR;
	    goto error;
	}

	    /* TIP #280. Scan the words and compute the extended location
	     * 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, parse.commandStart);
	    TclAdvanceContinuations (&cmdLine, &clNext,
				     parse.commandStart - envPtr->source);
	    EnterCmdWordData (eclPtr, (parse.commandStart - envPtr->source),
			      parse.tokenPtr, parse.commandStart,
			      parse.commandSize, parse.numWords,
			      cmdLine, clNext, &wlines, envPtr);
	    wlineat = eclPtr->nuloc - 1;
#endif

	    for (wordIdx = 0, tokenPtr = parse.tokenPtr;
		    wordIdx < parse.numWords;
		    wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
#ifdef TCL_TIP280
	        envPtr->line   = eclPtr->loc [wlineat].line [wordIdx];
		envPtr->clNext = eclPtr->loc [wlineat].next [wordIdx];
#endif
		if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		    /*
		     * If this is the first word and the command has a
		     * compile procedure, let it compile the command.
		     */

			 * 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);
#ifdef TCL_TIP280
			if (envPtr->clNext) {
			    TclContinuationsEnterDerived (envPtr->literalArrayPtr[objIndex].objPtr,
							  tokenPtr[1].start - envPtr->source,
							  eclPtr->loc [wlineat].next [wordIdx]);
			}
#endif
		    }
		    TclEmitPush(objIndex, envPtr);
		} else {
		    /*
		     * The word is not a simple string of characters.
		     */
		    code = TclCompileTokens(interp, tokenPtr+1,

	    isFirstCmd = 0;

#ifdef TCL_TIP280
	    /* 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;
#endif
	} /* end if parse.numWords > 0 */

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

	next = parse.commandStart + parse.commandSize;
	bytesLeft -= (next - p);
	p = next;
#ifdef TCL_TIP280
	/* TIP #280 : Track lines in the just compiled command */
	TclAdvanceLines         (&cmdLine, parse.commandStart, p);
	TclAdvanceContinuations (&cmdLine, &clNext, p - envPtr->source);
#endif
	Tcl_FreeParse(&parse);
	gotParse = 0;
	if (nested && (*parse.term == ']')) {
	    /*
	     * We get here in the special case where TCL_BRACKET_TERM was
	     * set in the interpreter and the latest parsed command was

    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, code;
    unsigned char *entryCodeNext = envPtr->codeNext;
#ifdef TCL_TIP280
#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
     * 'EvalTokensStandard()' (see file "tclBasic.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));
    }
#endif

    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, (int *) NULL,
			buffer);
		Tcl_DStringAppend(&textBuffer, buffer, length);

#ifdef TCL_TIP280
		/*
		 * 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 ++;
		    }
		}
#endif
		break;

	    case TCL_TOKEN_COMMAND:
		/*
		 * Push any accumulated chars appearing before the command.
		 */
		
		if (Tcl_DStringLength(&textBuffer) > 0) {
		    int literal;
		    
		    literal = TclRegisterLiteral(envPtr,
			    Tcl_DStringValue(&textBuffer),
			    Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
		    TclEmitPush(literal, envPtr);
		    numObjsToConcat++;
		    Tcl_DStringFree(&textBuffer);
#ifdef TCL_TIP280
		    if (numCL) {
			TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr,
					      numCL, clPosition);
		    }
		    numCL = 0;
#endif
		}
		
		code = TclCompileScript(interp, tokenPtr->start+1,
			tokenPtr->size-2, /*nested*/ 0,	envPtr);
		if (code != TCL_OK) {
		    goto error;
		}

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

	literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer),
	        Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
	TclEmitPush(literal, envPtr);
	numObjsToConcat++;

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

    /*
     * 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(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),
	        envPtr);
    }

    code = TCL_OK;

    error:
    Tcl_DStringFree(&textBuffer);
#ifdef TCL_TIP280
    /*
     * Release the temp table we used to collect the locations of
     * continuation lines, if any.
     */

    if (maxNumCL) {
	ckfree ((char*) clPosition);
    }
#endif
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileCmdWord --

 *	environment envPtr for the command at index cmdIndex. The
 *	compilation environment's ExtCmdLoc.ECL array is grown if necessary.
 *
 *----------------------------------------------------------------------
 */

static void
EnterCmdWordData(eclPtr, srcOffset, tokenPtr, cmd, len, numWords, line, clNext, wlines, envPtr)
    ExtCmdLoc *eclPtr;		/* Points to the map environment
				 * structure in which to enter command
				 * location 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;
    int         wordIdx;
    CONST char* last;
    int         wordLine;
    int*        wordNext;
    int*        wwlines;

    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).

	eclPtr->loc  = (ECL *) newPtr;
	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)
				? wordLine
				: -1);
	ePtr->line [wordIdx] = wordLine;
	ePtr->next [wordIdx] = wordNext;
	last = tokenPtr->start;
    }

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

/*
 * 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.33.2.8 2009/08/25 20:59:11 andreas_kupries Exp $
 */

#ifndef _TCLCOMPILATION
#define _TCLCOMPILATION 1

#ifndef _TCLINT
#include "tclInt.h"

 * information, like the path of a sourced file.
 */

typedef struct ECL {
  int  srcOffset; /* cmd 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 during compile, ICL tracking */
} ECL;

typedef struct ExtCmdLoc {
  int      type;  /* Context type */
  Tcl_Obj* path;  /* Path of the sourced file the command is in */
  ECL*     loc;   /* Command word locations (lines) */
  int      nloc;  /* Number of allocated entries in 'loc' */

#ifdef TCL_TIP280
    /* TIP #280 */
    ExtCmdLoc* extCmdMapPtr;    /* Extended command location information
				 * for 'info frame'. */
    int        line;            /* First line of the script, based on the
				 * invoking context, then the line of the
				 * command currently compiled. */
    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. */
#endif
} 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

/* 
 * tclExecute.c --
 *
 *	This file contains procedures that execute byte-compiled Tcl
 *	commands.
 *
 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * 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: tclExecute.c,v 1.94.2.30 2009/08/25 20:59:11 andreas_kupries Exp $
 */

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

#ifndef TCL_NO_MATH
#   include "tclMath.h"

	     * Finally, let TclEvalObjvInternal handle the command.
	     *
	     * TIP #280 : Record the last piece of info needed by
	     * 'TclGetSrcInfoForPc', and push the frame.
	     */

#ifdef TCL_TIP280
	    bcFrame.data.tebc.pc = (char*) pc;
	    iPtr->cmdFramePtr = &bcFrame;
	    TclArgumentBCEnter((Tcl_Interp*) iPtr, objv, objc,
			       codePtr, &bcFrame,
			       pc - codePtr->codeStart);
#endif
	    DECACHE_STACK_INFO();
	    Tcl_ResetResult(interp);

void
TclGetSrcInfoForPc (cfPtr)
     CmdFrame* cfPtr;
{
    ByteCode* codePtr = (ByteCode*) cfPtr->data.tebc.codePtr;

    if (cfPtr->cmd.str.cmd == NULL) {
        cfPtr->cmd.str.cmd = GetSrcInfoForPc((unsigned char*) cfPtr->data.tebc.pc,
					     codePtr,
					     &cfPtr->cmd.str.len);
    }

    if (cfPtr->cmd.str.cmd != NULL) {
        /* We now have the command. We can get the srcOffset back and
	 * from there find the list of word locations for this command

 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 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: tclInt.h,v 1.118.2.35 2009/08/25 20:59:11 andreas_kupries Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Common include files needed by most of the Tcl source files are

typedef struct CFWordBC {
    CmdFrame* framePtr;  /* CmdFrame to acess */
    int pc;   /* Instruction pointer of a command in ExtCmdLoc.loc[.] */
    int word; /* Index of word in ExtCmdLoc.loc[cmd]->{line,literal}[.] */
    struct CFWordBC* prevPtr;
} 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
 * EvalTokensStandard() in the file "tclBasic.c" and its caller EvalEx(), 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 CLL_END is put after the last
		 * location, as end-marker/sentinel. */
} ContLineLoc;

#endif /* TCL_TIP280 */

/*
 *----------------------------------------------------------------
 * Data structures and procedures related to TclHandles, which
 * are a very lightweight method of preserving enough information
 * to determine if an arbitrary malloc'd block has been deleted.

				 * 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.
				 */
#endif
#ifdef TCL_TIP268
    /*
     * TIP #268.
     * The currently active selection mode,
     * i.e the package require preferences.
     */

 * world:
 *----------------------------------------------------------------
 */

#ifdef TCL_TIP280
EXTERN void             TclAdvanceLines _ANSI_ARGS_((int* line, CONST char* start,
						     CONST char* end));
EXTERN void             TclAdvanceContinuations _ANSI_ARGS_((int* line, int** next,
						     int loc));
EXTERN ContLineLoc*     TclContinuationsEnter _ANSI_ARGS_((Tcl_Obj* objPtr, int num,
							   int* loc));
EXTERN void             TclContinuationsEnterDerived _ANSI_ARGS_((Tcl_Obj* objPtr,
								  int start, int* clNext));
EXTERN ContLineLoc*     TclContinuationsGet _ANSI_ARGS_((Tcl_Obj* objPtr));

EXTERN void         TclContinuationsCopy _ANSI_ARGS_((Tcl_Obj* objPtr, Tcl_Obj* originObjPtr));

#endif
EXTERN int		TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));
EXTERN int		TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *value));
EXTERN void		TclDeleteNamespaceVars _ANSI_ARGS_((Namespace *nsPtr));

#include "tclIntDecls.h"

# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLIMPORT

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

 * Copyright (c) 1999 by Scriptics Corporation.
 * Copyright (c) 2001 by ActiveState Corporation.
 * 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.42.2.17 2009/08/25 20:59:11 andreas_kupries Exp $
 */

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

/*

 * as the value of an empty string representation for an object. This value
 * is shared by all new objects allocated by Tcl_NewObj.
 */

char tclEmptyString = '\0';
char *tclEmptyStringRep = &tclEmptyString;


#ifdef TCL_TIP280
/*
 * 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.
			     */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

static void ContLineLocFree _ANSI_ARGS_((char* clientData));
static void TclThreadFinalizeObjects _ANSI_ARGS_((ClientData clientData));
static ThreadSpecificData* TclGetContinuationTable _ANSI_ARGS_(());
#endif

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

static int		SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static int		SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,

     * of releasing memory for us.
     */
    Tcl_MutexLock(&tclObjMutex);
    tclFreeObjList = NULL;
    Tcl_MutexUnlock(&tclObjMutex);
}

#ifdef TCL_TIP280
/*
 *----------------------------------------------------------------------
 *
 * TclGetContinuationTable --
 *
 *	This procedure is a helper which returns the thread-specific
 *	hash-table used to track continuation line information associated with
 *	Tcl_Obj*.
 *
 * Results:
 *	A reference to the continuation line thread-data.
 *
 * Side effects:
 *	May allocate memory for the thread-data.
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

static ThreadSpecificData*
TclGetContinuationTable()
{
    /*
     * 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);
    }
    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(objPtr,num,loc)
     Tcl_Obj* objPtr;
     int num;
     int* loc;
{
  int newEntry;
  ThreadSpecificData *tsdPtr = TclGetContinuationTable();
  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(objPtr, start, clNext)
     Tcl_Obj* objPtr;
     int start;
     int* clNext;
{
    /*
     * We have to handle invisible continuations lines here as well, despite
     * the code we have in EvalTokensStandard (ETS) for that. Why ?
     * Nesting. If our script is the sole argument to an 'eval' command, for
     * example, the scriptCLLocPtr we are using here was generated by a
     * previous call to ETS, and while the words we have here may contain
     * continuation lines they are invisible already, and the call to ETS
     * above 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 = TclGetContinuationTable();
    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(objPtr)
     Tcl_Obj* objPtr;
{
    ThreadSpecificData *tsdPtr = TclGetContinuationTable();
    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 clientData;
{
    /*
     * Release the hashtable tracking invisible continuation lines.
     */

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

    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 (clientData)
     char* clientData;
{
  ckfree (clientData);
}
#endif
/*
 *--------------------------------------------------------------
 *
 * Tcl_RegisterObjType --
 *
 *	This procedure is called to register a new Tcl object type
 *	in the table of all object types supported by Tcl.

#else 
    Tcl_MutexLock(&tclObjMutex);
    objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList;
    tclFreeObjList = objPtr;
    Tcl_MutexUnlock(&tclObjMutex);
#endif /* TCL_MEM_DEBUG */

#ifdef TCL_TIP280
    /*
     * 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
    TclIncrObjsFreed();
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DuplicateObj --

    }
    
    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
    objPtr->typePtr = &tclCmdNameType;
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

/* 
 * tclProc.c --
 *
 *	This file contains routines that implement Tcl procedures,
 *	including the "proc" and "uplevel" commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * 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.44.2.11 2009/08/25 20:59:11 andreas_kupries Exp $
 */

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

/*
 * Prototypes for static functions in this file

         * below). This 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)) {
#ifdef TCL_TIP280
	    Tcl_Obj* sharedBodyPtr = bodyPtr;
#endif
            bytes = Tcl_GetStringFromObj(bodyPtr, &length);
            bodyPtr = Tcl_NewStringObj(bytes, length);
#ifdef TCL_TIP280
	    /*
	     * 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);
#endif
        }

        /*
         * Create and initialize a Proc structure for the procedure. Note that
         * we initialize its cmdPtr field below after we've created the command
         * 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

 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * 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: tclVar.c,v 1.69.2.15 2009/08/25 20:59:11 andreas_kupries Exp $
 */

#include "tclInt.h"
#include "tclPort.h"


/*

	    if (oldValuePtr == NULL) {
		varPtr->value.objPtr = newValuePtr;
		Tcl_IncrRefCount(newValuePtr);
	    } else {
		if (Tcl_IsShared(oldValuePtr)) {   /* append to copy */
		    varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
#ifdef TCL_TIP280
		    /*
		     * TIP #280.
		     * Ensure that the continuation line data for the
		     * string is not lost and applies to the extended
		     * script as well.
		     */
		    TclContinuationsCopy (varPtr->value.objPtr, oldValuePtr);
#endif
		    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.24.2.13 2009/08/25 20:59:11 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",

    reduce [info frame 4]
} {type source line 785 file info.test cmd test\ info-22.7.1\ \{info\ frame,\ global,\ absolute\}\ \{tip280\ &&\ singleTe proc ::tcltest::runAllTests}

test info-22.8 {info frame, basic trace} -constraints {tip280} -match glob -body {
    join [lrange [etrace] 0 1] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 790 file info.test cmd etrace proc ::tcltest::RunTest}}

test info-23.0.0 {eval'd info frame} {tip280 && !singleTestInterp} {
    eval {info frame}
} 8
test info-23.0.1 {eval'd info frame} {tip280 && singleTestInterp} {
    eval {info frame}
} 11

test info-23.6 {eval'd info frame, trace} -constraints {tip280} -match glob -body {
    set script {etrace}
    join [lrange [eval $script] 0 2] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 834 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

proc bar {} {info frame 0}
test info-25.1 {info frame, regular proc} tip280 {
    reduce [bar]
} {type source line 941 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} {tip280} {
    if {1} {
	set res \
	    [reduce [info frame 0]];# line 952
    }
    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 952 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 res [::foo::bar]
    namespace delete ::foo
    join $res \n
} -result {
type source line 1214 file info.test cmd {info frame 0} proc ::foo::bar level 0
type source line 1215 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} {tip280} {
    proc abra {} {
	if {1} \
	    {
		return \
		    [reduce [info frame 0]];# line 1233
	    }
    }
    set res [abra]
    rename abra {}
    set res
} {type source line 1233 file info.test cmd {info frame 0} proc ::abra level 0}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

test info-30.17 {bs+nl in multi-body switch, direct} {tip280} {
    switch -regexp -- {key    } \
	^key     { reduce [info frame 0] ;# 1388 } \
        \t###    { } \
        {[0-9]*} { }
} {type source line 1388 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} {tip280} {
    proc abra {script} {
	append script "\n# end of script"
	uplevel 1 $script
    }
    set res [abra {
	return "\
[reduce [info frame 0]]";# line 1400, still line of 3 appended script
    }]
    rename abra {}
    set res
} { type eval line 3 cmd {info frame 0} proc ::abra}
# { type source line 1400 file info.test cmd {info frame 0} proc ::abra}

test info-30.19 {bs+nl in single-body switch, compiled} {tip280} {
    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 1411 file info.test cmd {info frame 0} proc ::a level 0
type source line 1415 file info.test cmd {info frame 0} proc ::a level 0}

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

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

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

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

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

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