Tcl Source Code

2009-07-13  Andreas Kupries  <[email protected]>

	* generic/tclCompile.c (TclInitCompileEnv, EnterCmdWordIndex,
	TclCleanupByteCode, TclCompileScript):
	* generic/tclExecute.c (TclCompileObj, TclExecuteByteCode): 
	* tclCompile.h (ExtCmdLoc): 
	* tclInt.h (ExtIndex, CFWordBC, CmdFrame):
	* tclBasic.c (DeleteInterpProc, TclArgumentBCEnter,
	TclArgumentBCRelease, TclArgumentGet, SAVE_CONTEXT,
	RESTORE_CONTEXT, NRCoroutineExitCallback, TclNRCoroutineObjCmd):
	* generic/tclCmdAH.c (TclNRForObjCmd, TclNRForIterCallback,
	ForNextCallback):
	* generic/tclCmdMZ.c (TclNRWhileObjCmd):

	Extended the bytecode compiler initialization to recognize the
	compilation of whole files (NRE enabled 'source' command) and
	switch to the counting of absolute lines in that case.

	Further extended the bytecode compiler to track the start line in
	the generated information, and modified the bytecode execution to
	recompile an object if the location as per the calling context
	doesn't match the location saved in the bytecode. This part could
	be optimized more by using more memory to keep all possibilities
	which occur around, or by just adjusting the location information
	instead of a total recompile.

	Reworked the handling of literal command arguments in bytecode to
	be saved (compiler) and used (execution) per command (See the
	TCL_INVOKE_STK* instructions), and not per the whole bytecode.
	This, and the previous change remove the problems with location
	data caused by literal sharing (across whole files, but also proc
	bodies). Simplified the associated datastructures (ExtIndex is
	gone, as is the function EnterCmdWordIndex).

	The last change causes the hashtable 'lineLABCPtr' to be state
	which has to be kept per coroutine, like the CmdFrame stack.
	Reworked the coroutine support code to create, delete and switch
	the information as needed. Further reworked the tailcall command
	as well, it has to pop its own arguments when run in a bytecode
	context to keep a proper stack in 'lineLABCPtr'.

	Fixed the mishandling of line information in the NRE-enabled 'for'
	and 'while' commands introduced when both were made to share their
	iteration callbacks without taking into account that the loop body
	is found in different words of the command. Introduced a separate
	data structure to hold all the callback information, as we went
	over the limit of 4 direct client-data values for NRE callbacks.

	The above fixes [Bug 1605269].

2009-07-12  Donal K. Fellows  <[email protected]>

	* generic/tclCmdMZ.c (StringIndexCmd, StringEqualCmd, StringCmpCmd):
	* generic/tclExecute.c (TclExecuteByteCode): [Bug 2637173]: Factor out
	* generic/tclInt.h (TclIsPureByteArray):     the code to determine if
	* generic/tclUtil.c (TclStringMatchObj):     it is safe to work with
	byte arrays directly, so that we get the check correct _once_.

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

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

		ckfree((char *) eclPtr->loc[i].line);
	    }

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


	    Tcl_DeleteHashTable (&eclPtr->litInfo);


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

 *
 * TIP #280
 *----------------------------------------------------------------------
 */

