merge trunkbug_593baa032c

9 files changed, 151 insertions, 32 deletions

diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index 86f0e1d..c85fe13 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -21,9 +21,15 @@
  * 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 Tcl_Obj *	DisassembleByteCodeObj(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 +54,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 +125,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 = DisassembleByteCodeObj(interp, objPtr);
 
     fprintf(stdout, "\n%s", TclGetString(bufPtr));
     Tcl_DecrRefCount(bufPtr);
@@ -176,7 +233,7 @@ TclPrintSource(
 /*
  *----------------------------------------------------------------------
  *
- * TclDisassembleByteCodeObj --
+ * DisassembleByteCodeObj --
  *
  *	Given an object which is of bytecode type, return a disassembled
  *	version of the bytecode (in a new refcount 0 object). No guarantees
@@ -185,17 +242,18 @@ TclPrintSource(
  *----------------------------------------------------------------------
  */
 
-Tcl_Obj *
-TclDisassembleByteCodeObj(
+static Tcl_Obj *
+DisassembleByteCodeObj(
+    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 +278,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,
@@ -307,7 +370,7 @@ TclDisassembleByteCodeObj(
 			rangePtr->catchOffset);
 		break;
 	    default:
-		Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d",
+		Tcl_Panic("DisassembleByteCodeObj: bad ExceptionRange type %d",
 			rangePtr->type);
 	    }
 	}
@@ -881,14 +944,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 +1217,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 +1246,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 +1484,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,
+		DisassembleByteCodeObj(interp, codeObjPtr));
     }
     return TCL_OK;
 }
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 082fab4..42c13dd 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3152,7 +3152,6 @@ 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 int	TclZlibInit(Tcl_Interp *interp);
 MODULE_SCOPE void *	TclpThreadCreateKey(void);
 MODULE_SCOPE void	TclpThreadDeleteKey(void *keyPtr);
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 600f5ec..5468c56 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -958,7 +958,7 @@ AsyncHandlerProc(
     listArgv[3] = NULL;
     cmd = Tcl_Merge(3, listArgv);
     if (interp != NULL) {
-	code = Tcl_Eval(interp, cmd);
+	code = Tcl_EvalEx(interp, cmd, -1, 0);
     } else {
 	/*
 	 * this should not happen, but by definition of how async handlers are
@@ -1241,7 +1241,7 @@ TestcmdtraceCmd(
     if (strcmp(argv[1], "tracetest") == 0) {
 	Tcl_DStringInit(&buffer);
 	cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer);
-	result = Tcl_Eval(interp, argv[2]);
+	result = Tcl_EvalEx(interp, argv[2], -1, 0);
 	if (result == TCL_OK) {
 	    Tcl_ResetResult(interp);
 	    Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
@@ -1257,13 +1257,13 @@ TestcmdtraceCmd(
 	 */
 
 	cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceDeleteProc, NULL);
-	Tcl_Eval(interp, argv[2]);
+	Tcl_EvalEx(interp, argv[2], -1, 0);
     } else if (strcmp(argv[1], "leveltest") == 0) {
 	Interp *iPtr = (Interp *) interp;
 	Tcl_DStringInit(&buffer);
 	cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, CmdTraceProc,
 		&buffer);
