* generic/tclCompile.c: New instruction code INST_START_CMD

	* generic/tclCompile.h:     that allows checking the bytecode's
	* generic/tclExecute.c:     validity [Bug 729692] and the interp's
	* tests/interp.test (18.9): readyness [Bug 495830] before running
	* tests/proc.test (7.1):    the command. It also changes the
	* tests/rename.test (6.1):  mechanics of the async tests in TEBC,
	doing it now at command start instead of every 16 instructions.

7 files changed, 97 insertions, 42 deletions

diff --git a/ChangeLog b/ChangeLog
index fc42294..5848e79 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2004-03-30  Miguel Sofer <msofer@users.sf.net>
+
+	* generic/tclCompile.c:     New instruction code INST_START_CMD
+	* generic/tclCompile.h:     that allows checking the bytecode's  
+	* generic/tclExecute.c:     validity [Bug 729692] and the interp's  
+	* tests/interp.test (18.9): readyness [Bug 495830] before running 
+	* tests/proc.test (7.1):    the command. It also changes the 
+	* tests/rename.test (6.1):  mechanics of the async tests in TEBC, 		   	 
+	doing it now at command start instead of every 16 instructions.
+
 2004-03-30  Vince Darley  <vincentdarley@users.sourceforge.net>
 
         * generic/tclFileName.c:  Fix to Windows glob where the pattern is
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 6230e06..def4e4d 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.59 2004/03/29 02:09:46 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.60 2004/03/30 16:22:11 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -282,6 +282,9 @@ InstructionDesc tclInstructionTable[] = {
 	/* List Index:	push (lindex stktop op4) */
     {"listRangeImm",	  9,	0,	   2,	{OPERAND_IDX4, OPERAND_IDX4}},
 	/* List Range:	push (lrange stktop op4 op4) */
+
+    {"startCommand",      5,    0,         1,   {OPERAND_UINT4}},
+        /* Start of bytecoded command: op is the length of the cmd's code */ 
     {0}
 };
 
@@ -1056,9 +1059,26 @@ TclCompileScript(interp, script, numBytes, envPtr)
 			    unsigned int savedCodeNext =
 				    envPtr->codeNext - envPtr->codeStart;
 
+			    /*
+			     * Mark the start of the command; the proper
+			     * bytecode length will be updated later.
+			     */
+			    
+			    TclEmitInstInt4(INST_START_CMD, 0, envPtr);
+			    
 			    code = (*(cmdPtr->compileProc))(interp, &parse,
 			            envPtr);