void
TclArgumentBCEnter(
     Tcl_Interp* interp,
     Tcl_Obj*    objv[],
     int         objc,
     void*       codePtr,
     CmdFrame*   cfPtr,
     int         pc)
{
    Interp*        iPtr  = (Interp*) interp;

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

    if (hePtr) {
	ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
	hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, (char*) pc);



	if (hePtr) {
	    int  word;
	    int  cmd  = (int) Tcl_GetHashValue(hePtr);
	    ECL* ePtr = &eclPtr->loc[cmd];
	    CFWordBC* lastPtr = 0;



	    /*
	     * A few truths ...
	     * (1) ePtr->nline == objc
	     * (2) (ePtr->line[word] < 0) => !literal, for all words
	     * (3) (word == 0) => !literal

	     *
	     * Item (2) is why we can use objv to get the literals, and do not
	     * have to save them at compile time.
	     */

	    for (word = 1; word < objc; word++) {
		if (ePtr->line[word] >= 0) {
		    int isnew;
		    Tcl_HashEntry* hPtr =
			Tcl_CreateHashEntry (iPtr->lineLABCPtr,
					     (char*) objv[word], &isnew);
		    CFWordBC* cfwPtr = (CFWordBC*) ckalloc (sizeof (CFWordBC));

		    cfwPtr->framePtr = cfPtr;
		    cfwPtr->obj      = objv[word];
		    cfwPtr->pc       = pc;
		    cfwPtr->word     = word;
		    cfwPtr->nextPtr  = lastPtr;
		    lastPtr = cfwPtr;

		    if (isnew) {
			/*
			 * The word is not on the stack yet, remember the
			 * current location and initialize references.
			 */
			cfwPtr->prevPtr = NULL;
		    } else {
			/*
			 * The object is already on the stack, however it may
			 * have a different location now (literal sharing may
			 * map multiple location to a single Tcl_Obj*. Save
			 * the old information in the new structure.

			 */
			cfwPtr->prevPtr = (CFWordBC*) Tcl_GetHashValue(hPtr);
		    }



		    Tcl_SetHashValue (hPtr, cfwPtr);
		}
	    } /* for */

	    cfPtr->litarg = lastPtr;
	} /* if */
    } /* if */
}

/*
 *----------------------------------------------------------------------
 *
 * TclArgumentBCRelease --
 *

 * TIP #280
 *----------------------------------------------------------------------
 */

void
TclArgumentBCRelease(
     Tcl_Interp *interp,
     CmdFrame* cfPtr)
{
    Interp*   iPtr    = (Interp*) interp;
    CFWordBC* cfwPtr  = (CFWordBC*) cfPtr->litarg;


    while (cfwPtr) {
	CFWordBC* nextPtr = cfwPtr->nextPtr;

	Tcl_HashEntry* hPtr =


	    Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj);

	CFWordBC* xPtr = (CFWordBC*) Tcl_GetHashValue (hPtr);

	if (xPtr != cfwPtr) {

	    Tcl_Panic ("TclArgumentBC Enter/Release Mismatch");
	}

	if (cfwPtr->prevPtr) {
	    Tcl_SetHashValue(hPtr, cfwPtr->prevPtr);
	} else {
	    Tcl_DeleteHashEntry(hPtr);


	}

	ckfree((char *) cfwPtr);

	cfwPtr = nextPtr;
    }

    cfPtr->litarg = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclArgumentGet --
 *

     * Check if the Tcl_Obj has location information as a bytecode literal, in
     * that stack.
     */

    hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj);
    if (hPtr) {
	CFWordBC *cfwPtr = 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;
    }
}

/*
 *----------------------------------------------------------------------
 *

     * Add two callbacks: first the one to actually evaluate the tailcalled
     * command, then the one that signals TEBC to stash the first at its
     * proper place.
     *
     * Being lazy: add the callback, then remove it (to exploit the
     * TclNRAddCallBack macro to build the callback)
     */

    /*
     * In a bytecode execution context the engine has called
     * TclArgumentBCEnter() which, due to the tailcall, is not paired with a
     * regular TclArgumentBCRelease. Get rid of it on our own.
     */

    if (iPtr->cmdFramePtr->type == TCL_LOCATION_BC) {
	TclArgumentBCRelease (interp, iPtr->cmdFramePtr);
    }

    TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
    tailcallPtr = TOP_CB(interp);
    TOP_CB(interp) = tailcallPtr->nextPtr;

    TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_TAILCALL_TYPE), tailcallPtr, NULL, NULL);
    return TCL_OK;

			    Tcl_Interp *interp, int result);

static const CorContext NULL_CONTEXT = {NULL, NULL, NULL};

#define SAVE_CONTEXT(context)				\
    (context).framePtr = iPtr->framePtr;		\
    (context).varFramePtr = iPtr->varFramePtr;		\
    (context).cmdFramePtr = iPtr->cmdFramePtr;		\
    (context).lineLABCPtr = iPtr->lineLABCPtr

