summaryrefslogtreecommitdiffstats
path: root/generic/tclDisassemble.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclDisassemble.c')
-rw-r--r--generic/tclDisassemble.c1045
1 files changed, 1045 insertions, 0 deletions
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
new file mode 100644
index 0000000..bc84763
--- /dev/null
+++ b/generic/tclDisassemble.c
@@ -0,0 +1,1045 @@
+/*
+ * 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 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 */
+};
+
+#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 = objPtr->internalRep.twoPtrValue.ptr1;
+ 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++;
+ if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1
+ || opCode == INST_JUMP_FALSE1) {
+ sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
+ }
+ Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
+ break;
+ case OPERAND_INT4:
+ opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
+ if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4
+ || opCode == INST_JUMP_FALSE4) {
+ sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
+ } else if (opCode == INST_START_CMD) {
+ sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd);
+ }
+ Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
+ break;
+ case OPERAND_UINT1:
+ opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
+ if (opCode == INST_PUSH1) {
+ suffixObj = codePtr->objArrayPtr[opnd];
+ }
+ Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
+ break;
+ case OPERAND_AUX4:
+ case OPERAND_UINT4:
+ opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
+ if (opCode == INST_PUSH4) {
+ suffixObj = codePtr->objArrayPtr[opnd];
+ } else if (opCode == INST_START_CMD && opnd != 1) {
+ sprintf(suffixBuffer+strlen(suffixBuffer),
+ ", %u cmds start here", opnd);
+ }
+ Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
+ if (instDesc->opTypes[i] == OPERAND_AUX4) {
+ 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_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;
+
+ if (stringPtr == NULL) {
+ Tcl_AppendToObj(appendObj, "\"\"", -1);
+ return;
+ }
+
+ Tcl_AppendToObj(appendObj, "\"", -1);
+ p = stringPtr;
+ for (; (*p != '\0') && (i < maxChars); p++, i++) {
+ switch (*p) {
+ case '"':
+ Tcl_AppendToObj(appendObj, "\\\"", -1);
+ continue;
+ case '\f':
+ Tcl_AppendToObj(appendObj, "\\f", -1);
+ continue;
+ case '\n':
+ Tcl_AppendToObj(appendObj, "\\n", -1);
+ continue;
+ case '\r':
+ Tcl_AppendToObj(appendObj, "\\r", -1);
+ continue;
+ case '\t':
+ Tcl_AppendToObj(appendObj, "\\t", -1);
+ continue;
+ case '\v':
+ Tcl_AppendToObj(appendObj, "\\v", -1);
+ continue;
+ default:
+ Tcl_AppendPrintfToObj(appendObj, "%c", *p);
+ continue;
+ }
+ }
+ Tcl_AppendToObj(appendObj, "\"", -1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 *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.
+ */
+
+ 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->internalRep.twoPtrValue.ptr1)->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;
+ }
+ Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr));
+ return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * tab-width: 8
+ * End:
+ */