Tcl Source Code

static Tcl_NRPostProc	TEOEx_ByteCodeCallback;
static Tcl_NRPostProc	TEOEx_ListCallback;
static Tcl_NRPostProc	TEOV_Error;
static Tcl_NRPostProc	TEOV_Exception;
static Tcl_NRPostProc	TEOV_NotFoundCallback;
static Tcl_NRPostProc	TEOV_RestoreVarFrame;
static Tcl_NRPostProc	TEOV_RunLeaveTraces;
static Tcl_NRPostProc	YieldToCallback;

static void	        ClearTailcall(Tcl_Interp *interp,
			    struct NRE_callback *tailcallPtr);
static Tcl_ObjCmdProc NRCoroInjectObjCmd;

MODULE_SCOPE const TclStubs tclStubs;

/*
 * Magical counts for the number of arguments accepted by a coroutine command
 * after particular kinds of [yield].

				 * here, otherwise the pointer to the
				 * requested Command struct to be invoked. */
{
    Interp *iPtr = (Interp *) interp;
    int result;
    Namespace *lookupNsPtr = iPtr->lookupNsPtr;
    Command **cmdPtrPtr;


    iPtr->lookupNsPtr = NULL;

    /*
     * Push a callback with cleanup tasks for commands; the cmdPtr at data[0]
     * will be filled later when the command is found: save its address at
     * objProcPtr.
     *
     * data[1] stores a marker for use by tailcalls; it will be set to 1 by
     * command redirectors (imports, alias, ensembles) so that tailcalls
     * finishes the source command and not just the target.
     */

    if (iPtr->evalFlags & TCL_EVAL_REDIRECT) {
	TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), INT2PTR(objc), objv);
	iPtr->evalFlags &= ~TCL_EVAL_REDIRECT;
    } else {
	TclNRAddCallback(interp, NRCommand, NULL, NULL, INT2PTR(objc), objv);

    }
    cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]);

    TclNRSpliceDeferred(interp);



    iPtr->numLevels++;
    result = TclInterpReady(interp);

    if ((result != TCL_OK) || (objc == 0)) {
	return result;
    }

    Command *cmdPtr = data[0];
    /* int cmdStart = PTR2INT(data[1]); NOT USED HERE */

    if (cmdPtr) {
	TclCleanupCommandMacro(cmdPtr);
    }
    ((Interp *)interp)->numLevels--;









    /* OPT ??
     * Do not interrupt a series of cleanups with async or limit checks:
     * just check at the end?
     */

    if (TclAsyncReady(iPtr)) {

	return TCL_ERROR;
    }

    if (lookupNsPtr) {
	savedNsPtr = varFramePtr->nsPtr;
	varFramePtr->nsPtr = lookupNsPtr;
    }

    TclNRDeferCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc),
	    newObjv, savedNsPtr, NULL);
    iPtr->evalFlags |= TCL_EVAL_REDIRECT;
    return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL);
}

static int
TEOV_NotFoundCallback(
    ClientData data[],
    Tcl_Interp *interp,

	    eoFramePtr->cmd.listPtr = listPtr;
	    eoFramePtr->data.eval.path = NULL;

	    iPtr->cmdFramePtr = eoFramePtr;
	}


	TclNRDeferCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
		NULL, NULL);

	ListObjGetElements(listPtr, objc, objv);
	return TclNREvalObjv(interp, objc, objv, flags, NULL);
    }

    if (!(flags & TCL_EVAL_DIRECT)) {

 *	 implementation does not (or does it? Changed, test!) - it causes an
 *	 error.
 *
 * FIXME NRE!
 */

void
















TclSpliceTailcall(
    Tcl_Interp *interp,
    NRE_callback *tailcallPtr)
{
    /*
     * Find the splicing spot: right before the NRCommand of the thing
     * being tailcalled. Note that we skip NRCommands marked in data[1]
     * (used by command redirectors).
     */

    NRE_callback *runPtr;

    for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
	if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
            break;
        }
    }
    if (!runPtr) {
        Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!");
    }

    tailcallPtr->nextPtr = runPtr->nextPtr;
    runPtr->nextPtr = tailcallPtr;
}

