Improved rendering of some opcode arguments and auxdata.

4 files changed, 150 insertions, 14 deletions

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index fddf152..0740490 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -26,11 +26,17 @@ static void		FreeDictUpdateInfo(ClientData clientData);
 static void		PrintDictUpdateInfo(ClientData clientData,
 			    Tcl_Obj *appendObj, ByteCode *codePtr,
 			    unsigned int pcOffset);
+static void		DisassembleDictUpdateInfo(ClientData clientData,
+			    Tcl_Obj *dictObj, ByteCode *codePtr,
+			    unsigned int pcOffset);
 static ClientData	DupForeachInfo(ClientData clientData);
 static void		FreeForeachInfo(ClientData clientData);
 static void		PrintForeachInfo(ClientData clientData,
 			    Tcl_Obj *appendObj, ByteCode *codePtr,
 			    unsigned int pcOffset);
+static void		DisassembleForeachInfo(ClientData clientData,
+			    Tcl_Obj *dictObj, ByteCode *codePtr,
+			    unsigned int pcOffset);
 static int		CompileEachloopCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    CompileEnv *envPtr, int collect);
@@ -46,14 +52,16 @@ const AuxDataType tclForeachInfoType = {
     "ForeachInfo",		/* name */
     DupForeachInfo,		/* dupProc */
     FreeForeachInfo,		/* freeProc */
-    PrintForeachInfo		/* printProc */
+    PrintForeachInfo,		/* printProc */
+    DisassembleForeachInfo	/* disassembleProc */
 };
 
 const AuxDataType tclDictUpdateInfoType = {
     "DictUpdateInfo",		/* name */
     DupDictUpdateInfo,		/* dupProc */
     FreeDictUpdateInfo,		/* freeProc */
-    PrintDictUpdateInfo		/* printProc */
+    PrintDictUpdateInfo,	/* printProc */
+    DisassembleDictUpdateInfo	/* disassembleProc */
 };
 
 /*
@@ -2065,11 +2073,13 @@ TclCompileDictWithCmd(
  *	DupDictUpdateInfo: a copy of the auxiliary data
  *	FreeDictUpdateInfo: none
  *	PrintDictUpdateInfo: none
+ *	DisassembleDictUpdateInfo: none
  *
  * Side effects:
  *	DupDictUpdateInfo: allocates memory
  *	FreeDictUpdateInfo: releases memory
  *	PrintDictUpdateInfo: none
+ *	DisassembleDictUpdateInfo: none
  *
  *----------------------------------------------------------------------
  */
@@ -2112,6 +2122,25 @@ PrintDictUpdateInfo(
 	Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]);
     }
 }
+
+static void
+DisassembleDictUpdateInfo(
+    ClientData clientData,
+    Tcl_Obj *dictObj,
+    ByteCode *codePtr,
+    unsigned int pcOffset)
+{
+    DictUpdateInfo *duiPtr = clientData;
+    int i;
+    Tcl_Obj *variables = Tcl_NewObj();
+
+    for (i=0 ; i<duiPtr->length ; i++) {
+	Tcl_ListObjAppendElement(NULL, variables,
+		Tcl_NewIntObj(duiPtr->varIndices[i]));
+    }
+    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1),
+	    variables);
+}
 
 /*
  *----------------------------------------------------------------------
@@ -2856,10 +2885,10 @@ FreeForeachInfo(
 /*
  *----------------------------------------------------------------------
  *
- * PrintForeachInfo --
+ * PrintForeachInfo, DisassembleForeachInfo --
  *
- *	Function to write a human-readable representation of a ForeachInfo
- *	structure to stdout for debugging.
+ *	Functions to write a human-readable or script-readablerepresentation
+ *	of a ForeachInfo structure to a Tcl_Obj for debugging.
  *
  * Results:
  *	None.
@@ -2909,6 +2938,53 @@ PrintForeachInfo(
 	Tcl_AppendToObj(appendObj, "]", -1);
     }
 }
+
+static void
+DisassembleForeachInfo(
+    ClientData clientData,
+    Tcl_Obj *dictObj,
+    ByteCode *codePtr,
+    unsigned int pcOffset)
+{
+    register ForeachInfo *infoPtr = clientData;
+    register ForeachVarList *varsPtr;
+    int i, j;
+    Tcl_Obj *objPtr, *innerPtr;
+
+    /*
+     * Data stores.
+     */
+
+    objPtr = Tcl_NewObj();
+    for (i=0 ; i<infoPtr->numLists ; i++) {
+	Tcl_ListObjAppendElement(NULL, objPtr,
+		Tcl_NewIntObj(infoPtr->firstValueTemp + i));
+    }
+    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr);
+
+    /*
+     * Loop counter.
+     */
+
+    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1),
+	   Tcl_NewIntObj(infoPtr->loopCtTemp));
+
+    /*
+     * Assignment targets.
+     */
+
+    objPtr = Tcl_NewObj();
+    for (i=0 ; i<infoPtr->numLists ; i++) {
+	innerPtr = Tcl_NewObj();
+	varsPtr = infoPtr->varLists[i];
+	for (j=0 ; j<varsPtr->numVars ; j++) {
+	    Tcl_ListObjAppendElement(NULL, innerPtr,
+		    Tcl_NewIntObj(varsPtr->varIndexes[j]));
+	}
+	Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
+    }
+    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr);
+}
 
 /*
  *----------------------------------------------------------------------
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 855dd8f..3639032 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -27,6 +27,9 @@ static void		FreeJumptableInfo(ClientData clientData);
 static void		PrintJumptableInfo(ClientData clientData,
 			    Tcl_Obj *appendObj, ByteCode *codePtr,
 			    unsigned int pcOffset);
+static void		DisassembleJumptableInfo(ClientData clientData,
+			    Tcl_Obj *dictObj, ByteCode *codePtr,
+			    unsigned int pcOffset);
 static int		CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, const char *identity,
 			    int instruction, CompileEnv *envPtr);
@@ -74,7 +77,8 @@ const AuxDataType tclJumptableInfoType = {
     "JumptableInfo",		/* name */
     DupJumptableInfo,		/* dupProc */
     FreeJumptableInfo,		/* freeProc */
