summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog61
-rw-r--r--generic/tclBasic.c17
-rw-r--r--generic/tclCompCmds.c46
-rw-r--r--generic/tclCompile.c354
-rw-r--r--generic/tclCompile.h21
-rw-r--r--generic/tclInt.h6
-rw-r--r--generic/tclProc.c128
7 files changed, 440 insertions, 193 deletions
diff --git a/ChangeLog b/ChangeLog
index 6d223ca..96f7379 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2007-09-25 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
+
+ * generic/tclProc.c (Tcl_DisassembleObjCmd): Define a command,
+ ::tcl::unsupported::disassemble, which can disassemble procedures,
+ lambdas and general scripts.
+ * generic/tclCompile.c (TclDisassembleByteCodeObj): Split apart the
+ code to print disassemblies of bytecode so that there is reusable code
+ that spits it out in a Tcl_Obj and then that code is used when doing
+ tracing.
+
2007-09-20 Don Porter <dgp@users.sourceforge.net>
*** 8.5b1 TAGGED FOR RELEASE ***
@@ -8,31 +18,31 @@
* README: Bump version number to 8.5b1
* generic/tcl.h: Merge from core-stabilizer-branch.
- * library/init.tcl: Stabilizing toward 8.5b1 release now done
- * tools/tcl.wse.in: on the HEAD. core-stabilizer-branch is
- * unix/configure.in: now suspended.
+ * library/init.tcl: Stabilizing toward 8.5b1 release now done on
+ * tools/tcl.wse.in: the HEAD. core-stabilizer-branch is now
+ * unix/configure.in: suspended.
* unix/tcl.spec:
* win/configure.in:
2007-09-19 Pat Thoyts <patthoyts@users.sourceforge.net>
-
+
* generic/tclStubLib.: Replaced isdigit with internal implementation.
2007-09-18 Don Porter <dgp@users.sourceforge.net>
- * generic/tclStubLib.c: Remove C library calls from Tcl_InitStubs()
- * win/makefile.vc: so that we don't need the C library linked
- in to libtclStub.
+ * generic/tclStubLib.c: Remove C library calls from Tcl_InitStubs() so
+ * win/makefile.vc: that we don't need the C library linked in to
+ libtclStub.
2007-09-17 Pat Thoyts <patthoyts@users.sourceforge.net>
- * win/makefile.vc: Add crt flags for tclStubLib now it uses
- C-library functions
+ * win/makefile.vc: Add crt flags for tclStubLib now it uses C-library
+ functions.
2007-09-17 Joe English <jenglish@users.sourceforge.net>
- * tcl.m4: use '${CC} -shared' instead of 'ld -Bshareable'
- to build shared libraries on current NetBSDs [#1749251].
+ * tcl.m4: use '${CC} -shared' instead of 'ld -Bshareable' to build
+ shared libraries on current NetBSDs. [Bug 1749251]
* unix/configure: regenerated (autoconf-2.59).
2007-09-17 Don Porter <dgp@users.sourceforge.net>
@@ -42,12 +52,12 @@
* generic/tcl.h: Revised Tcl_InitStubs() to restore Tcl 8.4
* generic/tclPkg.c: source compatibility with callers of
- * generic/tclStubLib.c: Tcl_InitStubs(interp, TCL_VERSION, 1).
- [Bug 1578344].
+ * generic/tclStubLib.c: Tcl_InitStubs(interp, TCL_VERSION, 1). [Bug
+ 1578344]
2007-09-17 Donal K. Fellows <donal.k.fellows@man.ac.uk>
- * generic/tclTrace.c (Tcl_TraceObjCmd, TraceExecutionObjCmd)
+ * generic/tclTrace.c (Tcl_TraceObjCmd, TraceExecutionObjCmd)
(TraceCommandObjCmd, TraceVariableObjCmd): Generate literal values
* generic/tclNamesp.c (NamespaceCodeCmd): more efficiently using
* generic/tclFCmd.c (CopyRenameOneFile): TclNewLiteralStringObj
@@ -120,7 +130,7 @@
* generic/tclCompCmds.c (TclCompileDictCmd-update):
* generic/tclCompile.c (tclInstructionTable):
* generic/tclExecute.c (INST_DICT_UPDATE_END): fix stack management in
- [dict update]. [Bug 1786481]
+ compiled [dict update]. [Bug 1786481]
***POTENTIAL INCOMPATIBILITY***
Scripts that were precompiled on earlier versions of 8.5 and use [dict
@@ -184,8 +194,8 @@
2007-09-08 Miguel Sofer <msofer@users.sf.net>
- * generic/tclVar.c (Tcl_SetVar2, TclPtrSetVar): [Bug 1710710]
- fixed correctly, reverted fix of 2007-05-01.
+ * generic/tclVar.c (Tcl_SetVar2, TclPtrSetVar): [Bug 1710710] fixed
+ correctly, reverted fix of 2007-05-01.
2007-09-08 Donal K. Fellows <dkf@users.sf.net>
@@ -365,8 +375,8 @@
2007-08-24 Miguel Sofer <msofer@users.sf.net>
- * generic/tclCompile.c: replaced copy loop that tripped some
- compilers with memmove [Bug 1780870]
+ * generic/tclCompile.c: replaced copy loop that tripped some compilers
+ with memmove. [Bug 1780870]
2007-08-23 Don Porter <dgp@users.sourceforge.net>
@@ -490,7 +500,7 @@
2007-08-10 Miguel Sofer <msofer@users.sf.net>
- * generic/tclInt.h: remove redundant ops in TclNewStringObj macro
+ * generic/tclInt.h: remove redundant ops in TclNewStringObj macro.
2007-08-10 Miguel Sofer <msofer@users.sf.net>
@@ -537,10 +547,8 @@
non-resolved case, as the function is never called in that case.
Renamed the function to InitResolvedLocals to calrify the point.
-2007-08-07 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.decls: Exporting via stubs to help
- * generic/tclInt.h: xotcl adapt to VarReform.
+ * generic/tclInt.decls: Exporting via stubs to help xotcl adapt to
+ * generic/tclInt.h: VarReform.
* generic/tclIntDecls.h:
* generic/tclStubInit.c:
@@ -574,9 +582,8 @@
* generic/tclGetDate.y: Added a cast to the definition of YYFREE to
silence compiler warnings.
* generic/tclDate.c: Regenerated
- * win/tclWinTest.c: Added a cast to the call to
- GetSecurityDescriptorDacl to silence compiler
- warnings.
+ * win/tclWinTest.c: Added a cast to GetSecurityDescriptorDacl call
+ to silence compiler warnings.
2007-08-04 Miguel Sofer <msofer@users.sf.net>
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index f06c029..69f1e98 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.269 2007/09/14 14:58:07 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.270 2007/09/25 20:27:17 dkf Exp $
*/
#include "tclInt.h"
@@ -472,12 +472,12 @@ Tcl_CreateInterp(void)
/*
* Initialise the tables for variable traces and searches *before*
* creating the global ns - so that the trace on errorInfo can be
- * recorded.
+ * recorded.
*/
-
+
Tcl_InitHashTable(&iPtr->varTraces, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&iPtr->varSearches, TCL_ONE_WORD_KEYS);
-
+
iPtr->globalNsPtr = NULL; /* Force creation of global ns below */
iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
(ClientData) NULL, NULL);
@@ -656,6 +656,13 @@ Tcl_CreateInterp(void)
Tcl_CreateObjCommand(interp, "::tcl::Bgerror",
TclDefaultBgErrorHandlerObjCmd, NULL, NULL);
+ /*
+ * Create an unsupported command for debugging bytecode.
+ */
+
+ Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
+ Tcl_DisassembleObjCmd, NULL, NULL);
+
#ifdef USE_DTRACE
/*
* Register the tcl::dtrace command.
@@ -3386,7 +3393,7 @@ TclInterpReady(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp,
"attempt to call eval in deleted interpreter", NULL);
- Tcl_SetErrorCode(interp, "CORE", "IDELETE",
+ Tcl_SetErrorCode(interp, "TCL", "IDELETE",
"attempt to call eval in deleted interpreter", NULL);
return TCL_ERROR;
}
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 67f8961..5c5831b 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompCmds.c,v 1.119 2007/09/11 14:47:41 msofer Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.120 2007/09/25 20:27:17 dkf Exp $
*/
#include "tclInt.h"
@@ -138,15 +138,18 @@
static ClientData DupDictUpdateInfo(ClientData clientData);
static void FreeDictUpdateInfo(ClientData clientData);
static void PrintDictUpdateInfo(ClientData clientData,
- ByteCode *codePtr, unsigned int pcOffset);
+ Tcl_Obj *appendObj, ByteCode *codePtr,
+ unsigned int pcOffset);
static ClientData DupForeachInfo(ClientData clientData);
static void FreeForeachInfo(ClientData clientData);
static void PrintForeachInfo(ClientData clientData,
- ByteCode *codePtr, unsigned int pcOffset);
+ Tcl_Obj *appendObj, ByteCode *codePtr,
+ unsigned int pcOffset);
static ClientData DupJumptableInfo(ClientData clientData);
static void FreeJumptableInfo(ClientData clientData);
static void PrintJumptableInfo(ClientData clientData,
- ByteCode *codePtr, unsigned int pcOffset);
+ Tcl_Obj *appendObj, ByteCode *codePtr,
+ unsigned int pcOffset);
static int PushVarName(Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr,
int flags, int *localIndexPtr,
@@ -1140,6 +1143,7 @@ FreeDictUpdateInfo(
static void
PrintDictUpdateInfo(
ClientData clientData,
+ Tcl_Obj *appendObj,
ByteCode *codePtr,
unsigned int pcOffset)
{
@@ -1148,9 +1152,9 @@ PrintDictUpdateInfo(
for (i=0 ; i<duiPtr->length ; i++) {
if (i) {
- fprintf(stdout, ", ");
+ Tcl_AppendToObj(appendObj, ", ", -1);
}
- fprintf(stdout, "%%v%u", duiPtr->varIndices[i]);
+ Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]);
}
}
@@ -1787,6 +1791,7 @@ FreeForeachInfo(
static void
PrintForeachInfo(
ClientData clientData,
+ Tcl_Obj *appendObj,
ByteCode *codePtr,
unsigned int pcOffset)
{
@@ -1794,29 +1799,32 @@ PrintForeachInfo(
register ForeachVarList *varsPtr;
int i, j;
- fprintf(stdout, "data=[");
+ Tcl_AppendToObj(appendObj, "data=[", -1);
for (i=0 ; i<infoPtr->numLists ; i++) {
if (i) {
- fprintf(stdout, ", ");
+ Tcl_AppendToObj(appendObj, ", ", -1);
}
- fprintf(stdout, "%%v%u", (unsigned) (infoPtr->firstValueTemp + i));
+ Tcl_AppendPrintfToObj(appendObj, "%%v%u",
+ (unsigned) (infoPtr->firstValueTemp + i));
}
- fprintf(stdout, "], loop=%%v%u", (unsigned) infoPtr->loopCtTemp);
+ Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u",
+ (unsigned) infoPtr->loopCtTemp);
for (i=0 ; i<infoPtr->numLists ; i++) {
if (i) {
- fprintf(stdout, ",");
+ Tcl_AppendToObj(appendObj, ",", -1);
}
- fprintf(stdout, "\n\t\t it%%v%u\t[",
+ Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%u\t[",
(unsigned) (infoPtr->firstValueTemp + i));
varsPtr = infoPtr->varLists[i];
for (j=0 ; j<varsPtr->numVars ; j++) {
if (j) {
- fprintf(stdout, ", ");
+ Tcl_AppendToObj(appendObj, ", ", -1);
}
- fprintf(stdout, "%%v%u", (unsigned) varsPtr->varIndexes[j]);
+ Tcl_AppendPrintfToObj(appendObj, "%%v%u",
+ (unsigned) varsPtr->varIndexes[j]);
}
- fprintf(stdout, "]");
+ Tcl_AppendToObj(appendObj, "]", -1);
}
}
@@ -4305,6 +4313,7 @@ FreeJumptableInfo(
static void
PrintJumptableInfo(
ClientData clientData,
+ Tcl_Obj *appendObj,
ByteCode *codePtr,
unsigned int pcOffset)
{
@@ -4320,12 +4329,13 @@ PrintJumptableInfo(
offset = PTR2INT(Tcl_GetHashValue(hPtr));
if (i++) {
- fprintf(stdout, ", ");
+ Tcl_AppendToObj(appendObj, ", ", -1);
if (i%4==0) {
- fprintf(stdout, "\n\t\t");
+ Tcl_AppendToObj(appendObj, "\n\t\t", -1);
}
}
- fprintf(stdout, "\"%s\"->pc %d", keyPtr, pcOffset + offset);
+ Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d",
+ keyPtr, pcOffset + offset);
}
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 6ae3aaf..d4c5d9e 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.c,v 1.133 2007/09/11 14:47:42 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.134 2007/09/25 20:27:17 dkf Exp $
*/
#include "tclInt.h"
@@ -376,10 +376,10 @@ InstructionDesc tclInstructionTable[] = {
/* finds level and otherName in stack, links to local variable at
* index op1. Leaves the level on stack. */
{"nsupvar", 5, 0, 1, {OPERAND_LVT4}},
- /* finds namespace and otherName in stack, links to local variable at
+ /* finds namespace and otherName in stack, links to local variable at
* index op1. Leaves the namespace on stack. */
{"variable", 5, 0, 1, {OPERAND_LVT4}},
- /* finds namespace and otherName in stack, links to local variable at
+ /* finds namespace and otherName in stack, links to local variable at
* index op1. Leaves the namespace on stack. */
{"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}},
/* Compiled bytecodes to signal syntax error. */
@@ -407,6 +407,10 @@ static void RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */
static int SetByteCodeFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
+static int FormatInstruction(ByteCode *codePtr,
+ unsigned char *pc, Tcl_Obj *bufferObj);
+static void PrintSourceToObj(Tcl_Obj *appendObj,
+ const char *stringPtr, int maxChars);
/*
* TIP #280: Helper for building the per-word line information of all compiled
* commands.
@@ -720,7 +724,7 @@ TclCleanupByteCode(
* 1) decrement the ref counts of the LiteralEntry's in its literal array,
* 2) call the free procs for the auxiliary data items, 3) free the
* localCache if it is unused, and finally 4) free the ByteCode
- * structure's heap object.
+ * structure's heap object.
*
* The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, like
* those generated from tbcload) is special, as they doesn't make use of
@@ -916,7 +920,7 @@ TclInitCompileEnv(
ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
*ctxPtr = *invoker;
-
+
if (invoker->type == TCL_LOCATION_BC) {
/*
* Note: Type BC => ctx.data.eval.path is not used.
@@ -1162,7 +1166,7 @@ TclCompileScript(
if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) {
/* Compile bytecodes to report the parse error at runtime. */
- Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
+ Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
/* Drop the command terminator (";","]") if appropriate */
(parsePtr->term ==
parsePtr->commandStart + parsePtr->commandSize - 1)?
@@ -1330,7 +1334,7 @@ TclCompileScript(
* case. [Bug 1752146]
* Note that the environment is initialised with
* atCmdStart=1 to avoid emitting ISC for the first
- * command.
+ * command.
*/
if (envPtr->atCmdStart) {
@@ -1341,9 +1345,9 @@ TclCompileScript(
* this depends on the exact layout of the
* INST_START_CMD's operands, so be careful!
*/
-
+
unsigned char *fixPtr = envPtr->codeNext - 4;
-
+
TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)+1,
fixPtr);
}
@@ -1828,7 +1832,7 @@ TclCompileExprWords(
* Side effects:
* Instructions are added to envPtr to execute a no-op at runtime. No
* result is pushed onto the stack: the compiler has to take care of this
- * itself if the last compiled command is a NoOp.
+ * itself if the last compiled command is a NoOp.
*
*----------------------------------------------------------------------
*/
@@ -3207,15 +3211,135 @@ TclPrintByteCodeObj(
Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
- ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ 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. */
+ unsigned char *pc) /* Points to first byte of instruction. */
+{
+ Tcl_Obj *bufferObj;
+
+ TclNewObj(bufferObj);
+ 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, 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.otherValuePtr;
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; /* already freed */
+ return bufferObj; /* Already freed. */
}
codeStart = codePtr->codeStart;
@@ -3226,14 +3350,17 @@ TclPrintByteCodeObj(
* Print header lines describing the ByteCode.
*/
- fprintf(stdout,
- "\nByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n",
- codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
+ 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);
- fprintf(stdout, " Source ");
- TclPrintSource(stdout, codePtr->source,
+ Tcl_AppendToObj(bufferObj, " Source ", -1);
+ PrintSourceToObj(bufferObj, codePtr->source,
TclMin(codePtr->numSrcBytes, 55));
- fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
+ 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,
@@ -3244,7 +3371,7 @@ TclPrintByteCodeObj(
0.0);
#ifdef TCL_COMPILE_STATS
- fprintf(stdout,
+ 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))),
@@ -3264,14 +3391,18 @@ TclPrintByteCodeObj(
if (codePtr->procPtr != NULL) {
Proc *procPtr = codePtr->procPtr;
int numCompiledLocals = procPtr->numCompiledLocals;
- fprintf(stdout,
- " Proc 0x%p, refCt %d, args %d, compiled locals %d\n",
- procPtr, procPtr->refCount, procPtr->numArgs,
+
+ 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++) {
- fprintf(stdout, " slot %d%s%s%s%s%s%s", 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" : "",
@@ -3279,9 +3410,10 @@ TclPrintByteCodeObj(
(localPtr->flags & VAR_TEMPORARY) ? ", temp" : "",
(localPtr->flags & VAR_RESOLVED) ? ", resolved" : "");
if (TclIsVarTemporary(localPtr)) {
- fprintf(stdout, "\n");
+ Tcl_AppendToObj(bufferObj, "\n", -1);
} else {
- fprintf(stdout, ", \"%s\"\n", localPtr->name);
+ Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n",
+ localPtr->name);
}
localPtr = localPtr->nextPtr;
}
@@ -3293,25 +3425,28 @@ TclPrintByteCodeObj(
*/
if (codePtr->numExceptRanges > 0) {
- fprintf(stdout, " Exception ranges %d, depth %d:\n",
+ 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]);
- fprintf(stdout, " %d: level %d, %s, pc %d-%d, ",
+
+ 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:
- fprintf(stdout, "continue %d, break %d\n",
+ Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n",
rangePtr->continueOffset, rangePtr->breakOffset);
break;
case CATCH_EXCEPTION_RANGE:
- fprintf(stdout, "catch %d\n", rangePtr->catchOffset);
+ Tcl_AppendPrintfToObj(bufferObj, "catch %d\n",
+ rangePtr->catchOffset);
break;
default:
- Tcl_Panic("TclPrintByteCodeObj: bad ExceptionRange type %d",
+ Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d",
rangePtr->type);
}
}
@@ -3325,10 +3460,10 @@ TclPrintByteCodeObj(
if (numCmds == 0) {
pc = codeStart;
while (pc < codeLimit) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
+ Tcl_AppendToObj(bufferObj, " ", -1);
+ pc += FormatInstruction(codePtr, pc, bufferObj);
}
- return;
+ return bufferObj;
}
/*
@@ -3336,7 +3471,7 @@ TclPrintByteCodeObj(
* for each command. These are encoded as a sequence of bytes.
*/
- fprintf(stdout, " Commands %d:", numCmds);
+ Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds);
codeDeltaNext = codePtr->codeDeltaStart;
codeLengthNext = codePtr->codeLengthStart;
srcDeltaNext = codePtr->srcDeltaStart;
@@ -3381,13 +3516,13 @@ TclPrintByteCodeObj(
srcLengthNext++;
}
- fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d",
+ 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) {
- fprintf(stdout, "\n");
+ Tcl_AppendToObj(bufferObj, "\n", -1);
}
/*
@@ -3436,14 +3571,14 @@ TclPrintByteCodeObj(
*/
while ((pc-codeStart) < codeOffset) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
+ Tcl_AppendToObj(bufferObj, " ", -1);
+ pc += FormatInstruction(codePtr, pc, bufferObj);
}
- fprintf(stdout, " Command %d: ", (i+1));
- TclPrintSource(stdout, (codePtr->source + srcOffset),
+ Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1);
+ PrintSourceToObj(bufferObj, (codePtr->source + srcOffset),
TclMin(srcLen, 55));
- fprintf(stdout, "\n");
+ Tcl_AppendToObj(bufferObj, "\n", -1);
}
if (pc < codeLimit) {
/*
@@ -3451,43 +3586,37 @@ TclPrintByteCodeObj(
*/
while (pc < codeLimit) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
+ Tcl_AppendToObj(bufferObj, " ", -1);
+ pc += FormatInstruction(codePtr, pc, bufferObj);
}
}
+ return bufferObj;
}
/*
*----------------------------------------------------------------------
*
- * TclPrintInstruction --
+ * FormatInstruction --
*
- * 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.
+ * Appends a representation of a bytecode instruction to a Tcl_Obj.
*
*----------------------------------------------------------------------
*/
-int
-TclPrintInstruction(
+static int
+FormatInstruction(
ByteCode *codePtr, /* Bytecode containing the instruction. */
- unsigned char *pc) /* Points to first byte of instruction. */
+ 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 InstructionDesc *instDesc = &tclInstructionTable[opCode];
unsigned char *codeStart = codePtr->codeStart;
unsigned int pcOffset = (pc - codeStart);
- int opnd, i, j, numBytes = 1;
+ int opnd = 0, i, j, numBytes = 1;
int localCt = procPtr ? procPtr->numCompiledLocals : 0;
CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL;
-
char suffixBuffer[64]; /* Additional info to print after main opcode
* and immediates. */
char *suffixSrc = NULL;
@@ -3495,7 +3624,7 @@ TclPrintInstruction(
AuxData *auxPtr = NULL;
suffixBuffer[0] = '\0';
- fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
+ Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name);
for (i = 0; i < instDesc->numOperands; i++) {
switch (instDesc->opTypes[i]) {
case OPERAND_INT1:
@@ -3504,7 +3633,7 @@ TclPrintInstruction(
|| opCode == INST_JUMP_FALSE1) {
sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
}
- fprintf(stdout, "%+d ", opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
break;
case OPERAND_INT4:
opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
@@ -3514,14 +3643,14 @@ TclPrintInstruction(
} else if (opCode == INST_START_CMD) {
sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd);
}
- fprintf(stdout, "%+d ", opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
break;
case OPERAND_UINT1:
opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
if (opCode == INST_PUSH1) {
suffixObj = codePtr->objArrayPtr[opnd];
}
- fprintf(stdout, "%u ", (unsigned int) opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned int) opnd);
break;
case OPERAND_AUX4:
case OPERAND_UINT4:
@@ -3531,7 +3660,7 @@ TclPrintInstruction(
} else if (opCode == INST_START_CMD && opnd != 1) {
sprintf(suffixBuffer, ", %u cmds start here", opnd);
}
- fprintf(stdout, "%u ", (unsigned int) opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned int) opnd);
if (instDesc->opTypes[i] == OPERAND_AUX4) {
auxPtr = &codePtr->auxDataArrayPtr[opnd];
}
@@ -3539,11 +3668,11 @@ TclPrintInstruction(
case OPERAND_IDX4:
opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
if (opnd >= -1) {
- fprintf(stdout, "%d ", opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd);
} else if (opnd == -2) {
- fprintf(stdout, "end ");
+ Tcl_AppendPrintfToObj(bufferObj, "end ");
} else {
- fprintf(stdout, "end-%d ", -2-opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd);
}
break;
case OPERAND_LVT1:
@@ -3556,7 +3685,7 @@ TclPrintInstruction(
printLVTindex:
if (localPtr != NULL) {
if (opnd >= localCt) {
- Tcl_Panic("TclPrintInstruction: bad local var index %u (%u locals)",
+ Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)",
(unsigned int) opnd, localCt);
}
for (j = 0; j < opnd; j++) {
@@ -3569,7 +3698,7 @@ TclPrintInstruction(
suffixSrc = localPtr->name;
}
}
- fprintf(stdout, "%%v%u ", (unsigned) opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd);
break;
case OPERAND_NONE:
default:
@@ -3577,19 +3706,24 @@ TclPrintInstruction(
}
}
if (suffixObj) {
- fprintf(stdout, "\t# ");
- TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
+ 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]) {
- fprintf(stdout, "\t# %s", suffixBuffer);
+ Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
if (suffixSrc) {
- TclPrintSource(stdout, suffixSrc, 40);
+ PrintSourceToObj(bufferObj, suffixSrc, 40);
}
}
- fprintf(stdout, "\n");
+ Tcl_AppendToObj(bufferObj, "\n", -1);
if (auxPtr && auxPtr->type->printProc) {
- fprintf(stdout, "\t\t[");
- auxPtr->type->printProc(auxPtr->clientData, codePtr, pcOffset);
- fprintf(stdout, "]\n");
+ Tcl_AppendToObj(bufferObj, "\t\t[", -1);
+ auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr,
+ pcOffset);
+ Tcl_AppendToObj(bufferObj, "]\n", -1);
}
return numBytes;
}
@@ -3597,55 +3731,16 @@ TclPrintInstruction(
/*
*----------------------------------------------------------------------
*
- * TclPrintObject --
+ * PrintSourceToObj --
*
- * 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.
+ * Appends a quoted representation of a string to a Tcl_Obj.
*
*----------------------------------------------------------------------
*/
-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. */
+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. */
{
@@ -3653,40 +3748,39 @@ TclPrintSource(
register int i = 0;
if (stringPtr == NULL) {
- fprintf(outFile, "\"\"");
+ Tcl_AppendToObj(appendObj, "\"\"", -1);
return;
}
- fprintf(outFile, "\"");
+ Tcl_AppendToObj(appendObj, "\"", -1);
p = stringPtr;
for (; (*p != '\0') && (i < maxChars); p++, i++) {
switch (*p) {
case '"':
- fprintf(outFile, "\\\"");
+ Tcl_AppendToObj(appendObj, "\\\"", -1);
continue;
case '\f':
- fprintf(outFile, "\\f");
+ Tcl_AppendToObj(appendObj, "\\f", -1);
continue;
case '\n':
- fprintf(outFile, "\\n");
+ Tcl_AppendToObj(appendObj, "\\n", -1);
continue;
case '\r':
- fprintf(outFile, "\\r");
+ Tcl_AppendToObj(appendObj, "\\r", -1);
continue;
case '\t':
- fprintf(outFile, "\\t");
+ Tcl_AppendToObj(appendObj, "\\t", -1);
continue;
case '\v':
- fprintf(outFile, "\\v");
+ Tcl_AppendToObj(appendObj, "\\v", -1);
continue;
default:
- fprintf(outFile, "%c", *p);
+ Tcl_AppendPrintfToObj(appendObj, "%c", *p);
continue;
}
}
- fprintf(outFile, "\"");
+ Tcl_AppendToObj(appendObj, "\"", -1);
}
-#endif /* TCL_COMPILE_DEBUG */
#ifdef TCL_COMPILE_STATS
/*
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 3db6da9..0afc13b 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.h,v 1.79 2007/09/13 15:27:07 das Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.80 2007/09/25 20:27:17 dkf Exp $
*/
#ifndef _TCLCOMPILATION
@@ -128,19 +128,19 @@ typedef struct CmdLocation {
*/
typedef struct ECL {
- int srcOffset; /* Command location to find the entry. */
- int nline;
- int *line; /* Line information for all words in the
+ int srcOffset; /* Command location to find the entry. */
+ int nline;
+ int *line; /* Line information for all words in the
* command. */
} ECL;
typedef struct ExtCmdLoc {
- int type; /* Context type. */
- Tcl_Obj *path; /* Path of the sourced file the command is
+ int type; /* Context type. */
+ Tcl_Obj *path; /* Path of the sourced file the command is
* in. */
- ECL *loc; /* Command word locations (lines). */
- int nloc; /* Number of allocated entries in 'loc'. */
- int nuloc; /* Number of used entries in 'loc'. */
+ ECL *loc; /* Command word locations (lines). */
+ int nloc; /* Number of allocated entries in 'loc'. */
+ int nuloc; /* Number of used entries in 'loc'. */
} ExtCmdLoc;
/*
@@ -161,7 +161,8 @@ typedef struct ExtCmdLoc {
typedef ClientData (AuxDataDupProc) (ClientData clientData);
typedef void (AuxDataFreeProc) (ClientData clientData);
typedef void (AuxDataPrintProc)(ClientData clientData,
- struct ByteCode *codePtr, unsigned int pcOffset);
+ Tcl_Obj *appendObj, struct ByteCode *codePtr,
+ unsigned int pcOffset);
/*
* We define a separate AuxDataType struct to hold type-related information
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 9ba2331..b589085 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.335 2007/09/13 15:27:08 das Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.336 2007/09/25 20:27:17 dkf Exp $
*/
#ifndef _TCLINT
@@ -2565,6 +2565,7 @@ MODULE_SCOPE void TclFinalizeThreadStorage(void);
MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
MODULE_SCOPE Tcl_WideInt TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
#endif
+MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr);
/*
*----------------------------------------------------------------
@@ -2627,6 +2628,9 @@ MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd(
MODULE_SCOPE int Tcl_DictObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]);
+MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]);
MODULE_SCOPE int Tcl_EncodingObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]);
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 7008187..eac4033 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.134 2007/09/13 15:27:08 das Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.135 2007/09/25 20:27:18 dkf Exp $
*/
#include "tclInt.h"
@@ -1520,7 +1520,7 @@ PushProcCallFrame(
CallFrame *framePtr, **framePtrPtr;
int result;
ByteCode *codePtr;
-
+
/*
* If necessary (i.e. if we haven't got a suitable compilation already
* cached) compile the procedure's body. The compiler will allocate frame
@@ -2729,6 +2729,130 @@ MakeLambdaError(
(overflow ? "..." : ""), interp->errorLine));
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 *types[] = {
+ "lambda", "proc", "script", NULL
+ };
+ enum Types {
+ DISAS_LAMBDA, DISAS_PROC, DISAS_SCRIPT
+ };
+ int idx, result;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "type procName|lambdaTerm|script");
+ 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: {
+ Proc *procPtr = NULL;
+ Command cmd;
+ Tcl_Obj *nsObjPtr;
+ Tcl_Namespace *nsPtr;
+
+ /*
+ * Compile (if uncompiled) and disassemble a lambda term.
+ */
+
+ 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);
+ if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags
+ & TCL_BYTECODE_PRECOMPILED) {
+ Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode",
+ NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr));
+ break;
+ }
+ case DISAS_PROC: {
+ Proc *procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
+
+ if (procPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
+ "\" isn't a procedure", 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);
+ if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags
+ & TCL_BYTECODE_PRECOMPILED) {
+ Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode",
+ NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr));
+ break;
+ }
+ case DISAS_SCRIPT:
+ /*
+ * Compile and disassemble a script.
+ */
+
+ if (objv[2]->typePtr != &tclByteCodeType) {
+ if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){
+ return TCL_ERROR;
+ }
+ }
+ Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(objv[2]));
+ break;
+ }
+ return TCL_OK;
+}
+
/*
* Local Variables:
* mode: c
generated by cgit v0.12 at 2024-11-05 14:02:26 (GMT)