Add a new command, ::tcl::unsupported::disassemble

6 files changed, 406 insertions, 166 deletions

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index f06c029..69f1e98 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -14,7 +14,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.269 2007/09/14 14:58:07 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.270 2007/09/25 20:27:17 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -472,12 +472,12 @@ Tcl_CreateInterp(void)
     /*
      * Initialise the tables for variable traces and searches *before*
      * creating the global ns - so that the trace on errorInfo can be
-     * recorded. 
+     * recorded.
      */
-    
+
     Tcl_InitHashTable(&iPtr->varTraces, TCL_ONE_WORD_KEYS);
     Tcl_InitHashTable(&iPtr->varSearches, TCL_ONE_WORD_KEYS);
-        
+
     iPtr->globalNsPtr = NULL;		/* Force creation of global ns below */
     iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
 	    (ClientData) NULL, NULL);
@@ -656,6 +656,13 @@ Tcl_CreateInterp(void)
     Tcl_CreateObjCommand(interp, "::tcl::Bgerror",
 	    TclDefaultBgErrorHandlerObjCmd, NULL, NULL);
 
+    /*
+     * Create an unsupported command for debugging bytecode.
+     */
+
+    Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
+	    Tcl_DisassembleObjCmd, NULL, NULL);
+
 #ifdef USE_DTRACE
     /*
      * Register the tcl::dtrace command.
@@ -3386,7 +3393,7 @@ TclInterpReady(
 	Tcl_ResetResult(interp);
 	Tcl_AppendResult(interp,
 		"attempt to call eval in deleted interpreter", NULL);
-	Tcl_SetErrorCode(interp, "CORE", "IDELETE",
+	Tcl_SetErrorCode(interp, "TCL", "IDELETE",
 		"attempt to call eval in deleted interpreter", NULL);
 	return TCL_ERROR;
     }
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 67f8961..5c5831b 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCompCmds.c,v 1.119 2007/09/11 14:47:41 msofer Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.120 2007/09/25 20:27:17 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -138,15 +138,18 @@
 static ClientData	DupDictUpdateInfo(ClientData clientData);
 static void		FreeDictUpdateInfo(ClientData clientData);
 static void		PrintDictUpdateInfo(ClientData clientData,
-			    ByteCode *codePtr, unsigned int pcOffset);
+			    Tcl_Obj *appendObj, ByteCode *codePtr,
+			    unsigned int pcOffset);
 static ClientData	DupForeachInfo(ClientData clientData);
 static void		FreeForeachInfo(ClientData clientData);
 static void		PrintForeachInfo(ClientData clientData,
-			    ByteCode *codePtr, unsigned int pcOffset);
+			    Tcl_Obj *appendObj, ByteCode *codePtr,
+			    unsigned int pcOffset);
 static ClientData	DupJumptableInfo(ClientData clientData);
 static void		FreeJumptableInfo(ClientData clientData);
 static void		PrintJumptableInfo(ClientData clientData,
-			    ByteCode *codePtr, unsigned int pcOffset);
+			    Tcl_Obj *appendObj, ByteCode *codePtr,
+			    unsigned int pcOffset);
 static int		PushVarName(Tcl_Interp *interp,
 			    Tcl_Token *varTokenPtr, CompileEnv *envPtr,
 			    int flags, int *localIndexPtr,
@@ -1140,6 +1143,7 @@ FreeDictUpdateInfo(
 static void
 PrintDictUpdateInfo(
     ClientData clientData,
+    Tcl_Obj *appendObj,
     ByteCode *codePtr,
     unsigned int pcOffset)
 {
@@ -1148,9 +1152,9 @@ PrintDictUpdateInfo(
 
     for (i=0 ; i<duiPtr->length ; i++) {
 	if (i) {
-	    fprintf(stdout, ", ");
+	    Tcl_AppendToObj(appendObj, ", ", -1);
 	}
-	fprintf(stdout, "%%v%u", duiPtr->varIndices[i]);
+	Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]);
     }
 }
 
@@ -1787,6 +1791,7 @@ FreeForeachInfo(
 static void
 PrintForeachInfo(
     ClientData clientData,
+    Tcl_Obj *appendObj,
     ByteCode *codePtr,
     unsigned int pcOffset)
 {
@@ -1794,29 +1799,32 @@ PrintForeachInfo(
     register ForeachVarList *varsPtr;
     int i, j;
 
-    fprintf(stdout, "data=[");
+    Tcl_AppendToObj(appendObj, "data=[", -1);
 
     for (i=0 ; i<infoPtr->numLists ; i++) {
 	if (i) {
-	    fprintf(stdout, ", ");
+	    Tcl_AppendToObj(appendObj, ", ", -1);
 	}
-	fprintf(stdout, "%%v%u", (unsigned) (infoPtr->firstValueTemp + i));
+	Tcl_AppendPrintfToObj(appendObj, "%%v%u",
+		(unsigned) (infoPtr->firstValueTemp + i));
     }
-    fprintf(stdout, "], loop=%%v%u", (unsigned) infoPtr->loopCtTemp);
+    Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u",
+	    (unsigned) infoPtr->loopCtTemp);
     for (i=0 ; i<infoPtr->numLists ; i++) {
 	if (i) {
-	    fprintf(stdout, ",");
+	    Tcl_AppendToObj(appendObj, ",", -1);
 	}
-	fprintf(stdout, "\n\t\t it%%v%u\t[",
+	Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%u\t[",
 		(unsigned) (infoPtr->firstValueTemp + i));
 	varsPtr = infoPtr->varLists[i];
 	for (j=0 ; j<varsPtr->numVars ; j++) {
 	    if (j) {
-		fprintf(stdout, ", ");
+		Tcl_AppendToObj(appendObj, ", ", -1);
 	    }
-	    fprintf(stdout, "%%v%u", (unsigned) varsPtr->varIndexes[j]);
+	    Tcl_AppendPrintfToObj(appendObj, "%%v%u",
+		    (unsigned) varsPtr->varIndexes[j]);
 	}
-	fprintf(stdout, "]");
+	Tcl_AppendToObj(appendObj, "]", -1);
     }
 }
 
@@ -4305,6 +4313,7 @@ FreeJumptableInfo(
 static void
 PrintJumptableInfo(
     ClientData clientData,
+    Tcl_Obj *appendObj,
     ByteCode *codePtr,
     unsigned int pcOffset)
 {
@@ -4320,12 +4329,13 @@ PrintJumptableInfo(
 	offset = PTR2INT(Tcl_GetHashValue(hPtr));
 
 	if (i++) {
-	    fprintf(stdout, ", ");
+	    Tcl_AppendToObj(appendObj, ", ", -1);
 	    if (i%4==0) {
-		fprintf(stdout, "\n\t\t");
+		Tcl_AppendToObj(appendObj, "\n\t\t", -1);
 	    }
 	}
-	fprintf(stdout, "\"%s\"->pc %d", keyPtr, pcOffset + offset);
+	Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d",
+		keyPtr, pcOffset + offset);
     }
 }
 
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 6ae3aaf..d4c5d9e 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
  * 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.133 2007/09/11 14:47:42 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.134 2007/09/25 20:27:17 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -376,10 +376,10 @@ InstructionDesc tclInstructionTable[] = {
          /* finds level and otherName in stack, links to local variable at
 	  * index op1. Leaves the level on stack. */
     {"nsupvar",          5,     0,        1,   {OPERAND_LVT4}},
