Put the file location information that Tcl has into the disassembled code. Important for tclquadcode.

3 files changed, 131 insertions, 13 deletions

diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index 86f0e1d..a60a58d 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -21,9 +21,13 @@
  * Prototypes for procedures defined later in this file:
  */
 
-static Tcl_Obj *	DisassembleByteCodeAsDicts(Tcl_Obj *objPtr);
+static Tcl_Obj *	DisassembleByteCodeAsDicts(Tcl_Interp *interp,
+			    Tcl_Obj *objPtr);
 static int		FormatInstruction(ByteCode *codePtr,
 			    const unsigned char *pc, Tcl_Obj *bufferObj);
+static void		GetLocationInformation(Tcl_Interp *interp,
+			    Proc *procPtr, Tcl_Obj **fileObjPtr,
+			    int *linePtr);
 static void		PrintSourceToObj(Tcl_Obj *appendObj,
 			    const char *stringPtr, int maxChars);
 static void		UpdateStringOfInstName(Tcl_Obj *objPtr);
@@ -48,6 +52,57 @@ static const Tcl_ObjType tclInstNameType = {
 #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(
+    Tcl_Interp *interp,		/* Where to look up the location
+				 * information. */
+    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. */
+{
+    Interp *iPtr = (Interp *) interp;
+    Tcl_HashEntry *hePtr;
+    CmdFrame *cfPtr;
+
+    *fileObjPtr = NULL;
+    *linePtr = -1;
+    if (iPtr != NULL && procPtr != NULL) {
+	hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, procPtr);
+	if (hePtr != NULL && (cfPtr = Tcl_GetHashValue(hePtr)) != NULL) {
+	    *linePtr = cfPtr->line[0];
+	    if (cfPtr->type == TCL_LOCATION_SOURCE) {
+		*fileObjPtr = cfPtr->data.eval.path;
+	    }
+	}
+    }
+}
+
 #ifdef TCL_COMPILE_DEBUG
 /*
  *----------------------------------------------------------------------
@@ -68,10 +123,10 @@ static const Tcl_ObjType tclInstNameType = {
 
 void
 TclPrintByteCodeObj(
-    Tcl_Interp *interp,		/* Used only for Tcl_GetStringFromObj. */
+    Tcl_Interp *interp,		/* Used only for getting location info. */
     Tcl_Obj *objPtr)		/* The bytecode object to disassemble. */
 {
-    Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr);
+    Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(interp, objPtr);
 
     fprintf(stdout, "\n%s", TclGetString(bufPtr));
     Tcl_DecrRefCount(bufPtr);