int
TclNRTailcallObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,

    /*
     * Invocation without args just clears a scheduled tailcall; invocation
     * with an argument replaces any previously scheduled tailcall.
     */

    if (iPtr->varFramePtr->tailcallPtr) {
        ClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
        iPtr->varFramePtr->tailcallPtr = NULL;
    }

    /*
     * Create the callback to actually evaluate the tailcalled
     * command, then set it in the varFrame so that PopCallFrame can use it
     * at the proper time. Being lazy: exploit the TclNRAddCallBack macro to
     * build the callback.
     */

    if (objc > 1) {
        Tcl_Obj *listPtr, *nsObjPtr;
        Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
        Tcl_Namespace *ns1Ptr;
        NRE_callback *tailcallPtr;



        listPtr = Tcl_NewListObj(objc-1, objv+1);
        Tcl_IncrRefCount(listPtr);

        nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
        if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
                || (nsPtr != ns1Ptr)) {
            Tcl_Panic("Tailcall failed to find the proper namespace");
        }
        Tcl_IncrRefCount(nsObjPtr);

        TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr,
                NULL, NULL);
        tailcallPtr = TOP_CB(interp);
        TOP_CB(interp) = tailcallPtr->nextPtr;
        iPtr->varFramePtr->tailcallPtr = tailcallPtr;
    }
    return TCL_RETURN;
}

int
TclNRTailcallEval(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *listPtr = data[0];
    Tcl_Obj *nsObjPtr = data[1];
    Tcl_Namespace *nsPtr;
    int objc;
    Tcl_Obj **objv;




    if (result == TCL_OK) {
	result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
    }

    if (result != TCL_OK) {
        /*
         * Tailcall execution was preempted, eg by an intervening catch or by
         * a now-gone namespace: cleanup and return.
         */

        TailcallCleanup(data, interp, result);
        return result;
    }

    /*
     * Perform the tailcall
     */


    TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL,NULL);
    iPtr->lookupNsPtr = (Namespace *) nsPtr;
    ListObjGetElements(listPtr, objc, objv);
    return TclNREvalObjv(interp, objc, objv, 0, NULL);
}

static int
TailcallCleanup(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_DecrRefCount((Tcl_Obj *) data[0]);
    Tcl_DecrRefCount((Tcl_Obj *) data[1]);
    return result;
}

static void
ClearTailcall(
    Tcl_Interp *interp,
    NRE_callback *tailcallPtr)
{
    TailcallCleanup(tailcallPtr->data, interp, TCL_OK);
    TCLNR_FREE(interp, tailcallPtr);
}


void
Tcl_NRAddCallback(
    Tcl_Interp *interp,
    Tcl_NRPostProc *postProcPtr,
    ClientData data0,
    ClientData data1,

    /*
     * Add the tailcall in the caller env, then just yield.
     *
     * This is essentially code from TclNRTailcallObjCmd
     */







    listPtr = Tcl_NewListObj(objc-1, objv+1);
    Tcl_IncrRefCount(listPtr);

    nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
    if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
	    || (nsPtr != ns1Ptr)) {
	Tcl_Panic("yieldto failed to find the proper namespace");
    }

    Tcl_IncrRefCount(nsObjPtr);

    /*
     * Add the callback in the caller's env, then instruct TEBC to yield.
     */

    iPtr->execEnvPtr = corPtr->callerEEPtr;
    TclNRAddCallback(interp, YieldToCallback, corPtr, listPtr, nsObjPtr,
	    NULL);
    iPtr->execEnvPtr = corPtr->eePtr;

    return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
}

static int
YieldToCallback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    /* CoroutineData *corPtr = data[0];*/
    Tcl_Obj *listPtr = data[1];
    ClientData nsPtr = data[2];
    NRE_callback *cbPtr;

    /*
     * yieldTo: invoke the command using tailcall tech.
     */

    TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsPtr, NULL, NULL);
    cbPtr = TOP_CB(interp);
    TOP_CB(interp) = cbPtr->nextPtr;

    TclSpliceTailcall(interp, cbPtr);
    return TCL_OK;
}

