* generic/tclBasic.c (InfoCoroutine):

	* tests/unsupported.test: new command that returns the
	FQN of the currently executing coroutine. Lives as infoCoroutine
	under unsupported, but is designed to become a subcommand of [info]

1 files changed, 32 insertions, 1 deletions

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index a710857..68700c8 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,7 @@
  * 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.364 2008/08/25 13:22:04 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.365 2008/08/26 22:37:02 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -140,6 +140,9 @@ static Tcl_NRPostProc   NRRunObjProc;
 static Tcl_NRPostProc	AtProcExitCleanup;
 static Tcl_NRPostProc   NRAtProcExitEval;
 
+static int		InfoCoroutineCmd(ClientData dummy, Tcl_Interp *interp, 
+			    int objc, Tcl_Obj *const objv[]);
+
 /*
  * The following structure define the commands in the Tcl core.
  */
@@ -792,6 +795,8 @@ Tcl_CreateInterp(void)
 	    /*objProc*/ NULL, TclNRCoroutineObjCmd, NULL, NULL);
     Tcl_NRCreateCommand(interp, "::tcl::unsupported::yield",
 	    /*objProc*/ NULL, TclNRYieldObjCmd, NULL, NULL);
+    Tcl_NRCreateCommand(interp, "::tcl::unsupported::infoCoroutine",
+	    /*objProc*/ NULL, InfoCoroutineCmd, NULL, NULL);
 
 #ifdef USE_DTRACE
     /*
@@ -8459,6 +8464,32 @@ TclNRCoroutineObjCmd(
     return TclNRRunCallbacks(interp,
 	    TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0), rootPtr, 0);
 }
+
+/*
+ * This belongs in the [info] ensemble later on
+ */
+
+static int
+InfoCoroutineCmd(
+    ClientData dummy,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    CoroutineData *corPtr = ((Interp *)interp)->execEnvPtr->corPtr;
+
+    if (corPtr) {
+	Tcl_Command cmd = (Tcl_Command) corPtr->cmdPtr;
+	Tcl_Obj *namePtr;
+
+	TclNewObj(namePtr);
+	Tcl_GetCommandFullName(interp, cmd, namePtr);
+	Tcl_SetObjResult(interp, namePtr);
+    }
+    return TCL_OK;
+}
+
+
 
 /*
  * Local Variables: