Tcl Source Code

2010-11-29 Alexandre Ferrieux  <[email protected]>

	* generic/tclBasic.c: Patch by Miguel, providing a
	  [::tcl::unsupported::inject coroname command args], which prepends
	  ("injects") arbitrary code to a suspented coro's future resumption.
	  Neat for debugging complex coros without heavy instrumentation.

2010-11-29  Kevin B. Kenny  <[email protected]>

	* generic/tclInt.decls:
	* generic/tclInt.h:
	* generic/tclStrToD.c:
	* generic/tclTest.c:
	* generic/tclTomMath.decls:

 * 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.470 2010/11/29 22:16:17 ferrieux Exp $
 */

#include "tclInt.h"
#include "tclOOInt.h"
#include "tclCompile.h"
#include "tommath.h"
#include <math.h>

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

    Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation",
	    Tcl_RepresentationCmd, NULL, NULL);

    Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL,
	    TclNRYieldToObjCmd, NULL, NULL);
    Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldm", NULL,
	    TclNRYieldObjCmd, INT2PTR(CORO_ACTIVATE_YIELDM), NULL);
    Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
	    NRCoroInjectObjCmd, NULL, NULL);
    
#ifdef USE_DTRACE
    /*
     * Register the tcl::dtrace command.
     */

    Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL);
#endif /* USE_DTRACE */

        corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;

        iPtr->execEnvPtr = corPtr->callerEEPtr;
        return TCL_OK;
    }
}


static int
NRCoroInjectObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Command *cmdPtr;
    CoroutineData *corPtr;
    ExecEnv *savedEEPtr = iPtr->execEnvPtr;
    
    /*
     * Usage more or less like tailcall:
     *   inject coroName cmd ?arg1 arg2 ...?
     */

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
	return TCL_ERROR;
    }

    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
    if ((!cmdPtr) || (cmdPtr->nreProc != NRInterpCoroutine)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj("can only inject a command into a coroutine", -1));
        return TCL_ERROR;
    }

    corPtr = (CoroutineData *) cmdPtr->objClientData;
    if (!COR_IS_SUSPENDED(corPtr)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj("can only inject a command into a suspended coroutine", -1));
        return TCL_ERROR;
    }

    /*
     * Add the callback to the coro's execEnv, so that it is the first thing
     * to happen when the coro is resumed
     */
    
    iPtr->execEnvPtr = corPtr->eePtr;
    Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);    
    iPtr->execEnvPtr = savedEEPtr;
    
    return TCL_OK;
}

int
NRInterpCoroutine(
    ClientData clientData,
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{