#define RESTORE_CONTEXT(context)			\
    iPtr->framePtr = (context).framePtr;		\
    iPtr->varFramePtr = (context).varFramePtr;		\
    iPtr->cmdFramePtr = (context).cmdFramePtr;		\
    iPtr->lineLABCPtr = (context).lineLABCPtr

#define iPtr ((Interp *) interp)

int
TclNRYieldObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,

    Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
    TclCleanupCommandMacro(cmdPtr);

    corPtr->eePtr->corPtr = NULL;
    TclDeleteExecEnv(corPtr->eePtr);
    corPtr->eePtr = NULL;

    SAVE_CONTEXT(corPtr->running);
    RESTORE_CONTEXT(corPtr->caller);

    NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr);
    NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr);
    iPtr->varFramePtr = corPtr->caller.varFramePtr;

    iPtr->execEnvPtr = corPtr->callerEEPtr;

    /*
     * #280.
     * Drop the coroutine-owned copy of the lineLABCPtr hashtable for literal
     * command arguments in bytecode.
     */

    Tcl_DeleteHashTable(corPtr->base.lineLABCPtr);
    ckfree((char *) corPtr->base.lineLABCPtr);
    corPtr->base.lineLABCPtr = NULL;

    return result;
}

static int
NRInterpCoroutine(
    ClientData clientData,
    Tcl_Interp *interp,		/* Current interpreter. */

	return TCL_ERROR;
    }
    framePtr->objc = objc-2;
    framePtr->objv = &objv[2];

    SAVE_CONTEXT(corPtr->base);
    corPtr->running = NULL_CONTEXT;

    /*
     * #280.
     * Provide the new coroutine with its own copy of the lineLABCPtr
     * hashtable for literal command arguments in bytecode. Note that that
     * CFWordBC chains are not duplicated, only the entrypoints to them. This
     * means that in the presence of coroutines each chain is potentially a
     * tree. Like the chain -> tree conversion of the CmdFrame stack.
     */

    {
	Tcl_HashSearch hSearch;
	Tcl_HashEntry* hePtr;

	corPtr->base.lineLABCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(corPtr->base.lineLABCPtr, TCL_ONE_WORD_KEYS);

	for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch);
	     hePtr;
	     hePtr = Tcl_NextHashEntry(&hSearch)) {
	    int isNew;
	    Tcl_HashEntry* newPtr =
		Tcl_CreateHashEntry(corPtr->base.lineLABCPtr,
		    (char *) Tcl_GetHashKey (iPtr->lineLABCPtr, hePtr),
		    &isNew);
	    Tcl_SetHashValue(newPtr, Tcl_GetHashValue(hePtr));
	}

	/*
	 * The new copy is immediately plugged interpreter for use by the
	 * first coroutine commands (see below). The interp's copy of the
	 * table is already saved, see the SAVE_CONTEXT found just above this
	 * whole code block. This also properly prepares us for the
	 * SAVE/RESTORE dances during yields which swizzle the pointers
	 * around.
	 */

	iPtr->lineLABCPtr = corPtr->base.lineLABCPtr;
    }

    /*
     * Eval things in 'uplevel #0', except for the very first command lookup
     * which should be looked up in caller's context.
     *
     * A better approach would use the lambda infrastructure, but it is a bit
     * clumsy for now: we have the "lambda is a nameless proc" hack, we'd need

/*
 * tclCmdAH.c --
 *
 *	This file contains the top-level command routines for most of the Tcl
 *	built-in commands whose names begin with the letters A to H.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdAH.c,v 1.117 2009/07/14 16:34:08 andreas_kupries Exp $
 */

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

/*

    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int result;
    Interp *iPtr = (Interp *) interp;
    ForIterData* iterPtr;

    if (objc != 5) {
	Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
	return TCL_ERROR;
    }

    /*
     * TIP #280. Make invoking context available to initial script.
     */

    result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
    if (result != TCL_OK) {
	if (result == TCL_ERROR) {
	    Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
	}
	return result;
    }

    TclSmallAllocEx (interp, sizeof(ForIterData), iterPtr);
    iterPtr->cond = objv[2];
    iterPtr->body = objv[4];
    iterPtr->next = objv[3];
    iterPtr->msg  = "\n    (\"for\" body line %d)";
    iterPtr->word = 4;

    TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL,

	    NULL, NULL);
    return TCL_OK;
}

