/* * 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 /* * 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: */