-         /* finds namespace and otherName in stack, links to local variable at 
+         /* finds namespace and otherName in stack, links to local variable at
 	  * index op1. Leaves the namespace on stack. */
     {"variable",         5,     0,        1,   {OPERAND_LVT4}},
-         /* finds namespace and otherName in stack, links to local variable at 
+         /* finds namespace and otherName in stack, links to local variable at
 	  * index op1. Leaves the namespace on stack. */
     {"syntax",	 	 9,   -1,         2,	{OPERAND_INT4, OPERAND_UINT4}},
 	/* Compiled bytecodes to signal syntax error. */
@@ -407,6 +407,10 @@ static void		RecordByteCodeStats(ByteCode *codePtr);
 #endif /* TCL_COMPILE_STATS */
 static int		SetByteCodeFromAny(Tcl_Interp *interp,
 			    Tcl_Obj *objPtr);
+static int		FormatInstruction(ByteCode *codePtr,
+			    unsigned char *pc, Tcl_Obj *bufferObj);
+static void		PrintSourceToObj(Tcl_Obj *appendObj,
+			    const char *stringPtr, int maxChars);
 /*
  * TIP #280: Helper for building the per-word line information of all compiled
  * commands.
@@ -720,7 +724,7 @@ TclCleanupByteCode(
      * 1) decrement the ref counts of the LiteralEntry's in its literal array,
      * 2) call the free procs for the auxiliary data items, 3) free the
      * localCache if it is unused, and finally 4) free the ByteCode
-     * structure's heap object. 
+     * structure's heap object.
      *
      * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, like
      * those generated from tbcload) is special, as they doesn't make use of
@@ -916,7 +920,7 @@ TclInitCompileEnv(
 
 	    ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
 	    *ctxPtr = *invoker;
-	    
+
 	    if (invoker->type == TCL_LOCATION_BC) {
 		/*
 		 * Note: Type BC => ctx.data.eval.path    is not used.
@@ -1162,7 +1166,7 @@ TclCompileScript(
 	if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) {
 
 	    /* Compile bytecodes to report the parse error at runtime. */