-	result = Tcl_Eval(interp, argv[2]);
+	result = Tcl_EvalEx(interp, argv[2], -1, 0);
 	if (result == TCL_OK) {
 	    Tcl_ResetResult(interp);
 	    Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
@@ -1987,7 +1987,7 @@ EncodingToUtfProc(
     TclEncoding *encodingPtr;
 
     encodingPtr = (TclEncoding *) clientData;
-    Tcl_GlobalEval(encodingPtr->interp, encodingPtr->toUtfCmd);
+    Tcl_EvalEx(encodingPtr->interp,encodingPtr->toUtfCmd,-1,TCL_EVAL_GLOBAL);
 
     len = strlen(Tcl_GetStringResult(encodingPtr->interp));
     if (len > dstLen) {
@@ -2019,7 +2019,7 @@ EncodingFromUtfProc(
     TclEncoding *encodingPtr;
 
     encodingPtr = (TclEncoding *) clientData;
-    Tcl_GlobalEval(encodingPtr->interp, encodingPtr->fromUtfCmd);
+    Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd,-1,TCL_EVAL_GLOBAL);
 
     len = strlen(Tcl_GetStringResult(encodingPtr->interp));
     if (len > dstLen) {
@@ -4507,7 +4507,7 @@ TestfeventCmd(
 	    return TCL_ERROR;
 	}
 	if (interp2 != NULL) {
-	    code = Tcl_GlobalEval(interp2, argv[2]);
+	    code = Tcl_EvalEx(interp2, argv[2], -1, TCL_EVAL_GLOBAL);
 	    Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2));
 	    return code;
 	} else {
diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c
index 0d3617e..4d32c5a 100644
--- a/generic/tclTestProcBodyObj.c
+++ b/generic/tclTestProcBodyObj.c
@@ -143,7 +143,7 @@ RegisterCommand(
     if (cmdTablePtr->exportIt) {
 	sprintf(buf, "namespace eval %s { namespace export %s }",
 		namespace, cmdTablePtr->cmdName);
-	if (Tcl_Eval(interp, buf) != TCL_OK) {
+	if (Tcl_EvalEx(interp, buf, -1, 0) != TCL_OK) {
 	    return TCL_ERROR;
 	}
     }
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 02ee038..75f8a15 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -613,7 +613,7 @@ NewTestThread(
      */
 
     Tcl_Preserve(tsdPtr->interp);
-    result = Tcl_Eval(tsdPtr->interp, threadEvalScript);
+    result = Tcl_EvalEx(tsdPtr->interp, threadEvalScript, -1, 0);
     if (result != TCL_OK) {
 	ThreadErrorProc(tsdPtr->interp);
     }
@@ -834,7 +834,7 @@ ThreadSend(
 
     if (threadId == Tcl_GetCurrentThread()) {
 	Tcl_MutexUnlock(&threadMutex);
-	return Tcl_GlobalEval(interp, script);
+	return Tcl_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL);	
     }
 
     /*
@@ -1029,7 +1029,7 @@ ThreadEventProc(
 	Tcl_Preserve(interp);
 	Tcl_ResetResult(interp);
 	Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
-	code = Tcl_GlobalEval(interp, threadEventPtr->script);
+	code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL);	
 	Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
 	if (code != TCL_OK) {
 	    errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index fe52d59..4e74c54 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -1889,7 +1889,8 @@ TraceExecutionProc(
 	     * interpreter.
 	     */
 
-	    traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
+	    traceCode = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
+		    Tcl_DStringLength(&cmd), 0);
 	    tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
 
 	    /*
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 44dd9e0..ba3e9cb 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -762,7 +762,7 @@ Tcl_ZlibStreamInit(
      */
 
     if (interp != NULL) {
-	if (Tcl_Eval(interp, "::incr ::tcl::zlib::cmdcounter") != TCL_OK) {
+	if (Tcl_EvalEx(interp, "::incr ::tcl::zlib::cmdcounter", -1, 0) != TCL_OK) {
 	    goto error;
 	}
 	Tcl_DStringInit(&cmdname);
@@ -3816,7 +3816,7 @@ TclZlibInit(
      * commands.
      */
 
-    Tcl_Eval(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}");
+    Tcl_EvalEx(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}", -1, 0);
 
     /*
      * Create the public scripted interface to this file's functionality.
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.
diff --git a/unix/dltest/pkge.c b/unix/dltest/pkge.c
index d616352..395cd0e 100644
--- a/unix/dltest/pkge.c
+++ b/unix/dltest/pkge.c
@@ -50,5 +50,5 @@ Pkge_Init(
     if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
 	return TCL_ERROR;
     }
-    return Tcl_Eval(interp, script);
+    return Tcl_EvalEx(interp, script, -1, 0);
 }