@@ -187,15 +242,16 @@ TclPrintSource(
 
 Tcl_Obj *
 TclDisassembleByteCodeObj(
+    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;
+    int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line;
     Interp *iPtr = (Interp *) *codePtr->interpHandle;
-    Tcl_Obj *bufferObj;
+    Tcl_Obj *bufferObj, *fileObj;
     char ptrBuf1[20], ptrBuf2[20];
 
     TclNewObj(bufferObj);
@@ -220,6 +276,11 @@ TclDisassembleByteCodeObj(
     Tcl_AppendToObj(bufferObj, "  Source ", -1);
     PrintSourceToObj(bufferObj, codePtr->source,
 	    TclMin(codePtr->numSrcBytes, 55));
+    GetLocationInformation(interp, 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,
@@ -881,14 +942,16 @@ PrintSourceToObj(
 
 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;
+    Tcl_Obj *aux, *exn, *commands, *file;
     unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr;
     int codeOffset, codeLength, sourceOffset, sourceLength;
-    int i, val;
+    int i, val, line;
 
     /*
      * Get the literals from the bytecode.
@@ -1152,6 +1215,13 @@ DisassembleByteCodeAsDicts(
 #undef Decode
 
     /*
+     * Get the source file and line number information from the CmdFrame
+     * system if it is available.
+     */
+
+    GetLocationInformation(interp, codePtr->procPtr, &file, &line);
+
+    /*
      * Build the overall result.
      */
 
@@ -1174,6 +1244,15 @@ DisassembleByteCodeAsDicts(
 	    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;
 }
 
@@ -1403,9 +1482,11 @@ Tcl_DisassembleObjCmd(
 	return TCL_ERROR;
     }
     if (PTR2INT(clientData)) {
-	Tcl_SetObjResult(interp, DisassembleByteCodeAsDicts(codeObjPtr));
+	Tcl_SetObjResult(interp,
+		DisassembleByteCodeAsDicts(interp, codeObjPtr));
     } else {
-	Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr));
+	Tcl_SetObjResult(interp,
+		TclDisassembleByteCodeObj(interp, codeObjPtr));
     }
     return TCL_OK;
 }
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 082fab4..9a5b4bf 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3152,7 +3152,8 @@ MODULE_SCOPE void	TclFinalizeThreadStorage(void);
 MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
 MODULE_SCOPE double	TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
 #endif
-MODULE_SCOPE Tcl_Obj *	TclDisassembleByteCodeObj(Tcl_Obj *objPtr);
+MODULE_SCOPE Tcl_Obj *	TclDisassembleByteCodeObj(Tcl_Interp *interp,
+			    Tcl_Obj *objPtr);
 MODULE_SCOPE int	TclZlibInit(Tcl_Interp *interp);
 MODULE_SCOPE void *	TclpThreadCreateKey(void);
 MODULE_SCOPE void	TclpThreadDeleteKey(void *keyPtr);
diff --git a/tests/compile.test b/tests/compile.test
index d4a31d4..46e678a 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -765,7 +765,7 @@ test compile-18.24 {disassembler - basics} -returnCodes error -body {
 } -result "can't interpret \"\{\" as a lambda expression"
 test compile-18.25 {disassembler - basics} -body {
     dict keys [tcl::unsupported::getbytecode lambda {{} {}}]
-} -result $bytecodekeys
+} -result "$bytecodekeys initiallinenumber sourcefile"
 test compile-18.26 {disassembler - basics} -returnCodes error -body {
     tcl::unsupported::getbytecode proc
 } -match glob -result {wrong # args: should be "* proc procName"}
@@ -778,7 +778,43 @@ test compile-18.28 {disassembler - basics} -setup {
     dict keys [tcl::unsupported::getbytecode proc chewonthis]
 } -cleanup {
     rename chewonthis {}
+} -result "$bytecodekeys initiallinenumber sourcefile"
+test compile-18.28.1 {disassembler - tricky bit} -setup {
+    eval [list proc chewonthis {} {}]
+} -body {
+    dict keys [tcl::unsupported::getbytecode proc chewonthis]
+} -cleanup {
+    rename chewonthis {}
+} -result $bytecodekeys
+test compile-18.28.2 {disassembler - tricky bit} -setup {
+    eval {proc chewonthis {} {}}
+} -body {
+    dict keys [tcl::unsupported::getbytecode proc chewonthis]
+} -cleanup {
+    rename chewonthis {}
+} -result "$bytecodekeys initiallinenumber sourcefile"
+test compile-18.28.3 {disassembler - tricky bit} -setup {
+    proc Proc {n a b} {
+	proc $n $a $b
+    }
+    Proc chewonthis {} {}
+} -body {
+    dict keys [tcl::unsupported::getbytecode proc chewonthis]
+} -cleanup {
+    rename Proc {}
+    rename chewonthis {}
 } -result $bytecodekeys
+test compile-18.28.4 {disassembler - tricky bit} -setup {
+    proc Proc {n a b} {
+	tailcall proc $n $a $b
+    }
+    Proc chewonthis {} {}
+} -body {
+    dict keys [tcl::unsupported::getbytecode proc chewonthis]
+} -cleanup {
+    rename Proc {}
+    rename chewonthis {}
+} -result "$bytecodekeys initiallinenumber sourcefile"
 test compile-18.29 {disassembler - basics} -returnCodes error -body {
     tcl::unsupported::getbytecode script
 } -match glob -result {wrong # args: should be "* script script"}
@@ -807,7 +843,7 @@ test compile-18.35 {disassembler - basics} -setup {
     dict keys [tcl::unsupported::getbytecode method foo bar]
 } -cleanup {
     foo destroy
-} -result $bytecodekeys
+} -result "$bytecodekeys initiallinenumber sourcefile"
 test compile-18.36 {disassembler - basics} -returnCodes error -body {
     tcl::unsupported::getbytecode objmethod
 } -match glob -result {wrong # args: should be "* objmethod objectName methodName"}
@@ -824,7 +860,7 @@ test compile-18.39 {disassembler - basics} -setup {
     dict keys [tcl::unsupported::getbytecode objmethod foo bar]
 } -cleanup {
     foo destroy
-} -result $bytecodekeys
+} -result "$bytecodekeys initiallinenumber sourcefile"
 
 test compile-19.0 {Bug 3614102: reset stack housekeeping} -body {
     # This will panic in a --enable-symbols=compile build, unless bug is fixed.