-	    Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, 
+	    Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
 		    /* Drop the command terminator (";","]") if appropriate */
 		    (parsePtr->term ==
 		    parsePtr->commandStart + parsePtr->commandSize - 1)?
@@ -1330,7 +1334,7 @@ TclCompileScript(
 			 * case. [Bug 1752146]
 			 * Note that the environment is initialised with
 			 * atCmdStart=1 to avoid emitting ISC for the first
-			 * command. 
+			 * command.
 			 */
 
 			if (envPtr->atCmdStart) {
@@ -1341,9 +1345,9 @@ TclCompileScript(
 				 * this depends on the exact layout of the
 				 * INST_START_CMD's operands, so be careful!
 				 */
-				
+
 				unsigned char *fixPtr = envPtr->codeNext - 4;
-				
+
 				TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)+1,
 					fixPtr);
 			    }
@@ -1828,7 +1832,7 @@ TclCompileExprWords(
  * Side effects:
  *	Instructions are added to envPtr to execute a no-op at runtime. No
  *      result is pushed onto the stack: the compiler has to take care of this
- *      itself if the last compiled command is a NoOp. 
+ *      itself if the last compiled command is a NoOp.
  *
  *----------------------------------------------------------------------
  */
@@ -3207,15 +3211,135 @@ TclPrintByteCodeObj(
     Tcl_Interp *interp,		/* Used only for Tcl_GetStringFromObj. */
     Tcl_Obj *objPtr)		/* The bytecode object to disassemble. */
 {
-    ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+    Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr);
+
+    fprintf(stdout, "\n%s", TclGetString(bufPtr));
+    Tcl_DecrRefCount(bufPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintInstruction --
+ *
+ *	This procedure prints ("disassembles") one instruction from a bytecode
+ *	object to stdout.
+ *
+ * Results:
+ *	Returns the length in bytes of the current instruiction.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclPrintInstruction(
+    ByteCode *codePtr,		/* Bytecode containing the instruction. */
+    unsigned char *pc)		/* Points to first byte of instruction. */
+{
+    Tcl_Obj *bufferObj;
+
+    TclNewObj(bufferObj);
+    FormatInstruction(codePtr, pc, bufferObj);
+    fprintf(stdout, "%s", TclGetString(bufferObj));
+    Tcl_DecrRefCount(bufferObj);
+    return numBytes;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintObject --
+ *
+ *	This procedure prints up to a specified number of characters from the
+ *	argument Tcl object's string representation to a specified file.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Outputs characters to the specified file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPrintObject(
+    FILE *outFile,		/* The file to print the source to. */
+    Tcl_Obj *objPtr,		/* Points to the Tcl object whose string
+				 * representation should be printed. */
+    int maxChars)		/* Maximum number of chars to print. */
+{
+    char *bytes;
+    int length;
+
+    bytes = Tcl_GetStringFromObj(objPtr, &length);
+    TclPrintSource(outFile, bytes, TclMin(length, maxChars));
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintSource --
+ *
+ *	This procedure prints up to a specified number of characters from the
+ *	argument string to a specified file. It tries to produce legible
+ *	output by adding backslashes as necessary.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Outputs characters to the specified file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPrintSource(
+    FILE *outFile,		/* The file to print the source to. */
+    const char *stringPtr,	/* The string to print. */
+    int maxChars)		/* Maximum number of chars to print. */
+{
+    Tcl_Obj *bufferObj;
+
+    TclNewObj(bufferObj);
+    PrintSourceToObj(bufferObj, stringPtr, maxChars);
+    fprintf(outFile, TclGetString(bufferObj));
+    Tcl_DecrRefCount(bufferObj);
+}
+#endif /* TCL_COMPILE_DEBUG */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclDisassembleByteCodeObj --
+ *
+ *	Given an object which is of bytecode type, return a disassembled
+ *	version of the bytecode (in a new refcount 0 object). No guarantees
+ *	are made about the details of the contents of the result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclDisassembleByteCodeObj(
+    Tcl_Obj *objPtr)		/* The bytecode object to disassemble. */
+{
+    ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
     unsigned char *codeStart, *codeLimit, *pc;
     unsigned char *codeDeltaNext, *codeLengthNext;
     unsigned char *srcDeltaNext, *srcLengthNext;
     int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i;
     Interp *iPtr = (Interp *) *codePtr->interpHandle;
+    Tcl_Obj *bufferObj;
+    char ptrBuf1[20], ptrBuf2[20];
 
+    TclNewObj(bufferObj);
     if (codePtr->refCount <= 0) {
-	return;			/* already freed */
+	return bufferObj;	/* Already freed. */
     }
 
     codeStart = codePtr->codeStart;
@@ -3226,14 +3350,17 @@ TclPrintByteCodeObj(
      * Print header lines describing the ByteCode.
      */
 
-    fprintf(stdout,
-	    "\nByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n",
-	    codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
+    sprintf(ptrBuf1, "%p", codePtr);
+    sprintf(ptrBuf2, "%p", iPtr);
+    Tcl_AppendPrintfToObj(bufferObj,
+	    "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n",
+	    ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2,
 	    iPtr->compileEpoch);
-    fprintf(stdout, "  Source ");
-    TclPrintSource(stdout, codePtr->source,
+    Tcl_AppendToObj(bufferObj, "  Source ", -1);
+    PrintSourceToObj(bufferObj, codePtr->source,
 	    TclMin(codePtr->numSrcBytes, 55));
-    fprintf(stdout, "\n  Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
+    Tcl_AppendPrintfToObj(bufferObj,
+	    "\n  Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
 	    numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
 	    codePtr->numLitObjects, codePtr->numAuxDataItems,
 	    codePtr->maxStackDepth,
@@ -3244,7 +3371,7 @@ TclPrintByteCodeObj(
 	    0.0);
 
 #ifdef TCL_COMPILE_STATS
-    fprintf(stdout,
+    Tcl_AppendPrintfToObj(bufferObj,
 	    "  Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n",
 	    (unsigned long) codePtr->structureSize,
 	    (unsigned long) (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
@@ -3264,14 +3391,18 @@ TclPrintByteCodeObj(
     if (codePtr->procPtr != NULL) {
 	Proc *procPtr = codePtr->procPtr;
 	int numCompiledLocals = procPtr->numCompiledLocals;
-	fprintf(stdout,
-		"  Proc 0x%p, refCt %d, args %d, compiled locals %d\n",
-		procPtr, procPtr->refCount, procPtr->numArgs,
+
+	sprintf(ptrBuf1, "%p", procPtr);
+	Tcl_AppendPrintfToObj(bufferObj,
+		"  Proc 0x%s, refCt %d, args %d, compiled locals %d\n",
+		ptrBuf1, procPtr->refCount, procPtr->numArgs,
 		numCompiledLocals);
 	if (numCompiledLocals > 0) {
 	    CompiledLocal *localPtr = procPtr->firstLocalPtr;
+
 	    for (i = 0;  i < numCompiledLocals;  i++) {
-		fprintf(stdout, "      slot %d%s%s%s%s%s%s", i,
+		Tcl_AppendPrintfToObj(bufferObj,
+			"      slot %d%s%s%s%s%s%s", i,
 			(localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar",
 			(localPtr->flags & VAR_ARRAY) ? ", array" : "",
 			(localPtr->flags & VAR_LINK) ? ", link" : "",
@@ -3279,9 +3410,10 @@ TclPrintByteCodeObj(
 			(localPtr->flags & VAR_TEMPORARY) ? ", temp" : "",
 			(localPtr->flags & VAR_RESOLVED) ? ", resolved" : "");
 		if (TclIsVarTemporary(localPtr)) {
-		    fprintf(stdout, "\n");
+		    Tcl_AppendToObj(bufferObj, "\n", -1);
 		} else {
-		    fprintf(stdout, ", \"%s\"\n", localPtr->name);
+		    Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n",
+			    localPtr->name);
 		}
 		localPtr = localPtr->nextPtr;
 	    }
@@ -3293,25 +3425,28 @@ TclPrintByteCodeObj(
      */
 
     if (codePtr->numExceptRanges > 0) {
-	fprintf(stdout, "  Exception ranges %d, depth %d:\n",
+	Tcl_AppendPrintfToObj(bufferObj, "  Exception ranges %d, depth %d:\n",
 		codePtr->numExceptRanges, codePtr->maxExceptDepth);
 	for (i = 0;  i < codePtr->numExceptRanges;  i++) {
 	    ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]);
-	    fprintf(stdout, "      %d: level %d, %s, pc %d-%d, ",
+
+	    Tcl_AppendPrintfToObj(bufferObj,
+		    "      %d: level %d, %s, pc %d-%d, ",
 		    i, rangePtr->nestingLevel,
 		    (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"),
 		    rangePtr->codeOffset,
 		    (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
 	    switch (rangePtr->type) {
 	    case LOOP_EXCEPTION_RANGE:
-		fprintf(stdout,	"continue %d, break %d\n",
+		Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n",
 			rangePtr->continueOffset, rangePtr->breakOffset);
 		break;
 	    case CATCH_EXCEPTION_RANGE:
-		fprintf(stdout,	"catch %d\n", rangePtr->catchOffset);
+		Tcl_AppendPrintfToObj(bufferObj, "catch %d\n",
+			rangePtr->catchOffset);
 		break;
 	    default:
-		Tcl_Panic("TclPrintByteCodeObj: bad ExceptionRange type %d",
+		Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d",
 			rangePtr->type);
 	    }
 	}
@@ -3325,10 +3460,10 @@ TclPrintByteCodeObj(
     if (numCmds == 0) {
 	pc = codeStart;
 	while (pc < codeLimit) {
-	    fprintf(stdout, "    ");
-	    pc += TclPrintInstruction(codePtr, pc);
+	    Tcl_AppendToObj(bufferObj, "    ", -1);
+	    pc += FormatInstruction(codePtr, pc, bufferObj);
 	}
-	return;
+	return bufferObj;
     }
 
     /*
@@ -3336,7 +3471,7 @@ TclPrintByteCodeObj(
      * for each command. These are encoded as a sequence of bytes.
      */
 
-    fprintf(stdout, "  Commands %d:", numCmds);
+    Tcl_AppendPrintfToObj(bufferObj, "  Commands %d:", numCmds);
     codeDeltaNext = codePtr->codeDeltaStart;
     codeLengthNext = codePtr->codeLengthStart;
     srcDeltaNext = codePtr->srcDeltaStart;
@@ -3381,13 +3516,13 @@ TclPrintByteCodeObj(
 	    srcLengthNext++;
 	}
 
-	fprintf(stdout,	"%s%4d: pc %d-%d, src %d-%d",
+	Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d",
 		((i % 2)? "   	" : "\n   "),
 		(i+1), codeOffset, (codeOffset + codeLen - 1),
 		srcOffset, (srcOffset + srcLen - 1));
     }
     if (numCmds > 0) {
-	fprintf(stdout,	"\n");
+	Tcl_AppendToObj(bufferObj, "\n", -1);
     }
 
     /*
@@ -3436,14 +3571,14 @@ TclPrintByteCodeObj(
 	 */
 
 	while ((pc-codeStart) < codeOffset) {
-	    fprintf(stdout, "    ");
-	    pc += TclPrintInstruction(codePtr, pc);
+	    Tcl_AppendToObj(bufferObj, "    ", -1);
+	    pc += FormatInstruction(codePtr, pc, bufferObj);
 	}
 
-	fprintf(stdout, "  Command %d: ", (i+1));
-	TclPrintSource(stdout, (codePtr->source + srcOffset),
+	Tcl_AppendPrintfToObj(bufferObj, "  Command %d: ", i+1);
+	PrintSourceToObj(bufferObj, (codePtr->source + srcOffset),
 		TclMin(srcLen, 55));
-	fprintf(stdout, "\n");
+	Tcl_AppendToObj(bufferObj, "\n", -1);
     }
     if (pc < codeLimit) {
 	/*
@@ -3451,43 +3586,37 @@ TclPrintByteCodeObj(
 	 */
 
 	while (pc < codeLimit) {
-	    fprintf(stdout, "    ");
-	    pc += TclPrintInstruction(codePtr, pc);
+	    Tcl_AppendToObj(bufferObj, "    ", -1);
+	    pc += FormatInstruction(codePtr, pc, bufferObj);
 	}
     }
+    return bufferObj;
 }
 
 /*
  *----------------------------------------------------------------------
  *
- * TclPrintInstruction --
+ * FormatInstruction --
  *
- *	This procedure prints ("disassembles") one instruction from a bytecode
- *	object to stdout.
- *
- * Results:
- *	Returns the length in bytes of the current instruiction.
- *
- * Side effects:
- *	None.
+ *	Appends a representation of a bytecode instruction to a Tcl_Obj.
  *
  *----------------------------------------------------------------------
  */
 
-int
-TclPrintInstruction(
+static int
+FormatInstruction(
     ByteCode *codePtr,		/* Bytecode containing the instruction. */
-    unsigned char *pc)		/* Points to first byte of instruction. */
+    unsigned char *pc,		/* Points to first byte of instruction. */
+    Tcl_Obj *bufferObj)		/* Object to append instruction info to. */
 {
     Proc *procPtr = codePtr->procPtr;
     unsigned char opCode = *pc;
     register InstructionDesc *instDesc = &tclInstructionTable[opCode];
     unsigned char *codeStart = codePtr->codeStart;
     unsigned int pcOffset = (pc - codeStart);
-    int opnd, i, j, numBytes = 1;
+    int opnd = 0, i, j, numBytes = 1;
     int localCt = procPtr ? procPtr->numCompiledLocals : 0;
     CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL;
-
     char suffixBuffer[64];	/* Additional info to print after main opcode
 				 * and immediates. */
     char *suffixSrc = NULL;
@@ -3495,7 +3624,7 @@ TclPrintInstruction(
     AuxData *auxPtr = NULL;
 
     suffixBuffer[0] = '\0';
-    fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
+    Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name);
     for (i = 0;  i < instDesc->numOperands;  i++) {
 	switch (instDesc->opTypes[i]) {
 	case OPERAND_INT1:
@@ -3504,7 +3633,7 @@ TclPrintInstruction(
 		    || opCode == INST_JUMP_FALSE1) {
 		sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
 	    }
-	    fprintf(stdout, "%+d ", opnd);
+	    Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
 	    break;
 	case OPERAND_INT4:
 	    opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
@@ -3514,14 +3643,14 @@ TclPrintInstruction(
 	    } else if (opCode == INST_START_CMD) {
 		sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd);
 	    }
-	    fprintf(stdout, "%+d ", opnd);
+	    Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
 	    break;
 	case OPERAND_UINT1:
 	    opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
 	    if (opCode == INST_PUSH1) {
 		suffixObj = codePtr->objArrayPtr[opnd];
 	    }
-	    fprintf(stdout, "%u ", (unsigned int) opnd);
+	    Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned int) opnd);
 	    break;
 	case OPERAND_AUX4:
 	case OPERAND_UINT4:
@@ -3531,7 +3660,7 @@ TclPrintInstruction(
 	    } else if (opCode == INST_START_CMD && opnd != 1) {
 		sprintf(suffixBuffer, ", %u cmds start here", opnd);
 	    }
-	    fprintf(stdout, "%u ", (unsigned int) opnd);
+	    Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned int) opnd);
 	    if (instDesc->opTypes[i] == OPERAND_AUX4) {
 		auxPtr = &codePtr->auxDataArrayPtr[opnd];
 	    }
@@ -3539,11 +3668,11 @@ TclPrintInstruction(
 	case OPERAND_IDX4:
 	    opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
 	    if (opnd >= -1) {
-		fprintf(stdout, "%d ", opnd);
+		Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd);
 	    } else if (opnd == -2) {
-		fprintf(stdout, "end ");
+		Tcl_AppendPrintfToObj(bufferObj, "end ");
 	    } else {
-		fprintf(stdout, "end-%d ", -2-opnd);
+		Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd);
 	    }
 	    break;
 	case OPERAND_LVT1:
@@ -3556,7 +3685,7 @@ TclPrintInstruction(
 	printLVTindex:
 	    if (localPtr != NULL) {
 		if (opnd >= localCt) {
-		    Tcl_Panic("TclPrintInstruction: bad local var index %u (%u locals)",
+		    Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)",
 			    (unsigned int) opnd, localCt);
 		}
 		for (j = 0;  j < opnd;  j++) {
@@ -3569,7 +3698,7 @@ TclPrintInstruction(
 		    suffixSrc = localPtr->name;
 		}
 	    }
-	    fprintf(stdout, "%%v%u ", (unsigned) opnd);
+	    Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd);
 	    break;
 	case OPERAND_NONE:
 	default:
@@ -3577,19 +3706,24 @@ TclPrintInstruction(
 	}
     }
     if (suffixObj) {
-	fprintf(stdout, "\t# ");
-	TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
+	char *bytes;
+	int length;
+
+	Tcl_AppendToObj(bufferObj, "\t# ", -1);
+	bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length);
+	PrintSourceToObj(bufferObj, bytes, TclMin(length, 40));
     } else if (suffixBuffer[0]) {
-	fprintf(stdout, "\t# %s", suffixBuffer);
+	Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
 	if (suffixSrc) {
-	    TclPrintSource(stdout, suffixSrc, 40);
+	    PrintSourceToObj(bufferObj, suffixSrc, 40);
 	}
     }
-    fprintf(stdout, "\n");
+    Tcl_AppendToObj(bufferObj, "\n", -1);
     if (auxPtr && auxPtr->type->printProc) {
-	fprintf(stdout, "\t\t[");
-	auxPtr->type->printProc(auxPtr->clientData, codePtr, pcOffset);
-	fprintf(stdout, "]\n");
+	Tcl_AppendToObj(bufferObj, "\t\t[", -1);
+	auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr,
+		pcOffset);
+	Tcl_AppendToObj(bufferObj, "]\n", -1);
     }
     return numBytes;
 }
@@ -3597,55 +3731,16 @@ TclPrintInstruction(
 /*
  *----------------------------------------------------------------------
  *
- * TclPrintObject --
+ * PrintSourceToObj --
  *
- *	This procedure prints up to a specified number of characters from the
- *	argument Tcl object's string representation to a specified file.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	Outputs characters to the specified file.
+ *	Appends a quoted representation of a string to a Tcl_Obj.
  *
  *----------------------------------------------------------------------
  */
 
-void
-TclPrintObject(
-    FILE *outFile,		/* The file to print the source to. */
-    Tcl_Obj *objPtr,		/* Points to the Tcl object whose string
-				 * representation should be printed. */
-    int maxChars)		/* Maximum number of chars to print. */
-{
-    char *bytes;
-    int length;
-
-    bytes = Tcl_GetStringFromObj(objPtr, &length);
-    TclPrintSource(outFile, bytes, TclMin(length, maxChars));
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclPrintSource --
- *
- *	This procedure prints up to a specified number of characters from the
- *	argument string to a specified file. It tries to produce legible
- *	output by adding backslashes as necessary.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	Outputs characters to the specified file.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclPrintSource(
-    FILE *outFile,		/* The file to print the source to. */
+static void
+PrintSourceToObj(
+    Tcl_Obj *appendObj,		/* The object to print the source to. */
     const char *stringPtr,	/* The string to print. */
     int maxChars)		/* Maximum number of chars to print. */
 {
@@ -3653,40 +3748,39 @@ TclPrintSource(
     register int i = 0;
 
     if (stringPtr == NULL) {
-	fprintf(outFile, "\"\"");
+	Tcl_AppendToObj(appendObj, "\"\"", -1);
 	return;
     }
 
-    fprintf(outFile, "\"");
+    Tcl_AppendToObj(appendObj, "\"", -1);
     p = stringPtr;
     for (;  (*p != '\0') && (i < maxChars);  p++, i++) {
 	switch (*p) {
 	case '"':
-	    fprintf(outFile, "\\\"");
+	    Tcl_AppendToObj(appendObj, "\\\"", -1);
 	    continue;
 	case '\f':
-	    fprintf(outFile, "\\f");
+	    Tcl_AppendToObj(appendObj, "\\f", -1);
 	    continue;
 	case '\n':
-	    fprintf(outFile, "\\n");
+	    Tcl_AppendToObj(appendObj, "\\n", -1);
 	    continue;
 	case '\r':
-	    fprintf(outFile, "\\r");
+	    Tcl_AppendToObj(appendObj, "\\r", -1);
 	    continue;
 	case '\t':
-	    fprintf(outFile, "\\t");
+	    Tcl_AppendToObj(appendObj, "\\t", -1);
 	    continue;
 	case '\v':
-	    fprintf(outFile, "\\v");
+	    Tcl_AppendToObj(appendObj, "\\v", -1);
 	    continue;
 	default:
-	    fprintf(outFile, "%c", *p);
+	    Tcl_AppendPrintfToObj(appendObj, "%c", *p);
 	    continue;
 	}
     }
-    fprintf(outFile, "\"");
+    Tcl_AppendToObj(appendObj, "\"", -1);
 }
-#endif /* TCL_COMPILE_DEBUG */
 
 #ifdef TCL_COMPILE_STATS
 /*
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 3db6da9..0afc13b 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -9,7 +9,7 @@
  * 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.79 2007/09/13 15:27:07 das Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.80 2007/09/25 20:27:17 dkf Exp $
  */
 
 #ifndef _TCLCOMPILATION
@@ -128,19 +128,19 @@ typedef struct CmdLocation {
  */
 
 typedef struct ECL {
-  int srcOffset;		/* Command location to find the entry. */
-  int nline;
-  int *line;			/* Line information for all words in the
+    int srcOffset;		/* Command location to find the entry. */
+    int nline;
+    int *line;			/* Line information for all words in the
 				 * command. */
 } ECL;
 
 typedef struct ExtCmdLoc {
-  int type;			/* Context type. */
-  Tcl_Obj *path;		/* Path of the sourced file the command is
+    int type;			/* Context type. */
+    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'. */
+    ECL *loc;			/* Command word locations (lines). */
+    int nloc;			/* Number of allocated entries in 'loc'. */
+    int nuloc;			/* Number of used entries in 'loc'. */
 } ExtCmdLoc;
 
 /*
@@ -161,7 +161,8 @@ typedef struct ExtCmdLoc {
 typedef ClientData (AuxDataDupProc)  (ClientData clientData);
 typedef void       (AuxDataFreeProc) (ClientData clientData);
 typedef void	   (AuxDataPrintProc)(ClientData clientData,
-			    struct ByteCode *codePtr, unsigned int pcOffset);
+			    Tcl_Obj *appendObj, struct ByteCode *codePtr,
+			    unsigned int pcOffset);
 
 /*
  * We define a separate AuxDataType struct to hold type-related information
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 9ba2331..b589085 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -13,7 +13,7 @@
  * 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.335 2007/09/13 15:27:08 das Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.336 2007/09/25 20:27:17 dkf Exp $
  */
 
 #ifndef _TCLINT
@@ -2565,6 +2565,7 @@ MODULE_SCOPE void	TclFinalizeThreadStorage(void);
 MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
 MODULE_SCOPE Tcl_WideInt TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
 #endif
+MODULE_SCOPE Tcl_Obj *	TclDisassembleByteCodeObj(Tcl_Obj *objPtr);
 
 /*
  *----------------------------------------------------------------
@@ -2627,6 +2628,9 @@ MODULE_SCOPE int	TclDefaultBgErrorHandlerObjCmd(
 MODULE_SCOPE int	Tcl_DictObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *CONST objv[]);
+MODULE_SCOPE int	Tcl_DisassembleObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *CONST objv[]);
 MODULE_SCOPE int	Tcl_EncodingObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *CONST objv[]);
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 7008187..eac4033 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclProc.c,v 1.134 2007/09/13 15:27:08 das Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.135 2007/09/25 20:27:18 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -1520,7 +1520,7 @@ PushProcCallFrame(
     CallFrame *framePtr, **framePtrPtr;
     int result;
     ByteCode *codePtr;
-    
+
     /*
      * If necessary (i.e. if we haven't got a suitable compilation already
      * cached) compile the procedure's body. The compiler will allocate frame
@@ -2729,6 +2729,130 @@ MakeLambdaError(
 	    (overflow ? "..." : ""), interp->errorLine));
 }
 
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DisassembleObjCmd --
+ *
+ *	Implementation of the "::tcl::unsupported::disassemble" command. This
+ *	command is not documented, but will disassemble procedures, lambda
+ *	terms and general scripts. Note that will compile terms if necessary
+ *	in order to disassemble them.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DisassembleObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *CONST objv[])	/* Argument objects. */
+{
+    static const char *types[] = {
+	"lambda", "proc", "script", NULL
+    };
+    enum Types {
+	DISAS_LAMBDA, DISAS_PROC, DISAS_SCRIPT
+    };
+    int idx, result;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "type procName|lambdaTerm|script");
+	return TCL_ERROR;
+    }
+    if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){
+	return TCL_ERROR;
+    }
+
+    switch ((enum Types) idx) {
+    case DISAS_LAMBDA: {
+	Proc *procPtr = NULL;
+	Command cmd;
+	Tcl_Obj *nsObjPtr;
+	Tcl_Namespace *nsPtr;
+
+	/*
+	 * Compile (if uncompiled) and disassemble a lambda term.
+	 */
+
+	if (objv[2]->typePtr == &lambdaType) {
+	    procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
+	}
+	if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) {
+	    result = SetLambdaFromAny(interp, objv[2]);
+	    if (result != TCL_OK) {
+		return result;
+	    }
+	    procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
+	}
+
+	memset(&cmd, 0, sizeof(Command));
+	nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2;
+	result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
+	if (result != TCL_OK) {
+	    return result;
+	}
+	cmd.nsPtr = (Namespace *) nsPtr;
+	procPtr->cmdPtr = &cmd;
+	result = PushProcCallFrame(procPtr, interp, objc, objv, 1);
+	if (result != TCL_OK) {
+	    return result;
+	}
+	TclPopStackFrame(interp);
+	if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags
+		& TCL_BYTECODE_PRECOMPILED) {
+	    Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode",
+		    NULL);
+	    return TCL_ERROR;
+	}
+	Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr));
+	break;
+    }
+    case DISAS_PROC: {
+	Proc *procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
+
+	if (procPtr == NULL) {
+	    Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
+		    "\" isn't a procedure", NULL);
+	    return TCL_ERROR;
+	}
+
+	/*
+	 * Compile (if uncompiled) and disassemble a procedure.
+	 */
+
+	result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1);
+	if (result != TCL_OK) {
+	    return result;
+	}
+	TclPopStackFrame(interp);
+	if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags
+		& TCL_BYTECODE_PRECOMPILED) {
+	    Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode",
+		    NULL);
+	    return TCL_ERROR;
+	}
+	Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr));
+	break;
+    }
+    case DISAS_SCRIPT:
+	/*
+	 * Compile and disassemble a script.
+	 */
+
+	if (objv[2]->typePtr != &tclByteCodeType) {
+	    if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){
+		return TCL_ERROR;
+	    }
+	}
+	Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(objv[2]));
+	break;
+    }
+    return TCL_OK;
+}
+
 /*
  * Local Variables:
  * mode: c