Attachment "729692.patch" to
ticket [729692ffff]
added by
msofer
2004-03-30 07:41:52.
? 729692.patch
? unix/ERR
? unix/httpd_2680
? unix/httpd_32632
? unix/httpd_879
? unix/st7CigPj
Index: generic/tclCompile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.c,v
retrieving revision 1.59
diff -u -r1.59 tclCompile.c
--- generic/tclCompile.c 29 Mar 2004 02:09:46 -0000 1.59
+++ generic/tclCompile.c 30 Mar 2004 00:23:02 -0000
@@ -282,6 +282,9 @@
/* 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 @@
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) {
/*
Index: generic/tclCompile.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.h,v
retrieving revision 1.42
diff -u -r1.42 tclCompile.h
--- generic/tclCompile.h 20 Jan 2004 15:49:54 -0000 1.42
+++ generic/tclCompile.h 30 Mar 2004 00:23:03 -0000
@@ -543,8 +543,10 @@
#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
Index: generic/tclExecute.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclExecute.c,v
retrieving revision 1.121
diff -u -r1.121 tclExecute.c
--- generic/tclExecute.c 18 Jan 2004 16:19:05 -0000 1.121
+++ generic/tclExecute.c 30 Mar 2004 00:23:07 -0000
@@ -61,15 +61,6 @@
# 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 @@
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 @@
iPtr->stats.numExecutions++;
#endif
+ if (iPtr->varFramePtr != NULL) {
+ namespacePtr = iPtr->varFramePtr->nsPtr;
+ } else {
+ namespacePtr = iPtr->globalNsPtr;
+ }
/*
* Loop executing instructions until a "done" instruction, a
@@ -1220,16 +1218,39 @@
* do the check every 16th instruction.
*/
- 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;
- }
- }
switch (*pc) {
+ case INST_START_CMD:
+ if (Tcl_AsyncReady()) {
+ DECACHE_STACK_INFO();
+ result = Tcl_AsyncInvoke(interp, result);
+ CACHE_STACK_INFO();
+ if (result == TCL_ERROR) {
+ goto checkForCatch;
+ }
+ }
+ 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 +1553,6 @@
++*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.
*/
Index: tests/interp.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/interp.test,v
retrieving revision 1.26
diff -u -r1.26 interp.test
--- tests/interp.test 17 Mar 2004 18:14:17 -0000 1.26
+++ tests/interp.test 30 Mar 2004 00:23:09 -0000
@@ -753,7 +753,7 @@
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
Index: tests/proc.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/proc.test,v
retrieving revision 1.12
diff -u -r1.12 proc.test
--- tests/proc.test 14 Nov 2003 20:44:47 -0000 1.12
+++ tests/proc.test 30 Mar 2004 00:23:09 -0000
@@ -325,6 +325,15 @@
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 ""}
Index: tests/rename.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/rename.test,v
retrieving revision 1.10
diff -u -r1.10 rename.test
--- tests/rename.test 12 Sep 2001 20:28:50 -0000 1.10
+++ tests/rename.test 30 Mar 2004 00:23:09 -0000
@@ -160,7 +160,7 @@
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 @@
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"}