int
TclNRForIterCallback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    ForIterData* iterPtr = data[0];
    Tcl_Obj *cond = iterPtr->cond;
    Tcl_Obj *body = iterPtr->body;
    Tcl_Obj *next = iterPtr->next;
    char *msg = iterPtr->msg;
    int value;

    if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
	goto done;
    }

    /*
     * We need to reset the result before passing it off to
     * Tcl_ExprBooleanObj. Otherwise, any error message will be appended
     * to the result of the last evaluation.
     */

    Tcl_ResetResult(interp);
    result = Tcl_ExprBooleanObj(interp, cond, &value);
    if (result != TCL_OK) {
	TclSmallFreeEx (interp, iterPtr);
	return result;
    }
    if (value) {
	/* TIP #280. */
	if (next) {
	    TclNRAddCallback(interp, ForNextCallback, iterPtr, NULL, NULL,
		    NULL);
	} else {
	    TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL,
		    NULL);
	}
	return TclNREvalObjEx(interp, body, 0, iPtr->cmdFramePtr, iterPtr->word);
    }

  done:
    switch (result) {
    case TCL_BREAK:
	result = TCL_OK;
    case TCL_OK:
	Tcl_ResetResult(interp);
	break;
    case TCL_ERROR:
	Tcl_AppendObjToErrorInfo(interp,
		Tcl_ObjPrintf(msg, Tcl_GetErrorLine(interp)));
    }
    TclSmallFreeEx (interp, iterPtr);
    return result;
}

static int
ForNextCallback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    ForIterData* iterPtr = data[0];

    Tcl_Obj *next = iterPtr->next;


    if ((result == TCL_OK) || (result == TCL_CONTINUE)) {
	/*
	 * TIP #280. Make invoking context available to next script.
	 *
	 * NRE: we let the next script run in a new TEBC instance, ie, it is
	 * not nr-enabled.
	 */

	result = TclEvalObjEx(interp, next, 0, iPtr->cmdFramePtr, 3);
	if ((result != TCL_BREAK) && (result != TCL_OK)) {
	    if (result == TCL_ERROR) {
		Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
		TclSmallFreeEx (interp, iterPtr);
	    }
	    return result;
	}
    }

    TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ForeachObjCmd, TclNRForeachCmd --

 * Copyright (c) 1998-2000 Scriptics Corporation.
 * Copyright (c) 2002 ActiveState Corporation.
 * Copyright (c) 2003 Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdMZ.c,v 1.185 2009/07/14 16:34:08 andreas_kupries Exp $
 */

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

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

int
TclNRWhileObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    ForIterData* iterPtr;

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

    /*
     * We reuse [for]'s callback, passing a NULL for the 'next' script.
     */

    TclSmallAllocEx (interp, sizeof(ForIterData), iterPtr);
    iterPtr->cond = objv[1];
    iterPtr->body = objv[2];
    iterPtr->next = NULL;
    iterPtr->msg  = "\n    (\"while\" body line %d)";
    iterPtr->word = 2;

    TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL,
	    NULL, NULL);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclListLines --

/*
 * 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.168 2009/07/14 16:34:08 andreas_kupries Exp $
 */

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

