diff options
| -rw-r--r-- | ChangeLog | 10 | ||||
| -rw-r--r-- | generic/tclCompile.c | 22 | ||||
| -rw-r--r-- | generic/tclCompile.h | 6 | ||||
| -rw-r--r-- | generic/tclExecute.c | 80 | ||||
| -rw-r--r-- | tests/interp.test | 4 | ||||
| -rw-r--r-- | tests/proc.test | 11 | ||||
| -rw-r--r-- | tests/rename.test | 6 |
7 files changed, 97 insertions, 42 deletions
@@ -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"} |