merge trunk

1 files changed, 1409 insertions, 0 deletions

diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
new file mode 100644
index 0000000..15502e7
--- /dev/null
+++ b/generic/tclDisassemble.c
@@ -0,0 +1,1409 @@
+/*
+ * tclDisassemble.c --
+ *
+ *	This file contains procedures that disassemble bytecode into either
+ *	human-readable or Tcl-processable forms.
+ *
+ * Copyright (c) 1996-1998 Sun Microsystems, Inc.
+ * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2013 Donal K. Fellows.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+#include "tclCompile.h"
+#include "tclOOInt.h"
+#include <assert.h>
+
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+
+static Tcl_Obj *	DisassembleByteCodeAsDicts(Tcl_Obj *objPtr);
+static int		FormatInstruction(ByteCode *codePtr,
+			    const unsigned char *pc, Tcl_Obj *bufferObj);
+static void		PrintSourceToObj(Tcl_Obj *appendObj,
+			    const char *stringPtr, int maxChars);
+static void		UpdateStringOfInstName(Tcl_Obj *objPtr);
+
+/*
+ * The structure below defines an instruction name Tcl object to allow
+ * reporting of inner contexts in errorstack without string allocation.
+ */
+
+static const Tcl_ObjType tclInstNameType = {
+    "instname",			/* name */
+    NULL,			/* freeIntRepProc */
+    NULL,			/* dupIntRepProc */
+    UpdateStringOfInstName,	/* updateStringProc */
+    NULL,			/* setFromAnyProc */
+};
+
+/*
+ * How to get the bytecode out of a Tcl_Obj.
+ */
+
+#define BYTECODE(objPtr)					\
+    ((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1)
+
+#ifdef TCL_COMPILE_DEBUG
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintByteCodeObj --
+ *
+ *	This procedure prints ("disassembles") the instructions of a bytecode
+ *	object to stdout.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPrintByteCodeObj(
+    Tcl_Interp *interp,		/* Used only for Tcl_GetStringFromObj. */
+    Tcl_Obj *objPtr)		/* The bytecode object to disassemble. */
+{
+    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. */
+    const unsigned char *pc)	/* Points to first byte of instruction. */
+{
+    Tcl_Obj *bufferObj;
+    int numBytes;
+
+    TclNewObj(bufferObj);
+    numBytes = 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, "%s", 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 = BYTECODE(objPtr);
+    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 bufferObj;	/* Already freed. */
+    }
+
+    codeStart = codePtr->codeStart;
+    codeLimit = codeStart + codePtr->numCodeBytes;
+    numCmds = codePtr->numCommands;
+
+    /*
+     * Print header lines describing the ByteCode.
+     */
+
+    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);
+    Tcl_AppendToObj(bufferObj, "  Source ", -1);
+    PrintSourceToObj(bufferObj, codePtr->source,
+	    TclMin(codePtr->numSrcBytes, 55));
+    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,
+#ifdef TCL_COMPILE_STATS
+	    codePtr->numSrcBytes?
+		    codePtr->structureSize/(float)codePtr->numSrcBytes :
+#endif
+	    0.0);
+
+#ifdef TCL_COMPILE_STATS
+    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)),
+	    codePtr->numCodeBytes,
+	    (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
+	    (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),
+	    (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)),
+	    codePtr->numCmdLocBytes);
+#endif /* TCL_COMPILE_STATS */
+
+    /*
+     * If the ByteCode is the compiled body of a Tcl procedure, print
+     * information about that procedure. Note that we don't know the
+     * procedure's name since ByteCode's can be shared among procedures.
+     */
+
+    if (codePtr->procPtr != NULL) {
+	Proc *procPtr = codePtr->procPtr;
+	int numCompiledLocals = procPtr->numCompiledLocals;
+
+	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++) {
+		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" : "",
+			(localPtr->flags & VAR_ARGUMENT) ? ", arg" : "",
+			(localPtr->flags & VAR_TEMPORARY) ? ", temp" : "",
+			(localPtr->flags & VAR_RESOLVED) ? ", resolved" : "");
+		if (TclIsVarTemporary(localPtr)) {
+		    Tcl_AppendToObj(bufferObj, "\n", -1);
+		} else {
+		    Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n",
+			    localPtr->name);
+		}
+		localPtr = localPtr->nextPtr;
+	    }
+	}
+    }
+
+    /*
+     * Print the ExceptionRange array.
+     */
+
+    if (codePtr->numExceptRanges > 0) {
+	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];
+
+	    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:
+		Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n",
+			rangePtr->continueOffset, rangePtr->breakOffset);
+		break;
+	    case CATCH_EXCEPTION_RANGE:
+		Tcl_AppendPrintfToObj(bufferObj, "catch %d\n",
+			rangePtr->catchOffset);
+		break;
+	    default:
+		Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d",
+			rangePtr->type);
+	    }
+	}
+    }
+
+    /*
+     * If there were no commands (e.g., an expression or an empty string was
+     * compiled), just print all instructions and return.
+     */
+
+    if (numCmds == 0) {
+	pc = codeStart;
+	while (pc < codeLimit) {
+	    Tcl_AppendToObj(bufferObj, "    ", -1);
+	    pc += FormatInstruction(codePtr, pc, bufferObj);
+	}
+	return bufferObj;
+    }
+
+    /*
+     * Print table showing the code offset, source offset, and source length
+     * for each command. These are encoded as a sequence of bytes.
+     */
+
+    Tcl_AppendPrintfToObj(bufferObj, "  Commands %d:", numCmds);
+    codeDeltaNext = codePtr->codeDeltaStart;
+    codeLengthNext = codePtr->codeLengthStart;
+    srcDeltaNext = codePtr->srcDeltaStart;
+    srcLengthNext = codePtr->srcLengthStart;
+    codeOffset = srcOffset = 0;
+    for (i = 0;  i < numCmds;  i++) {
+	if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) {
+	    codeDeltaNext++;
+	    delta = TclGetInt4AtPtr(codeDeltaNext);
+	    codeDeltaNext += 4;
+	} else {
+	    delta = TclGetInt1AtPtr(codeDeltaNext);
+	    codeDeltaNext++;
+	}
+	codeOffset += delta;
+
+	if ((unsigned) *codeLengthNext == (unsigned) 0xFF) {
+	    codeLengthNext++;
+	    codeLen = TclGetInt4AtPtr(codeLengthNext);
+	    codeLengthNext += 4;
+	} else {
+	    codeLen = TclGetInt1AtPtr(codeLengthNext);
+	    codeLengthNext++;
+	}
+
+	if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
+	    srcDeltaNext++;
+	    delta = TclGetInt4AtPtr(srcDeltaNext);
+	    srcDeltaNext += 4;
+	} else {
+	    delta = TclGetInt1AtPtr(srcDeltaNext);
+	    srcDeltaNext++;
+	}
+	srcOffset += delta;
+
+	if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
+	    srcLengthNext++;
+	    srcLen = TclGetInt4AtPtr(srcLengthNext);
+	    srcLengthNext += 4;
+	} else {
+	    srcLen = TclGetInt1AtPtr(srcLengthNext);
+	    srcLengthNext++;
+	}
+
+	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) {
+	Tcl_AppendToObj(bufferObj, "\n", -1);
+    }
+
+    /*
+     * Print each instruction. If the instruction corresponds to the start of
+     * a command, print the command's source. Note that we don't need the code
+     * length here.
+     */
+
+    codeDeltaNext = codePtr->codeDeltaStart;
+    srcDeltaNext = codePtr->srcDeltaStart;
+    srcLengthNext = codePtr->srcLengthStart;
+    codeOffset = srcOffset = 0;
+    pc = codeStart;
+    for (i = 0;  i < numCmds;  i++) {
+	if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) {
+	    codeDeltaNext++;
+	    delta = TclGetInt4AtPtr(codeDeltaNext);
+	    codeDeltaNext += 4;
+	} else {
+	    delta = TclGetInt1AtPtr(codeDeltaNext);
+	    codeDeltaNext++;
+	}
+	codeOffset += delta;
+
+	if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
+	    srcDeltaNext++;
+	    delta = TclGetInt4AtPtr(srcDeltaNext);
+	    srcDeltaNext += 4;
+	} else {
+	    delta = TclGetInt1AtPtr(srcDeltaNext);
+	    srcDeltaNext++;
+	}
+	srcOffset += delta;
+
+	if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
+	    srcLengthNext++;
+	    srcLen = TclGetInt4AtPtr(srcLengthNext);
+	    srcLengthNext += 4;
+	} else {
+	    srcLen = TclGetInt1AtPtr(srcLengthNext);
+	    srcLengthNext++;
+	}
+
+	/*
+	 * Print instructions before command i.
+	 */
+
+	while ((pc-codeStart) < codeOffset) {
+	    Tcl_AppendToObj(bufferObj, "    ", -1);
+	    pc += FormatInstruction(codePtr, pc, bufferObj);
+	}
+
+	Tcl_AppendPrintfToObj(bufferObj, "  Command %d: ", i+1);
+	PrintSourceToObj(bufferObj, (codePtr->source + srcOffset),
+		TclMin(srcLen, 55));
+	Tcl_AppendToObj(bufferObj, "\n", -1);
+    }
+    if (pc < codeLimit) {
+	/*
+	 * Print instructions after the last command.
+	 */
+
+	while (pc < codeLimit) {
+	    Tcl_AppendToObj(bufferObj, "    ", -1);
+	    pc += FormatInstruction(codePtr, pc, bufferObj);
+	}
+    }
+    return bufferObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FormatInstruction --
+ *
+ *	Appends a representation of a bytecode instruction to a Tcl_Obj.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FormatInstruction(
+    ByteCode *codePtr,		/* Bytecode containing the instruction. */
+    const 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 const InstructionDesc *instDesc = &tclInstructionTable[opCode];
+    unsigned char *codeStart = codePtr->codeStart;
+    unsigned pcOffset = pc - codeStart;
+    int opnd = 0, i, j, numBytes = 1;
+    int localCt = procPtr ? procPtr->numCompiledLocals : 0;
+    CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL;
+    char suffixBuffer[128];	/* Additional info to print after main opcode
+				 * and immediates. */
+    char *suffixSrc = NULL;
+    Tcl_Obj *suffixObj = NULL;
+    AuxData *auxPtr = NULL;
+
+    suffixBuffer[0] = '\0';
+    Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name);
+    for (i = 0;  i < instDesc->numOperands;  i++) {
+	switch (instDesc->opTypes[i]) {
+	case OPERAND_INT1:
+	    opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++;
+	    Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
+	    break;
+	case OPERAND_INT4:
+	    opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
+	    Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
+	    break;
+	case OPERAND_UINT1:
+	    opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
+	    Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
+	    break;
+	case OPERAND_UINT4:
+	    opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
+	    if (opCode == INST_START_CMD) {
+		sprintf(suffixBuffer+strlen(suffixBuffer),
+			", %u cmds start here", opnd);
+	    }
+	    Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
+	    break;
+	case OPERAND_OFFSET1:
+	    opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++;
+	    sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
+	    Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
+	    break;
+	case OPERAND_OFFSET4:
+	    opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
+	    if (opCode == INST_START_CMD) {
+		sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd);
+	    } else {
+		sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
+	    }
+	    Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
+	    break;
+	case OPERAND_LIT1:
+	    opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
+	    suffixObj = codePtr->objArrayPtr[opnd];
+	    Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
+	    break;
+	case OPERAND_LIT4:
+	    opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
+	    suffixObj = codePtr->objArrayPtr[opnd];
+	    Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
+	    break;
+	case OPERAND_AUX4:
+	    opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
+	    Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
+	    auxPtr = &codePtr->auxDataArrayPtr[opnd];
+	    break;
+	case OPERAND_IDX4:
+	    opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
+	    if (opnd >= -1) {
+		Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd);
+	    } else if (opnd == -2) {
+		Tcl_AppendPrintfToObj(bufferObj, "end ");
+	    } else {
+		Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd);
+	    }
+	    break;
+	case OPERAND_LVT1:
+	    opnd = TclGetUInt1AtPtr(pc+numBytes);
+	    numBytes++;
+	    goto printLVTindex;
+	case OPERAND_LVT4:
+	    opnd = TclGetUInt4AtPtr(pc+numBytes);
+	    numBytes += 4;
+	printLVTindex:
+	    if (localPtr != NULL) {
+		if (opnd >= localCt) {
+		    Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)",
+			    (unsigned) opnd, localCt);
+		}
+		for (j = 0;  j < opnd;  j++) {
+		    localPtr = localPtr->nextPtr;
+		}
+		if (TclIsVarTemporary(localPtr)) {
+		    sprintf(suffixBuffer, "temp var %u", (unsigned) opnd);
+		} else {
+		    sprintf(suffixBuffer, "var ");
+		    suffixSrc = localPtr->name;
+		}
+	    }
+	    Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd);
+	    break;
+	case OPERAND_SCLS1:
+	    opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
+	    Tcl_AppendPrintfToObj(bufferObj, "%s ",
+		    tclStringClassTable[opnd].name);
+	    break;
+	case OPERAND_NONE:
+	default:
+	    break;
+	}
+    }
+    if (suffixObj) {
+	const 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]) {
+	Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
+	if (suffixSrc) {
+	    PrintSourceToObj(bufferObj, suffixSrc, 40);
+	}
+    }
+    Tcl_AppendToObj(bufferObj, "\n", -1);
+    if (auxPtr && auxPtr->type->printProc) {
+	Tcl_AppendToObj(bufferObj, "\t\t[", -1);
+	auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr,
+		pcOffset);
+	Tcl_AppendToObj(bufferObj, "]\n", -1);
+    }
+    return numBytes;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetInnerContext --
+ *
+ *	If possible, returns a list capturing the inner context. Otherwise
+ *	return NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclGetInnerContext(
+    Tcl_Interp *interp,
+    const unsigned char *pc,
+    Tcl_Obj **tosPtr)
+{
+    int objc = 0, off = 0;
+    Tcl_Obj *result;
+    Interp *iPtr = (Interp *) interp;
+
+    switch (*pc) {
+    case INST_STR_LEN:
+    case INST_LNOT:
+    case INST_BITNOT:
+    case INST_UMINUS:
+    case INST_UPLUS:
+    case INST_TRY_CVT_TO_NUMERIC:
+    case INST_EXPAND_STKTOP:
+    case INST_EXPR_STK:
+        objc = 1;
+        break;
+
+    case INST_LIST_IN:
+    case INST_LIST_NOT_IN:	/* Basic list containment operators. */
+    case INST_STR_EQ:
+    case INST_STR_NEQ:		/* String (in)equality check */
+    case INST_STR_CMP:		/* String compare. */
+    case INST_STR_INDEX:
+    case INST_STR_MATCH:
+    case INST_REGEXP:
+    case INST_EQ:
+    case INST_NEQ:
+    case INST_LT:
+    case INST_GT:
+    case INST_LE:
+    case INST_GE:
+    case INST_MOD:
+    case INST_LSHIFT:
+    case INST_RSHIFT:
+    case INST_BITOR:
+    case INST_BITXOR:
+    case INST_BITAND:
+    case INST_EXPON:
+    case INST_ADD:
+    case INST_SUB:
+    case INST_DIV:
+    case INST_MULT:
+        objc = 2;
+        break;
+
+    case INST_RETURN_STK:
+        /* early pop. TODO: dig out opt dict too :/ */
+        objc = 1;
+        break;
+
+    case INST_SYNTAX:
+    case INST_RETURN_IMM:
+        objc = 2;
+        break;
+
+    case INST_INVOKE_STK4:
+	objc = TclGetUInt4AtPtr(pc+1);
+        break;
+
+    case INST_INVOKE_STK1:
+	objc = TclGetUInt1AtPtr(pc+1);
+	break;
+    }
+
+    result = iPtr->innerContext;
+    if (Tcl_IsShared(result)) {
+        Tcl_DecrRefCount(result);
+        iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL);
+        Tcl_IncrRefCount(result);
+    } else {
+        int len;
+
+        /*
+         * Reset while keeping the list intrep as much as possible.
+         */
+
+	Tcl_ListObjLength(interp, result, &len);
+        Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);
+    }
+    Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc));
+
+    for (; objc>0 ; objc--) {
+        Tcl_Obj *objPtr;
+
+        objPtr = tosPtr[1 - objc + off];
+        if (!objPtr) {
+            Tcl_Panic("InnerContext: bad tos -- appending null object");
+        }
+        if ((objPtr->refCount<=0)
+#ifdef TCL_MEM_DEBUG
+                || (objPtr->refCount==0x61616161)
+#endif
+        ) {
+            Tcl_Panic("InnerContext: bad tos -- appending freed object %p",
+                    objPtr);
+        }
+        Tcl_ListObjAppendElement(NULL, result, objPtr);
+    }
+
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNewInstNameObj --
+ *
+ *	Creates a new InstName Tcl_Obj based on the given instruction
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclNewInstNameObj(
+    unsigned char inst)
+{
+    Tcl_Obj *objPtr = Tcl_NewObj();
+
+    objPtr->typePtr = &tclInstNameType;
+    objPtr->internalRep.longValue = (long) inst;
+    objPtr->bytes = NULL;
+
+    return objPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfInstName --
+ *
+ *	Update the string representation for an instruction name object.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfInstName(
+    Tcl_Obj *objPtr)
+{
+    int inst = objPtr->internalRep.longValue;
+    char *s, buf[20];
+    int len;
+
+    if ((inst < 0) || (inst > LAST_INST_OPCODE)) {
+        sprintf(buf, "inst_%d", inst);
+        s = buf;
+    } else {
+        s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name;
+    }
+    len = strlen(s);
+    objPtr->bytes = ckalloc(len + 1);
+    memcpy(objPtr->bytes, s, len + 1);
+    objPtr->length = len;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PrintSourceToObj --
+ *
+ *	Appends a quoted representation of a string to a Tcl_Obj.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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. */
+{
+    register const char *p;
+    register int i = 0, len;
+    Tcl_UniChar ch = 0;
+
+    if (stringPtr == NULL) {
+	Tcl_AppendToObj(appendObj, "\"\"", -1);
+	return;
+    }
+
+    Tcl_AppendToObj(appendObj, "\"", -1);
+    p = stringPtr;
+    for (;  (*p != '\0') && (i < maxChars);  p+=len) {
+
+	len = TclUtfToUniChar(p, &ch);
+	switch (ch) {
+	case '"':
+	    Tcl_AppendToObj(appendObj, "\\\"", -1);
+	    i += 2;
+	    continue;
+	case '\f':
+	    Tcl_AppendToObj(appendObj, "\\f", -1);
+	    i += 2;
+	    continue;
+	case '\n':
+	    Tcl_AppendToObj(appendObj, "\\n", -1);
+	    i += 2;
+	    continue;
+	case '\r':
+	    Tcl_AppendToObj(appendObj, "\\r", -1);
+	    i += 2;
+	    continue;
+	case '\t':
+	    Tcl_AppendToObj(appendObj, "\\t", -1);
+	    i += 2;
+	    continue;
+	case '\v':
+	    Tcl_AppendToObj(appendObj, "\\v", -1);
+	    i += 2;
+	    continue;
+	default:
+#if TCL_UTF_MAX > 4
+	    if ((int) ch > 0xffff) {
+		Tcl_AppendPrintfToObj(appendObj, "\\U%08x", (int) ch);
+		i += 10;
+	    } else
+#endif
+	    if (ch < 0x20 || ch >= 0x7f) {
+		Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ch);
+		i += 6;
+	    } else {
+		Tcl_AppendPrintfToObj(appendObj, "%c", ch);
+		i++;
+	    }
+	    continue;
+	}
+    }
+    if (*p != '\0') {
+	Tcl_AppendToObj(appendObj, "...", -1);
+    }
+    Tcl_AppendToObj(appendObj, "\"", -1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DisassembleByteCodeAsDicts --
+ *
+ *	Given an object which is of bytecode type, return a disassembled
+ *	version of the bytecode (in a new refcount 0 object) in a dictionary.
+ *	No guarantees are made about the details of the contents of the
+ *	result, but it is intended to be more readable than the old output
+ *	format.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+DisassembleByteCodeAsDicts(
+    Tcl_Obj *objPtr)		/* The bytecode-holding value to take apart */
+{
+    ByteCode *codePtr = BYTECODE(objPtr);
+    Tcl_Obj *description, *literals, *variables, *instructions, *inst;
+    Tcl_Obj *aux, *exn, *commands;
+    unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr;
+    int codeOffset, codeLength, sourceOffset, sourceLength;
+    int i, val;
+
+    /*
+     * Get the literals from the bytecode.
+     */
+
+    literals = Tcl_NewObj();
+    for (i=0 ; i<codePtr->numLitObjects ; i++) {
+	Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]);
+    }
+
+    /*
+     * Get the variables from the bytecode.
+     */
+
+    variables = Tcl_NewObj();
+    if (codePtr->procPtr) {
+	int localCount = codePtr->procPtr->numCompiledLocals;
+	CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr;
+
+	for (i=0 ; i<localCount ; i++,localPtr=localPtr->nextPtr) {
+	    Tcl_Obj *descriptor[2];
+
+	    descriptor[0] = Tcl_NewObj();
+	    if (!(localPtr->flags & (VAR_ARRAY|VAR_LINK))) {
+		Tcl_ListObjAppendElement(NULL, descriptor[0],
+			Tcl_NewStringObj("scalar", -1));
+	    }
+	    if (localPtr->flags & VAR_ARRAY) {
+		Tcl_ListObjAppendElement(NULL, descriptor[0],
+			Tcl_NewStringObj("array", -1));
+	    }
+	    if (localPtr->flags & VAR_LINK) {
+		Tcl_ListObjAppendElement(NULL, descriptor[0],
+			Tcl_NewStringObj("link", -1));
+	    }
+	    if (localPtr->flags & VAR_ARGUMENT) {
+		Tcl_ListObjAppendElement(NULL, descriptor[0],
+			Tcl_NewStringObj("arg", -1));
+	    }
+	    if (localPtr->flags & VAR_TEMPORARY) {
+		Tcl_ListObjAppendElement(NULL, descriptor[0],
+			Tcl_NewStringObj("temp", -1));
+	    }
+	    if (localPtr->flags & VAR_RESOLVED) {
+		Tcl_ListObjAppendElement(NULL, descriptor[0],
+			Tcl_NewStringObj("resolved", -1));
+	    }
+	    if (localPtr->flags & VAR_TEMPORARY) {
+		Tcl_ListObjAppendElement(NULL, variables,
+			Tcl_NewListObj(1, descriptor));
+	    } else {
+		descriptor[1] = Tcl_NewStringObj(localPtr->name, -1);
+		Tcl_ListObjAppendElement(NULL, variables,
+			Tcl_NewListObj(2, descriptor));
+	    }
+	}
+    }
+
+    /*
+     * Get the instructions from the bytecode.
+     */
+
+    instructions = Tcl_NewObj();
+    for (pc=codePtr->codeStart; pc<codePtr->codeStart+codePtr->numCodeBytes;){
+	const InstructionDesc *instDesc = &tclInstructionTable[*pc];
+	int address = pc - codePtr->codeStart;
+
+	inst = Tcl_NewObj();
+	Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj(
+		instDesc->name, -1));
+	opnd = pc + 1;
+	for (i=0 ; i<instDesc->numOperands ; i++) {
+	    switch (instDesc->opTypes[i]) {
+	    case OPERAND_INT1:
+		val = TclGetInt1AtPtr(opnd);
+		opnd += 1;
+		goto formatNumber;
+	    case OPERAND_UINT1:
+		val = TclGetUInt1AtPtr(opnd);
+		opnd += 1;
+		goto formatNumber;
+	    case OPERAND_INT4:
+		val = TclGetInt4AtPtr(opnd);
+		opnd += 4;
+		goto formatNumber;
+	    case OPERAND_UINT4:
+		val = TclGetUInt4AtPtr(opnd);
+		opnd += 4;
+	    formatNumber:
+		Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val));
+		break;
+
+	    case OPERAND_OFFSET1:
+		val = TclGetInt1AtPtr(opnd);
+		opnd += 1;
+		goto formatAddress;
+	    case OPERAND_OFFSET4:
+		val = TclGetInt4AtPtr(opnd);
+		opnd += 4;
+	    formatAddress:
+		Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
+			"pc %d", address + val));
+		break;
+
+	    case OPERAND_LIT1:
+		val = TclGetUInt1AtPtr(opnd);
+		opnd += 1;
+		goto formatLiteral;
+	    case OPERAND_LIT4:
+		val = TclGetUInt4AtPtr(opnd);
+		opnd += 4;
+	    formatLiteral:
+		Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
+			"@%d", val));
+		break;
+
+	    case OPERAND_LVT1:
+		val = TclGetUInt1AtPtr(opnd);
+		opnd += 1;
+		goto formatVariable;
+	    case OPERAND_LVT4:
+		val = TclGetUInt4AtPtr(opnd);
+		opnd += 4;
+	    formatVariable:
+		Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
+			"%%%d", val));
+		break;
+	    case OPERAND_IDX4:
+		val = TclGetInt4AtPtr(opnd);
+		opnd += 4;
+		if (val >= -1) {
+		    Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
+			    ".%d", val));
+		} else if (val == -2) {
+		    Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj(
+			    ".end", -1));
+		} else {
+		    Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
+			    ".end-%d", -2-val));
+		}
+		break;
+	    case OPERAND_AUX4:
+		val = TclGetInt4AtPtr(opnd);
+		opnd += 4;
+		Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
+			"?%d", val));
+		break;
+	    case OPERAND_SCLS1:
+		val = TclGetUInt1AtPtr(opnd);
+		opnd++;
+		Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
+			"=%s", tclStringClassTable[val].name));
+		break;
+	    case OPERAND_NONE:
+		Tcl_Panic("opcode %d with more than zero 'no' operands", *pc);
+	    }
+	}
+	Tcl_DictObjPut(NULL, instructions, Tcl_NewIntObj(address), inst);
+	pc += instDesc->numBytes;
+    }
+
+    /*
+     * Get the auxiliary data from the bytecode.
+     */
+
+    aux = Tcl_NewObj();
+    for (i=0 ; i<codePtr->numAuxDataItems ; i++) {
+	AuxData *auxData = &codePtr->auxDataArrayPtr[i];
+	Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1);
+
+	if (auxData->type->disassembleProc) {
+	    Tcl_Obj *desc = Tcl_NewObj();
+
+	    Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), auxDesc);
+	    auxDesc = desc;
+	    auxData->type->disassembleProc(auxData->clientData, auxDesc,
+		    codePtr, 0);
+	} else if (auxData->type->printProc) {
+	    Tcl_Obj *desc = Tcl_NewObj();
+
+	    auxData->type->printProc(auxData->clientData, desc, codePtr, 0);
+	    Tcl_ListObjAppendElement(NULL, auxDesc, desc);
+	}
+	Tcl_ListObjAppendElement(NULL, aux, auxDesc);
+    }
+
+    /*
+     * Get the exception ranges from the bytecode.
+     */
+
+    exn = Tcl_NewObj();
+    for (i=0 ; i<codePtr->numExceptRanges ; i++) {
+	ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i];
+
+	switch (rangePtr->type) {
+	case LOOP_EXCEPTION_RANGE:
+	    Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf(
+		    "type %s level %d from %d to %d break %d continue %d",
+		    "loop", rangePtr->nestingLevel, rangePtr->codeOffset,
+		    rangePtr->codeOffset + rangePtr->numCodeBytes - 1,
+		    rangePtr->breakOffset, rangePtr->continueOffset));
+	    break;
+	case CATCH_EXCEPTION_RANGE:
+	    Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf(
+		    "type %s level %d from %d to %d catch %d",
+		    "catch", rangePtr->nestingLevel, rangePtr->codeOffset,
+		    rangePtr->codeOffset + rangePtr->numCodeBytes - 1,
+		    rangePtr->catchOffset));
+	    break;
+	}
+    }
+
+    /*
+     * Get the command information from the bytecode.
+     *
+     * The way these are encoded in the bytecode is non-trivial; the Decode
+     * macro (which updates its argument and returns the next decoded value)
+     * handles this so that the rest of the code does not.
+     */
+
+#define Decode(ptr) \
+    ((TclGetUInt1AtPtr(ptr) == 0xFF)			\
+	? ((ptr)+=5 , TclGetInt4AtPtr((ptr)-4))		\
+	: ((ptr)+=1 , TclGetInt1AtPtr((ptr)-1)))
+
+    commands = Tcl_NewObj();
+    codeOffPtr = codePtr->codeDeltaStart;
+    codeLenPtr = codePtr->codeLengthStart;
+    srcOffPtr = codePtr->srcDeltaStart;
+    srcLenPtr = codePtr->srcLengthStart;
+    codeOffset = sourceOffset = 0;
+    for (i=0 ; i<codePtr->numCommands ; i++) {
+	Tcl_Obj *cmd;
+
+	codeOffset += Decode(codeOffPtr);
+	codeLength = Decode(codeLenPtr);
+	sourceOffset += Decode(srcOffPtr);
+	sourceLength = Decode(srcLenPtr);
+	cmd = Tcl_NewObj();
+	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1),
+		Tcl_NewIntObj(codeOffset));
+	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1),
+		Tcl_NewIntObj(codeOffset + codeLength - 1));
+
+	/*
+	 * Convert byte offsets to character offsets; important if multibyte
+	 * characters are present in the source!
+	 */
+
+	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1),
+		Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source,
+			sourceOffset)));
+	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1),
+		Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source,
+			sourceOffset + sourceLength - 1)));
+	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1),
+		Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength));
+	Tcl_ListObjAppendElement(NULL, commands, cmd);
+    }
+
+#undef Decode
+
+    /*
+     * Build the overall result.
+     */
+
+    description = Tcl_NewObj();
+    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("literals", -1),
+	    literals);
+    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("variables", -1),
+	    variables);
+    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exception", -1), exn);
+    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("instructions", -1),
+	    instructions);
+    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("auxiliary", -1), aux);
+    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("commands", -1),
+	    commands);
+    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("script", -1),
+	    Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes));
+    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1),
+	    Tcl_NewStringObj(codePtr->nsPtr->fullName, -1));
+    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1),
+	    Tcl_NewIntObj(codePtr->maxStackDepth));
+    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1),
+	    Tcl_NewIntObj(codePtr->maxExceptDepth));
+    return description;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 clientData,	/* What type of operation. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    static const char *const types[] = {
+	"lambda", "method", "objmethod", "proc", "script", NULL
+    };
+    enum Types {
+	DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC,
+	DISAS_SCRIPT
+    };
+    int idx, result;
+    Tcl_Obj *codeObjPtr = NULL;
+    Proc *procPtr = NULL;
+    Tcl_HashEntry *hPtr;
+    Object *oPtr;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "type ...");
+	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: {
+	Command cmd;
+	Tcl_Obj *nsObjPtr;
+	Tcl_Namespace *nsPtr;
+
+	/*
+	 * Compile (if uncompiled) and disassemble a lambda term.
+	 *
+	 * WARNING! Pokes inside the lambda objtype.
+	 */
+
+	if (objc != 3) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm");
+	    return TCL_ERROR;
+	}
+	if (objv[2]->typePtr == &tclLambdaType) {
+	    procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
+	}
+	if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) {
+	    result = tclLambdaType.setFromAnyProc(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 = TclPushProcCallFrame(procPtr, interp, objc, objv, 1);
+	if (result != TCL_OK) {
+	    return result;
+	}
+	TclPopStackFrame(interp);
+	codeObjPtr = procPtr->bodyPtr;
+	break;
+    }
+    case DISAS_PROC:
+	if (objc != 3) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "procName");
+	    return TCL_ERROR;
+	}
+
+	procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
+	if (procPtr == NULL) {
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "\"%s\" isn't a procedure", TclGetString(objv[2])));
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC",
+		    TclGetString(objv[2]), NULL);
+	    return TCL_ERROR;
+	}
+
+	/*
+	 * Compile (if uncompiled) and disassemble a procedure.
+	 */
+
+	result = TclPushProcCallFrame(procPtr, interp, 2, objv+1, 1);
+	if (result != TCL_OK) {
+	    return result;
+	}
+	TclPopStackFrame(interp);
+	codeObjPtr = procPtr->bodyPtr;
+	break;
+    case DISAS_SCRIPT:
+	/*
+	 * Compile and disassemble a script.
+	 */
+
+	if (objc != 3) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "script");
+	    return TCL_ERROR;
+	}
+	if ((objv[2]->typePtr != &tclByteCodeType)
+		&& (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) {
+	    return TCL_ERROR;
+	}
+	codeObjPtr = objv[2];
+	break;
+
+    case DISAS_CLASS_METHOD:
+	if (objc != 4) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "className methodName");
+	    return TCL_ERROR;
+	}
+
+	/*
+	 * Look up the body of a class method.
+	 */
+
+	oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+	if (oPtr == NULL) {
+	    return TCL_ERROR;
+	}
+	if (oPtr->classPtr == NULL) {
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "\"%s\" is not a class", TclGetString(objv[2])));
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+		    TclGetString(objv[2]), NULL);
+	    return TCL_ERROR;
+	}
+	hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
+		(char *) objv[3]);
+	goto methodBody;
+    case DISAS_OBJECT_METHOD:
+	if (objc != 4) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName");
+	    return TCL_ERROR;
+	}
+
+	/*
+	 * Look up the body of an instance method.
+	 */
+
+	oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+	if (oPtr == NULL) {
+	    return TCL_ERROR;
+	}
+	if (oPtr->methodsPtr == NULL) {
+	    goto unknownMethod;
+	}
+	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]);
+
+	/*
+	 * Compile (if necessary) and disassemble a method body.
+	 */
+
+    methodBody:
+	if (hPtr == NULL) {
+	unknownMethod:
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "unknown method \"%s\"", TclGetString(objv[3])));
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		    TclGetString(objv[3]), NULL);
+	    return TCL_ERROR;
+	}
+	procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+	if (procPtr == NULL) {
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "body not available for this kind of method", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+		    "METHODTYPE", NULL);
+	    return TCL_ERROR;
+	}
+	if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+	    Command cmd;
+
+	    /*
+	     * Yes, this is ugly, but we need to pass the namespace in to the
+	     * compiler in two places.
+	     */
+
+	    cmd.nsPtr = (Namespace *) oPtr->namespacePtr;
+	    procPtr->cmdPtr = &cmd;
+	    result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr,
+		    (Namespace *) oPtr->namespacePtr, "body of method",
+		    TclGetString(objv[3]));
+	    procPtr->cmdPtr = NULL;
+	    if (result != TCL_OK) {
+		return result;
+	    }
+	}
+	codeObjPtr = procPtr->bodyPtr;
+	break;
+    default:
+	CLANG_ASSERT(0);
+    }
+
+    /*
+     * Do the actual disassembly.
+     */
+
+    if (BYTECODE(codeObjPtr)->flags & TCL_BYTECODE_PRECOMPILED) {
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"may not disassemble prebuilt bytecode", -1));
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+		"BYTECODE", NULL);
+	return TCL_ERROR;
+    }
+    if (PTR2INT(clientData)) {
+	Tcl_SetObjResult(interp, DisassembleByteCodeAsDicts(codeObjPtr));
+    } else {
+	Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr));
+    }
+    return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * tab-width: 8
+ * End:
+ */