/*
 * Table of all AuxData types.

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



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

const Tcl_ObjType tclByteCodeType = {

		ckfree((char *) eclPtr->loc[i].line);
	    }

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



	    Tcl_DeleteHashTable (&eclPtr->litInfo);


	    ckfree((char *) eclPtr);
	    Tcl_DeleteHashEntry(hePtr);
	}
    }

    if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) {

     */

    envPtr->extCmdMapPtr = (ExtCmdLoc *) ckalloc(sizeof(ExtCmdLoc));
    envPtr->extCmdMapPtr->loc = NULL;
    envPtr->extCmdMapPtr->nloc = 0;
    envPtr->extCmdMapPtr->nuloc = 0;
    envPtr->extCmdMapPtr->path = NULL;
    Tcl_InitHashTable(&envPtr->extCmdMapPtr->litInfo, TCL_ONE_WORD_KEYS);



    if ((invoker == NULL) || (invoker->type == TCL_LOCATION_EVAL_LIST)) {
	/*
	 * Initialize the compiler for relative counting in case of a
	 * dynamic context.
	 */

	envPtr->line = 1;
	if (iPtr->evalFlags & TCL_EVAL_FILE) {
	    iPtr->evalFlags &= ~TCL_EVAL_FILE;
	    envPtr->extCmdMapPtr->type = TCL_LOCATION_SOURCE;

	    if (iPtr->scriptFile) {
		/*
		 * Normalization here, to have the correct pwd. Should have
		 * negligible impact on performance, as the norm should have
		 * been done already by the 'source' invoking us, and it
		 * caches the result.
		 */

		Tcl_Obj *norm = Tcl_FSGetNormalizedPath(interp, iPtr->scriptFile);

		if (norm == NULL) {
		    /*
		     * Error message in the interp result. No place to put
		     * it. And no place to serve the error itself to either.
		     * Fake a path, empty string.
		     */

		    TclNewLiteralStringObj(envPtr->extCmdMapPtr->path, "");
		} else {
		    envPtr->extCmdMapPtr->path = norm;
		}
	    } else {
		TclNewLiteralStringObj(envPtr->extCmdMapPtr->path, "");
	    }

	    Tcl_IncrRefCount(envPtr->extCmdMapPtr->path);
	} else {
	    envPtr->extCmdMapPtr->type =
		(envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC);
	}
    } else {
	/*
	 * Initialize the compiler using the context, making counting absolute
	 * to that context. Note that the context can be byte code execution.
	 * In that case we have to fill out the missing pieces (line, path,
	 * ...) which may make change the type as well.
	 */

		    Tcl_IncrRefCount(envPtr->extCmdMapPtr->path);
		}
	    }
	}

	TclStackFree(interp, ctxPtr);
    }

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

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

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







		}
		TclEmitPush(objIndex, envPtr);
	    } /* for loop */

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

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

		TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
		TclAdjustStackDepth((1-wordIdx), envPtr);
	    } else if (wordIdx > 0) {
		/*
		 * Save PC -> command map for the TclArgumentBC* functions.
		 */

		int isnew;
		Tcl_HashEntry* hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo,
			   (char*) (envPtr->codeNext - envPtr->codeStart), &isnew);
		Tcl_SetHashValue(hePtr, (char*) wlineat);

		if (wordIdx <= 255) {
		    TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
		} else {
		    TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
		}
	    }

	ePtr->line[wordIdx] = wordLine;
	last = tokenPtr->start;
    }

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


































/*
 *----------------------------------------------------------------------
 *
 * TclCreateExceptRange --
 *
 *	Procedure that allocates and initializes a new ExceptionRange

/*
 * 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.117 2009/07/14 16:34:08 andreas_kupries Exp $
 */

#ifndef _TCLCOMPILATION
#define _TCLCOMPILATION 1

#include "tclInt.h"

typedef struct ECL {
    int srcOffset;		/* Command location to find the entry. */
    int nline;                  /* Number of words in the command */
    int *line;			/* Line information for all words in the
				 * command. */
} ECL;



typedef struct ExtCmdLoc {
    int type;			/* Context type. */
    int start;                  /* Starting line for compiled script. Needed
				 * for the extended recompile check in
				 * tclCompileObj. */
    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'. */
    int nuloc;			/* Number of used entries in 'loc'. */
    Tcl_HashTable litInfo;      /* Indexed by bytecode 'PC', to have the
				 * information accessible per command and
				 * argument, not per whole bytecode. Value is
				 * index of command in 'loc', giving us the
				 * literals to associate with line information
				 * as command argument, see
				 * TclArgumentBCEnter() */
} ExtCmdLoc;

