summaryrefslogtreecommitdiffstats
path: root/generic/tclDisassemble.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclDisassemble.c')
-rw-r--r--generic/tclDisassemble.c149
1 files changed, 71 insertions, 78 deletions
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index 5a64ff8..f78666c 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -114,7 +114,7 @@ GetLocationInformation(
/*
*----------------------------------------------------------------------
*
- * TclPrintByteCodeObj --
+ * TclDebugPrintByteCodeObj --
*
* This procedure prints ("disassembles") the instructions of a bytecode
* object to stdout.
@@ -129,14 +129,16 @@ GetLocationInformation(
*/
void
-TclPrintByteCodeObj(
- TCL_UNUSED(Tcl_Interp *), /* Stuck with this in internal stubs */
+TclDebugPrintByteCodeObj(
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
- Tcl_Obj *bufPtr = DisassembleByteCodeObj(objPtr);
+ if (tclTraceCompile >= 2) {
+ Tcl_Obj *bufPtr = DisassembleByteCodeObj(objPtr);
- fprintf(stdout, "\n%s", TclGetString(bufPtr));
- Tcl_DecrRefCount(bufPtr);
+ fprintf(stdout, "\n%s", TclGetString(bufPtr));
+ Tcl_DecrRefCount(bufPtr);
+ fflush(stdout);
+ }
}
/*
@@ -703,8 +705,8 @@ TclGetInnerContext(
case INST_TRY_CVT_TO_NUMERIC:
case INST_EXPAND_STKTOP:
case INST_EXPR_STK:
- objc = 1;
- break;
+ objc = 1;
+ break;
case INST_LIST_IN:
case INST_LIST_NOT_IN: /* Basic list containment operators. */
@@ -731,22 +733,22 @@ TclGetInnerContext(
case INST_SUB:
case INST_DIV:
case INST_MULT:
- objc = 2;
- break;
+ objc = 2;
+ break;
case INST_RETURN_STK:
- /* early pop. TODO: dig out opt dict too :/ */
- objc = 1;
- break;
+ /* early pop. TODO: dig out opt dict too :/ */
+ objc = 1;
+ break;
case INST_SYNTAX:
case INST_RETURN_IMM:
- objc = 2;
- break;
+ objc = 2;
+ break;
case INST_INVOKE_STK4:
objc = TclGetUInt4AtPtr(pc+1);
- break;
+ break;
case INST_INVOKE_STK1:
objc = TclGetUInt1AtPtr(pc+1);
@@ -755,37 +757,37 @@ TclGetInnerContext(
result = iPtr->innerContext;
if (Tcl_IsShared(result)) {
- Tcl_DecrRefCount(result);
- iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL);
- Tcl_IncrRefCount(result);
+ Tcl_DecrRefCount(result);
+ iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL);
+ Tcl_IncrRefCount(result);
} else {
- Tcl_Size len;
+ Tcl_Size len;
- /*
- * Reset while keeping the list internalrep as much as possible.
- */
+ /*
+ * Reset while keeping the list internalrep as much as possible.
+ */
TclListObjLength(interp, result, &len);
- Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);
+ Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);
}
Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc));
for (; objc>0 ; objc--) {
- Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
- objPtr = tosPtr[1 - objc];
- if (!objPtr) {
- Tcl_Panic("InnerContext: bad tos -- appending null object");
- }
- if ((objPtr->refCount <= 0)
+ objPtr = tosPtr[1 - objc];
+ if (!objPtr) {
+ Tcl_Panic("InnerContext: bad tos -- appending null object");
+ }
+ if ((objPtr->refCount <= 0)
#ifdef TCL_MEM_DEBUG
- || (objPtr->refCount == 0x61616161)
+ || (objPtr->refCount == 0x61616161)
#endif
- ) {
- Tcl_Panic("InnerContext: bad tos -- appending freed object %p",
- objPtr);
- }
- Tcl_ListObjAppendElement(NULL, result, objPtr);
+ ) {
+ Tcl_Panic("InnerContext: bad tos -- appending freed object %p",
+ objPtr);
+ }
+ Tcl_ListObjAppendElement(NULL, result, objPtr);
}
return result;
@@ -836,7 +838,7 @@ UpdateStringOfInstName(
if (inst >= LAST_INST_OPCODE) {
dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5);
TclOOM(dst, TCL_INTEGER_SPACE + 5);
- snprintf(dst, TCL_INTEGER_SPACE + 5, "inst_%" TCL_Z_MODIFIER "u", inst);
+ snprintf(dst, TCL_INTEGER_SPACE + 5, "inst_%" TCL_Z_MODIFIER "u", inst);
(void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
} else {
const char *s = tclInstructionTable[inst].name;
@@ -1121,7 +1123,7 @@ DisassembleByteCodeAsDicts(
Tcl_Obj *desc;
TclNewObj(desc);
- Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), auxDesc);
+ TclDictPut(NULL, desc, "name", auxDesc);
auxDesc = desc;
auxData->type->disassembleProc(auxData->clientData, auxDesc,
codePtr, 0);
@@ -1188,23 +1190,20 @@ DisassembleByteCodeAsDicts(
sourceOffset += Decode(srcOffPtr);
sourceLength = Decode(srcLenPtr);
TclNewObj(cmd);
- Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1),
- Tcl_NewWideIntObj(codeOffset));
- Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1),
- Tcl_NewWideIntObj(codeOffset + codeLength - 1));
+ TclDictPut(NULL, cmd, "codefrom", Tcl_NewWideIntObj(codeOffset));
+ TclDictPut(NULL, cmd, "codeto", Tcl_NewWideIntObj(
+ 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_NewWideIntObj(Tcl_NumUtfChars(codePtr->source,
- sourceOffset)));
- Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1),
- Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source,
- sourceOffset + sourceLength - 1)));
- Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1),
+ TclDictPut(NULL, cmd, "scriptfrom", Tcl_NewWideIntObj(
+ Tcl_NumUtfChars(codePtr->source, sourceOffset)));
+ TclDictPut(NULL, cmd, "scriptto", Tcl_NewWideIntObj(
+ Tcl_NumUtfChars(codePtr->source, sourceOffset + sourceLength - 1)));
+ TclDictPut(NULL, cmd, "script",
Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength));
Tcl_ListObjAppendElement(NULL, commands, cmd);
}
@@ -1223,32 +1222,26 @@ DisassembleByteCodeAsDicts(
*/
TclNewObj(description);
- 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),
+ TclDictPut(NULL, description, "literals", literals);
+ TclDictPut(NULL, description, "variables", variables);
+ TclDictPut(NULL, description, "exception", exn);
+ TclDictPut(NULL, description, "instructions", instructions);
+ TclDictPut(NULL, description, "auxiliary", aux);
+ TclDictPut(NULL, description, "commands", commands);
+ TclDictPut(NULL, description, "script",
Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes));
- Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1),
+ TclDictPut(NULL, description, "namespace",
Tcl_NewStringObj(codePtr->nsPtr->fullName, -1));
- Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1),
+ TclDictPut(NULL, description, "stackdepth",
Tcl_NewWideIntObj(codePtr->maxStackDepth));
- Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1),
+ TclDictPut(NULL, description, "exceptdepth",
Tcl_NewWideIntObj(codePtr->maxExceptDepth));
if (line >= 0) {
- Tcl_DictObjPut(NULL, description,
- Tcl_NewStringObj("initiallinenumber", -1),
+ TclDictPut(NULL, description, "initiallinenumber",
Tcl_NewWideIntObj(line));
}
if (file) {
- Tcl_DictObjPut(NULL, description,
- Tcl_NewStringObj("sourcefile", -1), file);
+ TclDictPut(NULL, description, "sourcefile", file);
}
return description;
}
@@ -1344,7 +1337,7 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC",
- TclGetString(objv[2]), (void *)NULL);
+ TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
@@ -1394,7 +1387,7 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
- TclGetString(objv[2]), (void *)NULL);
+ TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
@@ -1404,7 +1397,7 @@ Tcl_DisassembleObjCmd(
"\"%s\" has no defined constructor",
TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
- "CONSRUCTOR", (void *)NULL);
+ "CONSRUCTOR", (char *)NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(methodPtr);
@@ -1412,7 +1405,7 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of constructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
- "METHODTYPE", (void *)NULL);
+ "METHODTYPE", (char *)NULL);
return TCL_ERROR;
}
@@ -1459,7 +1452,7 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
- TclGetString(objv[2]), (void *)NULL);
+ TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
@@ -1469,7 +1462,7 @@ Tcl_DisassembleObjCmd(
"\"%s\" has no defined destructor",
TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
- "DESRUCTOR", (void *)NULL);
+ "DESRUCTOR", (char *)NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(methodPtr);
@@ -1477,7 +1470,7 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of destructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
- "METHODTYPE", (void *)NULL);
+ "METHODTYPE", (char *)NULL);
return TCL_ERROR;
}
@@ -1524,7 +1517,7 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
- TclGetString(objv[2]), (void *)NULL);
+ TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
@@ -1559,7 +1552,7 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[3])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[3]), (void *)NULL);
+ TclGetString(objv[3]), (char *)NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
@@ -1567,7 +1560,7 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
- "METHODTYPE", (void *)NULL);
+ "METHODTYPE", (char *)NULL);
return TCL_ERROR;
}
if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) {
@@ -1604,7 +1597,7 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not disassemble prebuilt bytecode", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
- "BYTECODE", (void *)NULL);
+ "BYTECODE", (char *)NULL);
return TCL_ERROR;
}
if (clientData) {
generated by cgit v0.12 at 2025-12-09 15:02:33 (GMT)