+			    
 			    if (code == TCL_OK) {
+				/*
+				 * Fix the bytecode length.
+				 */
+				unsigned char *fixPtr = envPtr->codeStart + savedCodeNext + 1;
+				unsigned int fixLen = envPtr->codeNext - envPtr->codeStart
+				        - savedCodeNext;
+				
+				TclStoreInt4AtPtr(fixLen, fixPtr);
+				
 				goto finishCommand;
 			    } else if (code == TCL_OUT_LINE_COMPILE) {
 				/*
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 5f46b78..1d6b498 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -8,7 +8,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.42 2004/01/20 15:49:54 dkf Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.43 2004/03/30 16:22:21 msofer Exp $
  */
 
 #ifndef _TCLCOMPILATION
@@ -543,8 +543,10 @@ typedef struct ByteCode {
 #define INST_LIST_INDEX_IMM		102
 #define INST_LIST_RANGE_IMM		103
 
+#define INST_START_CMD                  104
+
 /* The last opcode */
-#define LAST_INST_OPCODE		103
+#define LAST_INST_OPCODE		104
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 2a313d2..3ff411d 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.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: tclExecute.c,v 1.121 2004/01/18 16:19:05 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.122 2004/03/30 16:22:21 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -61,15 +61,6 @@ int errno;
 #   endif /* MAXDOUBLE */
 #endif /* !DBL_MAX */
 
-/*
- * A mask (should be 2**n-1) that is used to work out when the
- * bytecode engine should call Tcl_AsyncReady() to see whether there
- * is a signal that needs handling.
- */
-
-#ifndef ASYNC_CHECK_COUNT_MASK
-#   define ASYNC_CHECK_COUNT_MASK	15
-#endif /* !ASYNC_CHECK_COUNT_MASK */
 
 /*
  * Boolean flag indicating whether the Tcl bytecode interpreter has been
@@ -1098,9 +1089,11 @@ TclExecuteByteCode(interp, codePtr)
     int traceInstructions = (tclTraceExec == 3);
     char cmdNameBuf[21];
 #endif
-    int instructionCount = 0;	/* Counter that is used to work out
-				 * when to call Tcl_AsyncReady() */
-
+    Namespace *namespacePtr;
+    int codeCompileEpoch = codePtr->compileEpoch;
+    int codeNsEpoch = codePtr->nsEpoch;
+    int codePrecompiled = (codePtr->flags & TCL_BYTECODE_PRECOMPILED);
+    
     /*
      * The execution uses a unified stack: first the catch stack, immediately
      * above it the execution stack.
@@ -1134,6 +1127,11 @@ TclExecuteByteCode(interp, codePtr)
     iPtr->stats.numExecutions++;
 #endif
 
+    if (iPtr->varFramePtr != NULL) {
+        namespacePtr = iPtr->varFramePtr->nsPtr;
+    } else {
+        namespacePtr = iPtr->globalNsPtr;
+    }
 
     /*
      * Loop executing instructions until a "done" instruction, a 
@@ -1215,21 +1213,43 @@ TclExecuteByteCode(interp, codePtr)
     iPtr->stats.instructionCount[*pc]++;
 #endif
 
-    /*
-     * Check for asynchronous handlers [Bug 746722]; we
-     * do the check every 16th instruction.
-     */
+    switch (*pc) {
+    case INST_START_CMD:
+	/*
+	 * Check for asynchronous handlers [Bug 746722].
+	 */
 
-    if (!(instructionCount++ & ASYNC_CHECK_COUNT_MASK) && Tcl_AsyncReady()) {
-	DECACHE_STACK_INFO();
-	result = Tcl_AsyncInvoke(interp, result);
-	CACHE_STACK_INFO();
-	if (result == TCL_ERROR) {
-	    goto checkForCatch;
+	if (Tcl_AsyncReady()) {
+	    DECACHE_STACK_INFO();
+	    result = Tcl_AsyncInvoke(interp, result);
+	    CACHE_STACK_INFO();
+	    if (result == TCL_ERROR) {
+		goto checkForCatch;
+	    }
 	}
-    }
-
-    switch (*pc) {
+	
+	if ((!(iPtr->flags & DELETED)
+		    && (codeCompileEpoch == iPtr->compileEpoch)
+		    && (codeNsEpoch == namespacePtr->resolverEpoch))
+		|| codePrecompiled) {
+	    NEXT_INST_F(5, 0, 0);
+	} else {
+	    bytes = GetSrcInfoForPc(pc, codePtr, &length);
+	    result = Tcl_EvalEx(interp, bytes, length, 0);
+	    if (result != TCL_OK) {
+		goto checkForCatch;
+	    }
+	    opnd = TclGetUInt4AtPtr(pc+1);
+	    objResultPtr = Tcl_GetObjResult(interp);
+	    {
+		Tcl_Obj *newObjResultPtr;
+		TclNewObj(newObjResultPtr);
+		Tcl_IncrRefCount(newObjResultPtr);
+		iPtr->objResultPtr = newObjResultPtr;
+	    }
+	    NEXT_INST_V(opnd, 0, -1);
+	}
+	
     case INST_RETURN:
 	{
 	    int code = TclGetInt4AtPtr(pc+1);
@@ -1532,14 +1552,6 @@ TclExecuteByteCode(interp, codePtr)
 	    ++*preservedStackRefCountPtr;
 
 	    /*
-	     * Reset the instructionCount variable, since we're about
-	     * to check for async stuff anyway while processing
-	     * TclEvalObjvInternal.
-	     */
-
-	    instructionCount = 1;
-
-	    /*
 	     * Finally, let TclEvalObjvInternal handle the command. 
 	     */
 
diff --git a/tests/interp.test b/tests/interp.test
index 83356af..e6b2024 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -10,7 +10,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: interp.test,v 1.26 2004/03/17 18:14:17 das Exp $
+# RCS: @(#) $Id: interp.test,v 1.27 2004/03/30 16:22:22 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2.1
@@ -753,7 +753,7 @@ if {[info commands testinterpdelete] == ""} {
 	list [catch {a eval foo} msg] $msg
     } {1 {attempt to call eval in deleted interpreter}}
 }
-test interp-18.9 {eval in deleted interp, bug 495830} {knownBug} {
+test interp-18.9 {eval in deleted interp, bug 495830} {
     interp create tst
     interp alias tst suicide {} interp delete tst
     list [catch {tst eval {suicide; set a 5}} msg] $msg
diff --git a/tests/proc.test b/tests/proc.test
index bf23ef7..662d56f 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -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: proc.test,v 1.12 2003/11/14 20:44:47 dgp Exp $
+# RCS: @(#) $Id: proc.test,v 1.13 2004/03/30 16:22:22 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -325,6 +325,15 @@ test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} {
     set result
 } -5
 
+test proc-7.1 {Redefining a compiled cmd: Bug 729692} {
+    proc bar args {}
+    proc foo {} {
+	proc bar args {return bar}
+	bar
+    }
+    foo
+} bar
+
 # cleanup
 catch {rename p ""}
 catch {rename t ""}
diff --git a/tests/rename.test b/tests/rename.test
index babe4ef..a33afaa 100644
--- a/tests/rename.test
+++ b/tests/rename.test
@@ -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: rename.test,v 1.10 2001/09/12 20:28:50 dgp Exp $
+# RCS: @(#) $Id: rename.test,v 1.11 2004/03/30 16:22:22 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -160,7 +160,7 @@ catch {rename unknown.old unknown}
 
 
 test rename-6.1 {old code invalidated (epoch incremented) when cmd with compile proc is renamed } {
-    proc x {} {
+     proc x {} {
         set a 123
         set b [incr a]
     }
@@ -168,6 +168,8 @@ test rename-6.1 {old code invalidated (epoch incremented) when cmd with compile
     rename incr incr.old
     proc incr {} {puts "new incr called!"}
     catch {x} msg
+    rename incr {}
+    rename incr.old incr
     set msg
 } {wrong # args: should be "incr"}