/*
 * CompileProcs need the ability to record information during compilation that
 * can be used by bytecode instructions during execution. The AuxData
 * structure provides this "auxiliary data" mechanism. An arbitrary number of
 * these structures can be stored in the ByteCode record (during compilation

 * Copyright (c) 2005-2007 by Donal K. Fellows.
 * Copyright (c) 2007 Daniel A. Steffen <[email protected]>
 * Copyright (c) 2006-2008 by Joe Mistachkin.  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.441 2009/07/14 16:34:08 andreas_kupries Exp $
 */

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

#include <math.h>

	     * environment! If not, recompile.
	     */

	    if (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr) {
		goto recompileObj;
	    }
	}

	/*
	 * #280.
	 * Literal sharing fix. This part of the fix is not required by 8.4
	 * nor 8.5, because they eval-direct any literals, so just saving the
	 * argument locations per command in bytecode is enough, embedded
	 * 'eval' commands, etc. get the correct information.
	 *
	 * But in 8.6 all the embedded script are compiled, and the resulting
	 * bytecode stored in the literal. Now the shared literal has bytecode
	 * with location data for _one_ particular location this literal is
	 * found at. If we get executed from a different location the bytecode
	 * has to be recompiled to get the correct locations. Not doing this
	 * will execute the saved bytecode with data for a different location,
	 * causing 'info frame' to point to the wrong place in the sources.
	 *
	 * Future optimizations ...
	 * (1) Save the location data (ExtCmdLoc) keyed by start line. In that
	 *     case we recompile once per location of the literal, but not
	 *     continously, because the moment we have all locations we do not
	 *     need to recompile any longer.
	 *
	 * (2) Alternative: Do not recompile, tell the execution engine the
	 *     offset between saved starting line and actual one. Then modify
	 *     the users to adjust the locations they have by this offset.
	 *
	 * (3) Alternative 2: Do not fully recompile, adjust just the location
	 *     information.
	 */

	{
	    Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
						     (char *) codePtr);
	    if (hePtr) {
		ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
		int redo = 0;

		if (invoker) {
		    CmdFrame *ctxPtr = (CmdFrame *) 
			TclStackAlloc(interp, sizeof(CmdFrame));
		    *ctxPtr = *invoker;

		    if (invoker->type == TCL_LOCATION_BC) {
			/*
			 * Note: Type BC => ctx.data.eval.path    is not used.
			 *			ctx.data.tebc.codePtr is used instead.
			 */

			TclGetSrcInfoForPc(ctxPtr);
			if (ctxPtr->type == TCL_LOCATION_SOURCE) {
			    /*
			     * The reference made by 'TclGetSrcInfoForPc' is dead.
			     */
			    Tcl_DecrRefCount(ctxPtr->data.eval.path);
			    ctxPtr->data.eval.path = NULL;
			}
		    }

		    if (word < ctxPtr->nline) {
			/*
			 * Note: We do not care if the line[word] is -1. This
			 * is a difference and requires a recompile (location
			 * changed from absolute to relative, literal is used
			 * fixed and through variable)
			 *
			 * Example:
			 * test info-32.0 using literal of info-24.8
			 *     (dict with ... vs           set body ...).
			 */
			redo = 
			    ((eclPtr->type == TCL_LOCATION_SOURCE) &&
			     (eclPtr->start != ctxPtr->line[word])) ||
			    ((eclPtr->type == TCL_LOCATION_BC)     &&
			     (ctxPtr->type == TCL_LOCATION_SOURCE))
			    ;
		    }

		    TclStackFree(interp, ctxPtr);
		}

		if (redo) {
		    goto recompileObj;
		}
	    }
	}

	/*
	 * Increment the code's ref count while it is being executed. If
	 * afterwards no references to it remain, free the code.
	 */

    runCompiledObj:

		? TCL_LOCATION_PREBC : TCL_LOCATION_BC);
	bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1);
	bcFramePtr->numLevels = iPtr->numLevels;
	bcFramePtr->framePtr = iPtr->framePtr;
	bcFramePtr->nextPtr = iPtr->cmdFramePtr;
	bcFramePtr->nline = 0;
	bcFramePtr->line = NULL;
	bcFramePtr->litarg = NULL;
	bcFramePtr->data.tebc.codePtr = codePtr;
	bcFramePtr->data.tebc.pc = NULL;
	bcFramePtr->cmd.str.cmd = NULL;
	bcFramePtr->cmd.str.len = 0;



	if (iPtr->execEnvPtr->rewind) {
	    result = TCL_ERROR;
	    goto abnormalReturn;
	}

    } else {
	/*
	 * Returning from a non-recursive call. State is already completely
	 * reset, now process the return.
	 */

	NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
	iPtr->cmdFramePtr = bcFramePtr->nextPtr;

	TclArgumentBCRelease((Tcl_Interp*) iPtr, bcFramePtr);

	/*
	 * If the CallFrame is marked as tailcalling, keep tailcalling
	 */

	if (iPtr->varFramePtr->tailcallPtr) {
	    if (catchTop != initCatchTop) {

	    /*
	     * Reset the instructionCount variable, since we're about to check
	     * for async stuff anyway while processing TclEvalObjv
	     */

	    instructionCount = 1;

	    TclArgumentBCEnter((Tcl_Interp*) iPtr, objv, objc,
			       codePtr, bcFramePtr, pc - codePtr->codeStart);

	    DECACHE_STACK_INFO();

	    result = TclNREvalObjv(interp, objc, objv,
		    (*pc == INST_EVAL_STK) ? 0 : TCL_EVAL_NOERR, NULL);
	    result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 1);
	    CACHE_STACK_INFO();

	    if (TOP_CB(interp) != bottomPtr->rootPtr) {
		NRE_ASSERT(result == TCL_OK);
		pc += pcAdjustment;
		goto nonRecursiveCallStart;
	    }

	    TclArgumentBCRelease((Tcl_Interp*) iPtr, bcFramePtr);

	    iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
	    NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr->nextPtr);

	    iPtr->execEnvPtr->bottomPtr = bottomPtr;

	    if (result == TCL_OK) {

		    "stack top %d < entry stack top %d\n",
		    (unsigned)(pc - codePtr->codeStart),
		    (unsigned) CURR_DEPTH, (unsigned) 0);
	    Tcl_Panic("TclExecuteByteCode execution failure: end stack top < start stack top");
	}
    }



    oldBottomPtr = bottomPtr->prevBottomPtr;
    iPtr->cmdFramePtr = bcFramePtr->nextPtr;
    TclStackFree(interp, bottomPtr);	/* free my stack */

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

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

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options.

    int numLevels;		/* Value of interp's numLevels when the frame
				 * was pushed. */
    int *line;			/* Lines the words of the command start on. */
    int nline;
    CallFrame *framePtr;	/* Procedure activation record, may be
				 * NULL. */
    struct CmdFrame *nextPtr;	/* Link to calling frame. */
    const struct CFWordBC* litarg; /* Link to set of literal arguments which
				    * have ben pushed on the lineLABCPtr stack
				    * by TclArgumentBCEnter().  These will be
				    * removed by TclArgumentBCRelease. */
    /*
     * Data needed for Eval vs TEBC
     *
     * EXECUTION CONTEXTS and usage of CmdFrame
     *
     * Field	  TEBC		  EvalEx	  EvalObjEx
     * =======	  ====		  ======	  =========

typedef struct CFWord {
    CmdFrame *framePtr;		/* CmdFrame to access. */
    int word;			/* Index of the word in the command. */
    int refCount;		/* Number of times the word is on the
				 * stack. */
} CFWord;

