/*
* 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-2016 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_Interp *interp,
Tcl_Obj *objPtr);
static Tcl_Obj * DisassembleByteCodeObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
static int FormatInstruction(ByteCode *codePtr,
const unsigned char *pc, Tcl_Obj *bufferObj);
static void GetLocationInformation(Proc *procPtr,
Tcl_Obj **fileObjPtr, int *linePtr);
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)
/*
*----------------------------------------------------------------------
*
* GetLocationInformation --
*
* This procedure looks up the information about where a procedure was
* originally declared.
*
* Results:
* Writes to the variables pointed at by fileObjPtr and linePtr.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
GetLocationInformation(
Proc *procPtr, /* What to look up the information for. */
Tcl_Obj **fileObjPtr, /* Where to write the information about what
* file the code came from. Will be written
* to, either with the object (assume shared!)
* that describes what the file was, or with
* NULL if the information is not
* available. */
int *linePtr) /* Where to write the information about what
* line number represented the start of the
* code in question. Will be written to,
* either with the line number or with -1 if
* the information is not available. */
{
CmdFrame *cfPtr = TclGetCmdFrameForProcedure(procPtr);
*fileObjPtr = NULL;
*linePtr = -1;
if (cfPtr == NULL) {
return;
}
/*
* Get the source location data out of the CmdFrame.
*/
*linePtr = cfPtr->line[0];
if (cfPtr->type == TCL_LOCATION_SOURCE) {
*fileObjPtr = cfPtr->data.eval.path;
}
}
#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 getting location info. */
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
Tcl_Obj *bufPtr = DisassembleByteCodeObj(interp, 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 */
/*
*----------------------------------------------------------------------
*
* DisassembleByteCodeObj --
*
* 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.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
DisassembleByteCodeObj(
Tcl_Interp *interp,
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, line;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
Tcl_Obj *bufferObj, *fileObj;
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));
GetLocationInformation(codePtr->procPtr, &fileObj, &line);
if (line > -1 && fileObj != NULL) {
Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d",
Tcl_GetString(fileObj), line);
}
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("DisassembleByteCodeObj: 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;
if (stringPtr == NULL) {
Tcl_AppendToObj(appendObj, "\"\"", -1);
return;
}
Tcl_AppendToObj(appendObj, "\"", -1);
p = stringPtr;
for (; (*p != '\0') && (i < maxChars); p+=len) {
int ucs4;
len = TclUtfToUCS4(p, &ucs4);
switch (ucs4) {
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 (ucs4 > 0xFFFF) {
Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ucs4);
i += 10;
} else if (ucs4 < 0x20 || ucs4 >= 0x7F) {
Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ucs4);
i += 6;
} else {
Tcl_AppendPrintfToObj(appendObj, "%c", ucs4);
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_Interp *interp, /* Used for looking up the CmdFrame for the
* procedure, if one exists. */
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, *file;
unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr;
int codeOffset, codeLength, sourceOffset, sourceLength;
int i, val, line;
/*
* 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
/*
* Get the source file and line number information from the CmdFrame
* system if it is available.
*/
GetLocationInformation(codePtr->procPtr, &file, &line);
/*
* 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));
if (line > -1) {
Tcl_DictObjPut(NULL, description,
Tcl_NewStringObj("initiallinenumber", -1),
Tcl_NewIntObj(line));
}
if (file) {
Tcl_DictObjPut(NULL, description,
Tcl_NewStringObj("sourcefile", -1), file);
}
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[] = {
"constructor", "destructor",
"lambda", "method", "objmethod", "proc", "script", NULL
};
enum Types {
DISAS_CLASS_CONSTRUCTOR, DISAS_CLASS_DESTRUCTOR,
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;
Method *methodPtr;
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_CONSTRUCTOR:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "className");
return TCL_ERROR;
}
/*
* Look up the body of a constructor.
*/
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;
}
methodPtr = oPtr->classPtr->constructorPtr;
if (methodPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" has no defined constructor",
TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"CONSRUCTOR", NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(methodPtr);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of constructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"METHODTYPE", NULL);
return TCL_ERROR;
}
/*
* Compile if necessary.
*/
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 constructor",
TclGetString(objv[2]));
procPtr->cmdPtr = NULL;
if (result != TCL_OK) {
return result;
}
}
codeObjPtr = procPtr->bodyPtr;
break;
case DISAS_CLASS_DESTRUCTOR:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "className");
return TCL_ERROR;
}
/*
* Look up the body of a destructor.
*/
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;
}
methodPtr = oPtr->classPtr->destructorPtr;
if (methodPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" has no defined destructor",
TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"DESRUCTOR", NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(methodPtr);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of destructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"METHODTYPE", NULL);
return TCL_ERROR;
}
/*
* Compile if necessary.
*/
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 destructor",
TclGetString(objv[2]));
procPtr->cmdPtr = NULL;
if (result != TCL_OK) {
return result;
}
}
codeObjPtr = procPtr->bodyPtr;
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(interp, codeObjPtr));
} else {
Tcl_SetObjResult(interp,
DisassembleByteCodeObj(interp, codeObjPtr));
}
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* End:
*/