Tcl Source Code

Check-in [988bbef5f1]
Login
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment: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.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 988bbef5f1210c85109a439c6ccbb88beacd775d
User & Date: ferrieux 2010-11-29 22:16:16
Context
2010-11-29
22:22
ChangeLog typo. check-in: bc39db13b0 user: ferrieux tags: trunk
22:16
Patch by Miguel, providing a [::tcl::unsupported::inject coroname command args], which prepends ("in... check-in: 988bbef5f1 user: ferrieux tags: trunk
02:27
added missing casts that MSVC complained about and deleted unused variable check-in: 7c3fff6000 user: kennykb tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.







1
2
3
4
5
6
7






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

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







1
2
3
4
5
6
7
8
9
10
11
12
13
14
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:

Changes to generic/tclBasic.c.

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 * 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.469 2010/11/15 21:34:54 andreas_kupries Exp $
 */

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






|







12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 * Copyright (c) 2007 Daniel A. Steffen <[email protected]forge.net>
 * 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>
164
165
166
167
168
169
170

171
172
173
174
175
176
177
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);


MODULE_SCOPE const TclStubs tclStubs;

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






>







164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
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].
 */
824
825
826
827
828
829
830


831
832
833
834
835
836
837
838
    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);



#ifdef USE_DTRACE
    /*
     * Register the tcl::dtrace command.
     */

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






>
>
|







825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
    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 */
8752
8753
8754
8755
8756
8757
8758














































8759
8760
8761
8762
8763
8764
8765
        corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;

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














































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






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







8755
8756
8757
8758
8759
8760
8761
8762
8763
8764
8765
8766
8767
8768
8769
8770
8771
8772
8773
8774
8775
8776
8777
8778
8779
8780
8781
8782
8783
8784
8785
8786
8787
8788
8789
8790
8791
8792
8793
8794
8795
8796
8797
8798
8799
8800
8801
8802
8803
8804
8805
8806
8807
8808
8809
8810
8811
8812
8813
8814
        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. */
{