typedef struct CFWordBC {
    Tcl_Obj*         obj;       /* Back reference to hashtable key */
    CmdFrame *framePtr;		/* CmdFrame to access. */
    int pc;			/* Instruction pointer of a command in
				 * ExtCmdLoc.loc[.] */
    int word;			/* Index of word in
				 * ExtCmdLoc.loc[cmd]->line[.] */

    struct CFWordBC* prevPtr;   /* Previous entry in stack for same Tcl_Obj */
    struct CFWordBC* nextPtr;   /* Next entry for same command call. See
				 * CmdFrame litarg field for the list start. */



} CFWordBC;

/*
 * The following macros define the allowed values for the type field of the
 * CmdFrame structure above. Some of the values occur only in the extended
 * location data referenced via the 'baseLocPtr'.
 *

 * increasing addresses. The member stackPtr points to the stackItems of the
 * currently active execution stack.
 */

typedef struct CorContext {
    struct CallFrame *framePtr;
    struct CallFrame *varFramePtr;
    struct CmdFrame *cmdFramePtr;  /* See Interp.cmdFramePtr */
    Tcl_HashTable *lineLABCPtr;    /* See Interp.lineLABCPtr */
} CorContext;

typedef struct CoroutineData {
    struct Command *cmdPtr;	/* The command handle for the coroutine. */
    struct ExecEnv *eePtr;	/* The special execution environment (stacks,
				 * etc.) for the coroutine. */
    struct ExecEnv *callerEEPtr;/* The execution environment for the caller of

MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;

MODULE_SCOPE void TclClearTailcall(Tcl_Interp *interp,
	            struct TEOV_callback *tailcallPtr);

/*
 * This structure holds the data for the various iteration callbacks used to
 * NRE the 'for' and 'while' commands. We need a separate structure because we
 * have more than the 4 client data entries we can provide directly thorugh
 * the callback API. It is the 'word' information which puts us over the
 * limit. It is needed because the loop body is argument 4 of 'for' and
 * argument 2 of 'while'. Not providing the correct index confuses the #280
 * code. We TclSmallAlloc/Free this.
 */

typedef struct ForIterData {
    Tcl_Obj* cond; /* loop condition expression */
    Tcl_Obj* body; /* loop body */
    Tcl_Obj* next; /* loop step script, NULL for 'while' */
    char*    msg;  /* error message part */
    int      word; /* Index of the body script in the command */
} ForIterData;

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

MODULE_SCOPE int	TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    int flags);
MODULE_SCOPE void	TclPushTailcallPoint(Tcl_Interp *interp);
MODULE_SCOPE void	TclAdvanceLines(int *line, const char *start,
			    const char *end);