-    PrintJumptableInfo		/* printProc */
+    PrintJumptableInfo,		/* printProc */
+    DisassembleJumptableInfo	/* disassembleProc */
 };
 
 /*
@@ -1784,11 +1788,13 @@ IssueSwitchJumpTable(
  *	DupJumptableInfo: a copy of the jump-table
  *	FreeJumptableInfo: none
  *	PrintJumptableInfo: none
+ *	DisassembleJumptableInfo: none
  *
  * Side effects:
  *	DupJumptableInfo: allocates memory
  *	FreeJumptableInfo: releases memory
  *	PrintJumptableInfo: none
+ *	DisassembleJumptableInfo: none
  *
  *----------------------------------------------------------------------
  */
@@ -1851,6 +1857,30 @@ PrintJumptableInfo(
 		keyPtr, pcOffset + offset);
     }
 }
+
+static void
+DisassembleJumptableInfo(
+    ClientData clientData,
+    Tcl_Obj *dictObj,
+    ByteCode *codePtr,
+    unsigned int pcOffset)
+{
+    register JumptableInfo *jtPtr = clientData;
+    Tcl_Obj *mapping = Tcl_NewObj();
+    Tcl_HashEntry *hPtr;
+    Tcl_HashSearch search;
+    const char *keyPtr;
+    int offset;
+
+    hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
+    for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
+	keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
+	offset = PTR2INT(Tcl_GetHashValue(hPtr));
+	Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1),
+		Tcl_NewIntObj(offset));
+    }
+    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping);
+}
 
 /*
  *----------------------------------------------------------------------
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index f28403d..cf7b563 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -252,6 +252,16 @@ typedef struct AuxDataType {
     AuxDataPrintProc *printProc;/* Callback function to invoke when printing
 				 * the aux data as part of debugging. NULL
 				 * means that the data can't be printed. */
+    AuxDataPrintProc *disassembleProc;
+				/* Callback function to invoke when doing a
+				 * disassembly of the aux data (like the
+				 * printProc, except that the output is
+				 * intended to be script-readable). The
+				 * appendObj argument should be filled in with
+				 * a descriptive dictionary; it will start out
+				 * with "name" mapped to the content of the
+				 * name field. NULL means that the printProc
+				 * should be used instead. */
 } AuxDataType;
 
 /*
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index 0d2b844..fa99eaf 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -928,24 +928,35 @@ DisassembleByteCodeAsDicts(
 	    case OPERAND_UINT1:
 		val = TclGetUInt1AtPtr(opnd);
 		opnd += 1;
-		Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val));
+		if (*pc == INST_PUSH1) {
+		    Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
+			    "@%d", val));
+		} else {
+		    Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val));
+		}
 		break;
 	    case OPERAND_UINT4:
 		val = TclGetUInt4AtPtr(opnd);
 		opnd += 4;
-		Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val));
+		if (*pc == INST_PUSH4) {
+		    Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
+			    "@%d", val));
+		} else {
+		    Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val));
+		}
 		break;
 	    case OPERAND_IDX4:
 		val = TclGetInt4AtPtr(opnd);
 		opnd += 4;
 		if (val >= -1) {
-		    Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val));
+		    Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
+			    ".%d", val));
 		} else if (val == -2) {
 		    Tcl_ListObjAppendElement(NULL, inst,
-			    Tcl_NewStringObj("end", -1));
+			    Tcl_NewStringObj(".end", -1));
 		} else {
 		    Tcl_ListObjAppendElement(NULL, inst,
-			    Tcl_ObjPrintf("end-%d", -2-val));
+			    Tcl_ObjPrintf(".end-%d", -2-val));
 		}
 		break;
 	    case OPERAND_LVT1:
@@ -984,9 +995,18 @@ DisassembleByteCodeAsDicts(
 	AuxData *auxData = &codePtr->auxDataArrayPtr[i];
 	Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1);
 
-	if (auxData->type->printProc) {
-	    Tcl_AppendToObj(auxDesc, " ", -1);
-	    auxData->type->printProc(auxData->clientData, auxDesc, codePtr,0);
+	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);
     }