static int
RewindCoroutineCallback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{

    int i;

    if (parsePtr->numWords < 2 || parsePtr->numWords > 256
	    || envPtr->procPtr == NULL) {
	return TCL_ERROR;
    }



    for (i=1 ; i<parsePtr->numWords ; i++) {
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, i);
    }
    TclEmitInstInt1(	INST_TAILCALL, parsePtr->numWords-1,	envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileThrowCmd --

	    }
	}

	/*
	 * Hand off to the target command.
	 */

	iPtr->evalFlags |= TCL_EVAL_REDIRECT;
	return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN);
    }

  unknownOrAmbiguousSubcommand:
    /*
     * Have not been able to match the subcommand asked for with a real
     * subcommand that we export. See whether a handler has been registered

     * Now call the unknown handler. (We don't bother NRE-enabling this; deep
     * recursing through unknown handlers is horribly perverse.) Note that it
     * is always an error for an unknown handler to delete its ensemble; don't
     * do that!
     */

    Tcl_Preserve(ensemblePtr);
    ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
    result = Tcl_EvalObjv(interp, paramc, paramv, 0);
    if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unknown subcommand handler deleted its ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED",
		    NULL);

		INT2PTR(0), NULL, NULL);

	return TCL_OK;
    }

    case INST_TAILCALL: {
	Tcl_Obj *listPtr, *nsObjPtr;
        NRE_callback *tailcallPtr;

	opnd = TclGetUInt1AtPtr(pc+1);

	if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
	    TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "tailcall can only be called from a proc or lambda", -1));

	/*
	 * Push the evaluation of the called command into the NR callback
	 * stack.
	 */

	listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
	nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1);
	Tcl_IncrRefCount(listPtr);
	Tcl_IncrRefCount(nsObjPtr);
	TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr,
		NULL, NULL);

	/*
	 * Unstitch ourselves and do a [return].
	 */

	tailcallPtr = TOP_CB(interp);
	TOP_CB(interp) = tailcallPtr->nextPtr;
	iPtr->varFramePtr->tailcallPtr = tailcallPtr;

	result = TCL_RETURN;
	cleanup = opnd;
	goto processExceptionReturn;
    }

    case INST_DONE:
	if (tosPtr > initTosPtr) {

	}
	iPtr->ensembleRewrite.sourceObjs = objv;
	iPtr->ensembleRewrite.numRemovedObjs = opnd;
	iPtr->ensembleRewrite.numInsertedObjs = 1;
	DECACHE_STACK_INFO();
	pc += 6;
	TEBC_YIELD();

	TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL);
	iPtr->evalFlags |= TCL_EVAL_REDIRECT;

	return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN);

    /*
     * -----------------------------------------------------------------
     *	   Start of INST_LOAD instructions.
     *
     * WARNING: more 'goto' here than your doctor recommended! The different

				 * sets it, and it should only ever be set by
				 * the code that is pushing the frame. In that
				 * case, the code that sets it should also
				 * have some means of discovering what the
				 * meaning of the value is, which we do not
				 * specify. */
    LocalCache *localCachePtr;
    struct NRE_callback *tailcallPtr;
				/* NULL if no tailcall is scheduled */
} CallFrame;

#define FRAME_IS_PROC	0x1
#define FRAME_IS_LAMBDA 0x2
#define FRAME_IS_METHOD	0x4	/* The frame is a method body, and the frame's
				 * clientData field contains a CallContext

 *			code other than TCL_OK or TCL_ERROR; 0 means codes
 *			other than these should be turned into errors.
 */

#define TCL_ALLOW_EXCEPTIONS	4
#define TCL_EVAL_FILE		2
#define TCL_EVAL_CTX		8
#define TCL_EVAL_REDIRECT	16

/*
 * Flag bits for Interp structures:
 *
 * DELETED:		Non-zero means the interpreter has been deleted:
 *			don't process any more commands for it, and destroy
 *			the structure as soon as all nested invocations of

MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;

MODULE_SCOPE void  TclSpliceTailcall(Tcl_Interp *interp,
	               struct NRE_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

	callbackPtr->data[1] = (ClientData)(data1);			\
	callbackPtr->data[2] = (ClientData)(data2);			\
	callbackPtr->data[3] = (ClientData)(data3);			\
	callbackPtr->nextPtr = TOP_CB(interp);				\
	TOP_CB(interp) = callbackPtr;					\
    } while (0)

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

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

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

#if NRE_USE_SMALL_ALLOC
#define TCLNR_ALLOC(interp, ptr) \
    TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr))
#define TCLNR_FREE(interp, ptr)  TclSmallFreeEx((interp), (ptr))
#else
#define TCLNR_ALLOC(interp, ptr) \
    (ptr = ((ClientData) ckalloc(sizeof(NRE_callback))))

    /*
     * We are sending a 0-refCount obj, do not need a callback: it will be
     * cleaned up automatically. But we may need to clear the rootEnsemble
     * stuff ...
     */

    if (isRootEnsemble) {
	TclNRDeferCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
    }
    iPtr->evalFlags |= TCL_EVAL_REDIRECT;
    return Tcl_NREvalObj(interp, listPtr, flags);
}

static int
AliasObjCmd(
    ClientData clientData,	/* Alias record. */
    Tcl_Interp *interp,		/* Current interpreter. */

    if ((nsPtr->flags & NS_DYING)
	    && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) {
	Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
    }
    framePtr->nsPtr = NULL;

    if (framePtr->tailcallPtr) {
	TclSpliceTailcall(interp, framePtr->tailcallPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclPushStackFrame --

    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    ImportedCmdData *dataPtr = clientData;
    Command *realCmdPtr = dataPtr->realCmdPtr;

    ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
    return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
}

static int
InvokeImportedCmd(
    ClientData clientData,	/* Points to the imported command's
				 * ImportedCmdData structure. */