summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2013-06-11 08:19:56 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2013-06-11 08:19:56 (GMT)
commit8aa1ab62e1501d779f07a7c0df073f852b5dce4d (patch)
tree0a9b5a6c169615e6e9b9dae2591a2976e0975d33 /generic
parent7585d9a6fde12d67972b07247cb3e527ad224f51 (diff)
downloadtcl-8aa1ab62e1501d779f07a7c0df073f852b5dce4d.zip
tcl-8aa1ab62e1501d779f07a7c0df073f852b5dce4d.tar.gz
tcl-8aa1ab62e1501d779f07a7c0df073f852b5dce4d.tar.bz2
Move the disassembler to its own file.
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCompile.c785
-rw-r--r--generic/tclCompile.h18
-rw-r--r--generic/tclDisassemble.c1045
-rw-r--r--generic/tclProc.c258
4 files changed, 1072 insertions, 1034 deletions
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index c361430..f93bbad 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -576,11 +576,6 @@ static void RegisterAuxDataType(const AuxDataType *typePtr);
static int SetByteCodeFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
static void StartExpanding(CompileEnv *envPtr);
-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);
/*
* TIP #280: Helper for building the per-word line information of all compiled
@@ -619,19 +614,6 @@ static const Tcl_ObjType substCodeType = {
};
/*
- * 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 */
-};
-
-/*
* Helper macros.
*/
@@ -4411,773 +4393,6 @@ EncodeCmdLocMap(
return p;
}
-#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);
-}
-
#ifdef TCL_COMPILE_STATS
/*
*----------------------------------------------------------------------
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 9af4911..f28403d 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -48,6 +48,13 @@ MODULE_SCOPE int tclTraceCompile;
MODULE_SCOPE int tclTraceExec;
#endif
+
+/*
+ * The type of lambda expressions. Note that every lambda will *always* have a
+ * string representation.
+ */
+
+MODULE_SCOPE const Tcl_ObjType tclLambdaType;
/*
*------------------------------------------------------------------------
@@ -1099,12 +1106,15 @@ MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr);
MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
Tcl_Obj *valuePtr);
MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp,
- const char *script,
- const char *command, int length,
- const unsigned char *pc, Tcl_Obj **tosPtr);
+ const char *script, const char *command,
+ int length, const unsigned char *pc,
+ Tcl_Obj **tosPtr);
MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp,
- const unsigned char *pc, Tcl_Obj **tosPtr);
+ const unsigned char *pc, Tcl_Obj **tosPtr);
MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
+MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
+ register Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[], int isLambda);
/*
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:
+ */
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 18985a1..23d8e70 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -15,7 +15,6 @@
#include "tclInt.h"
#include "tclCompile.h"
-#include "tclOOInt.h"
/*
* Variables that are part of the [apply] command implementation and which
@@ -41,9 +40,6 @@ static void InitResolvedLocals(Tcl_Interp *interp,
ByteCode *codePtr, Var *defPtr,
Namespace *nsPtr);
static void InitLocalCache(Proc *procPtr);
-static int PushProcCallFrame(ClientData clientData,
- register Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[], int isLambda);
static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void ProcBodyFree(Tcl_Obj *objPtr);
static int ProcWrongNumArgs(Tcl_Interp *interp, int skip);
@@ -95,7 +91,7 @@ static const Tcl_ObjType levelReferenceType = {
* will execute within.
*/
-static const Tcl_ObjType lambdaType = {
+const Tcl_ObjType tclLambdaType = {
"lambdaExpr", /* name */
FreeLambdaInternalRep, /* freeIntRepProc */
DupLambdaInternalRep, /* dupIntRepProc */
@@ -221,7 +217,7 @@ Tcl_ProcObjCmd(
*
* This code is nearly identical to the #280 code in SetLambdaFromAny, see
* this file. The differences are the different index of the body in the
- * line array of the context, and the lamdba code requires some special
+ * line array of the context, and the lambda code requires some special
* processing. Find a way to factor the common elements into a single
* function.
*/
@@ -1571,7 +1567,7 @@ InitArgsAndLocals(
/*
*----------------------------------------------------------------------
*
- * PushProcCallFrame --
+ * TclPushProcCallFrame --
*
* Compiles a proc body if necessary, then pushes a CallFrame suitable
* for executing it.
@@ -1586,8 +1582,8 @@ InitArgsAndLocals(
*----------------------------------------------------------------------
*/
-static int
-PushProcCallFrame(
+int
+TclPushProcCallFrame(
ClientData clientData, /* Record describing procedure to be
* interpreted. */
register Tcl_Interp *interp,/* Interpreter in which procedure was
@@ -1708,7 +1704,7 @@ TclNRInterpProc(
* procedure. */
Tcl_Obj *const objv[]) /* Argument value objects. */
{
- int result = PushProcCallFrame(clientData, interp, objc, objv,
+ int result = TclPushProcCallFrame(clientData, interp, objc, objv,
/*isLambda*/ 0);
if (result != TCL_OK) {
@@ -2451,7 +2447,7 @@ DupLambdaInternalRep(
procPtr->refCount++;
Tcl_IncrRefCount(nsObjPtr);
- copyPtr->typePtr = &lambdaType;
+ copyPtr->typePtr = &tclLambdaType;
}
static void
@@ -2488,7 +2484,7 @@ SetLambdaFromAny(
/*
* Convert objPtr to list type first; if it cannot be converted, or if its
- * length is not 2, then it cannot be converted to lambdaType.
+ * length is not 2, then it cannot be converted to tclLambdaType.
*/
result = TclListObjGetElements(NULL, objPtr, &objc, &objv);
@@ -2634,14 +2630,14 @@ SetLambdaFromAny(
/*
* Free the list internalrep of objPtr - this will free argsPtr, but
* bodyPtr retains a reference from the Proc structure. Then finish the
- * conversion to lambdaType.
+ * conversion to tclLambdaType.
*/
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
- objPtr->typePtr = &lambdaType;
+ objPtr->typePtr = &tclLambdaType;
return TCL_OK;
}
@@ -2692,12 +2688,12 @@ TclNRApplyObjCmd(
}
/*
- * Set lambdaPtr, convert it to lambdaType in the current interp if
+ * Set lambdaPtr, convert it to tclLambdaType in the current interp if
* necessary.
*/
lambdaPtr = objv[1];
- if (lambdaPtr->typePtr == &lambdaType) {
+ if (lambdaPtr->typePtr == &tclLambdaType) {
procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
}
@@ -2775,7 +2771,7 @@ TclNRApplyObjCmd(
}
extraPtr->isRootEnsemble = isRootEnsemble;
- result = PushProcCallFrame(procPtr, interp, objc, objv, 1);
+ result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1);
if (result == TCL_OK) {
TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL);
result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError);
@@ -2835,234 +2831,6 @@ MakeLambdaError(
}
/*
- *----------------------------------------------------------------------
- *
- * 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 == &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);
- 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 = PushProcCallFrame(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