MODULE_SCOPE void	TclArgumentEnter(Tcl_Interp *interp,
			    Tcl_Obj *objv[], int objc, CmdFrame *cf);
MODULE_SCOPE void	TclArgumentRelease(Tcl_Interp *interp,
			    Tcl_Obj *objv[], int objc);
MODULE_SCOPE void	TclArgumentBCEnter(Tcl_Interp *interp,
			    Tcl_Obj* objv[], int objc,
			    void *codePtr, CmdFrame *cfPtr, int pc);
MODULE_SCOPE void	TclArgumentBCRelease(Tcl_Interp *interp,
			    CmdFrame *cfPtr);
MODULE_SCOPE void	TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj,
			    CmdFrame **cfPtrPtr, int *wordPtr);
MODULE_SCOPE int	TclArraySet(Tcl_Interp *interp,
			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj);
MODULE_SCOPE double	TclBignumToDouble(mp_int *bignum);
MODULE_SCOPE int	TclByteArrayMatch(const unsigned char *string,
			    int strLen, const unsigned char *pattern,

# 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.64 2009/07/14 16:34:09 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",

test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body {
    join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n
} -result {* {type source line 728 file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 1414 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest}
* {type source line 2298 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}}

# -------------------------------------------------------------------------
# literal sharing

test info-39.0 {location information not confused by literal sharing} -body {
    namespace eval ::foo {}
    proc ::foo::bar {} {
	lappend res {}
	lappend res [reduce [eval {info frame 0}]]
	lappend res [reduce [eval {info frame 0}]]
	return $res
    }
    set res [::foo::bar]
    namespace delete ::foo
    join $res \n
} -result {
type source line 1427 file info.test cmd {info frame 0} proc ::foo::bar level 0
type source line 1428 file info.test cmd {info frame 0} proc ::foo::bar level 0}

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

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