} .RS { output-RS-list return } - .RE { - manerror "unexpected .RE" - return - } .br { man-puts
return } - .DE { - manerror "unexpected .DE" - return - } .DS { if {[next-op-is .ta rest]} { # skip the leading .ta directive if it is there @@ -1109,16 +1102,6 @@ proc output-directive {line} { } return } - .CE { - manerror "unexpected .CE" - return - } - .sp { - man-puts

- } - .ta { - manerror "ignoring $line" - } .nf { if {[match-text @more .fi]} { foreach more [split $more \n] { @@ -1174,13 +1157,11 @@ proc output-directive {line} { manerror "ignoring $line" } } - .fi { - manerror "ignoring $line" + .RE - .DE - .CE { + manerror "unexpected $code" + return } - .na - - .ad - - .UL - - .ne { + .ta - .fi - .na - .ad - .UL - .ie - .el - .ne { manerror "ignoring $line" } default { diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index b347abf..e4845a6 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -360,7 +360,7 @@ proc make-man-pages {html args} { continue } switch -exact -- $code { - .if - .nr - .ti - .in - + .if - .nr - .ti - .in - .ie - .el - .ad - .na - .so - .ne - .AS - .VE - .VS - . { # ignore continue @@ -379,21 +379,22 @@ proc make-man-pages {html args} { lappend manual(text) "$code [unquote $rest]" } .QW { - set rest [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] - addbuffer $LQ [unquote [lindex $rest 0]] $RQ \ - [unquote [lindex $rest 1]] + lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \ + inQuote afterwards + addbuffer $LQ [unquote $inQuote] $RQ [unquote $afterwards] } .PQ { - set rest [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] - addbuffer ( $LQ [unquote [lindex $rest 0]] $RQ \ - [unquote [lindex $rest 1]] ) \ - [unquote [lindex $rest 2]] + lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \ + inQuote punctuation afterwards + addbuffer ( $LQ [unquote $inQuote] $RQ \ + [unquote $punctuation] ) \ + [unquote $afterwards] } .QR { - set rest [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] - addbuffer $LQ [unquote [lindex $rest 0]] - \ - [unquote [lindex $rest 1]] $RQ \ - [unquote [lindex $rest 2]] + lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \ + rangeFrom rangeTo afterwards + addbuffer $LQ [unquote $rangeFrom] "–" \ + [unquote $rangeTo] $RQ [unquote $afterwards] } .MT { addbuffer $LQ$RQ @@ -404,7 +405,7 @@ proc make-man-pages {html args} { } .BS - .BE - .br - .fi - .sp - .nf { flushbuffer - if {"$rest" ne {}} { + if {$rest ne ""} { if {!$verbose} { puts stderr "" } @@ -435,8 +436,9 @@ proc make-man-pages {html args} { } .OP { flushbuffer + lassign $rest cmdName dbName dbClass lappend manual(text) [concat .OP [process-text \ - "\\fB[lindex $rest 0]\\fR \\fB[lindex $rest 1]\\fR \\fB[lindex $rest 2]\\fR"]] + "\\fB$cmdName\\fR \\fB$dbName\\fR \\fB$dbClass\\fR"]] } .PP - .LP { flushbuffer -- cgit v0.12 From 201c3c421c30870cead2b6862a090479cb4ba43e Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 22 Sep 2011 14:08:34 +0000 Subject: (minor: tidy up some comments) --- ChangeLog | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/ChangeLog b/ChangeLog index 5dd2fb8..2096795 100644 --- a/ChangeLog +++ b/ChangeLog @@ -19,9 +19,8 @@ 2011-09-21 Andreas Kupries - * generic/tclIORTrans.c (ForwardOpToOwnerThread): Fixed the - missing initialization of the 'dsti' field. Reported by Don - Porter, on chat. + * generic/tclIORTrans.c (ForwardOpToOwnerThread): Fixed the missing + initialization of the 'dsti' field. Reported by Don Porter, on chat. 2011-09-20 Don Porter @@ -37,17 +36,17 @@ 2011-09-19 Don Porter * tests/ioTrans.test: Conversion from [testthread] to Thread package - stops most memory leaks. + stops most memory leaks. * tests/thread.test: Plug most memory leaks in thread.test. - Constrain the rest to be skipped during `make valgrind`. Tests using + Constrain the rest to be skipped during `make valgrind'. Tests using the [testthread cancel] testing command are leaky. Corrections wait for either addition of [thread::cancel] to the Thread package, or improvements to the [testthread] testing command to make leak-free versions of these tests possible. * generic/tclIORChan.c: Plug all memory leaks in ioCmd.test exposed - * tests/ioCmd.test: by `make valgrind`. + * tests/ioCmd.test: by `make valgrind'. * unix/Makefile.in: 2011-09-16 Jan Nijtmans @@ -2227,7 +2226,7 @@ [BRANCH: dogeen-assembler-branch] - * generic/tclAssembly.c (new file): + * generic/tclAssembly.c (new file): * generic/tclAssembly.h: * generic/tclBasic.c (builtInCmds, Tcl_CreateInterp): * generic/tclInt.h: -- cgit v0.12 From f48bcdecf871a829134b40269947502b13c58c73 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Sep 2011 20:32:06 +0000 Subject: Revise [info frame] so that it stops creating cycles in the iPtr->cmdFramePtr stack. --- ChangeLog | 5 +++++ generic/tclCmdIL.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 2096795..e2a5b21 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2011-09-22 Don Porter + + * generic/tclCmdIL.c: Revise [info frame] so that it stops creating + cycles in the iPtr->cmdFramePtr stack. + 2011-09-22 Donal K. Fellows * doc/re_syntax.n: [Bug 2903743]: Add more magic so that we can do at diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 95532d3..f28e651 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1163,7 +1163,7 @@ InfoFrameCmd( lastPtr = runPtr; runPtr = runPtr->nextPtr; } - if (lastPtr && !runPtr) { + if (lastPtr && (runPtr != NULL)) { lastPtr->nextPtr = corPtr->caller.cmdFramePtr; } } -- cgit v0.12 From 0fb83403e7b5a32f097dcbb7144943c0c0bca597 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 23 Sep 2011 02:55:30 +0000 Subject: Further corrections to [info frame] in a coroutine. --- generic/tclCmdIL.c | 66 +++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 45 insertions(+), 21 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index f28e651..b312026 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1140,32 +1140,40 @@ InfoFrameCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - int level, topLevel; - CmdFrame *framePtr; + int level, topLevel, code = TCL_OK; + CmdFrame *runPtr, *framePtr; + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?number?"); + return TCL_ERROR; + } topLevel = ((iPtr->cmdFramePtr == NULL) ? 0 : iPtr->cmdFramePtr->level); - - if (iPtr->execEnvPtr->corPtr) { + if (corPtr) { /* * A coroutine: must fix the level computations AND the cmdFrame chain, * which is interrupted at the base. */ + CmdFrame *lastPtr = NULL; - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - CmdFrame *runPtr = iPtr->cmdFramePtr; - CmdFrame *lastPtr = NULL; + runPtr = iPtr->cmdFramePtr; + /* TODO - deal with overflow */ topLevel += corPtr->caller.cmdFramePtr->level; - while (runPtr && (runPtr != corPtr->caller.cmdFramePtr)) { - lastPtr = runPtr; - runPtr = runPtr->nextPtr; - } - if (lastPtr && (runPtr != NULL)) { - lastPtr->nextPtr = corPtr->caller.cmdFramePtr; - } + while (runPtr) { + runPtr->level += corPtr->caller.cmdFramePtr->level; + lastPtr = runPtr; + runPtr = runPtr->nextPtr; + } + if (lastPtr) { + lastPtr->nextPtr = corPtr->caller.cmdFramePtr; + } else { + iPtr->cmdFramePtr = corPtr->caller.cmdFramePtr; + } } if (objc == 1) { @@ -1174,10 +1182,7 @@ InfoFrameCmd( */ Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel)); - return TCL_OK; - } else if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?number?"); - return TCL_ERROR; + goto done; } /* @@ -1185,7 +1190,8 @@ InfoFrameCmd( */ if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) { - return TCL_ERROR; + code = TCL_ERROR; + goto done; } if ((level > topLevel) || (level <= - topLevel)) { @@ -1194,7 +1200,8 @@ InfoFrameCmd( NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME", TclGetString(objv[1]), NULL); - return TCL_ERROR; + code = TCL_ERROR; + goto done; } /* @@ -1214,7 +1221,24 @@ InfoFrameCmd( } Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr)); - return TCL_OK; + + done: + if (corPtr) { + + if (iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr) { + iPtr->cmdFramePtr = NULL; + } else { + runPtr = iPtr->cmdFramePtr; + while (runPtr->nextPtr != corPtr->caller.cmdFramePtr) { + runPtr->level -= corPtr->caller.cmdFramePtr->level; + runPtr = runPtr->nextPtr; + } + runPtr->level = 1; + runPtr->nextPtr = NULL; + } + + } + return code; }  /* -- cgit v0.12 From b1b7242607411370b9765327872a81c2e8c88513 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 23 Sep 2011 16:00:09 +0000 Subject: Stop using the deprecated thread management commands of the tcltest package. The test suite ought to provide these tools for itself. They do not belong in a testing harness. --- ChangeLog | 6 ++++++ tests/thread.test | 40 +++++++++++++++++++++++++++++----------- 2 files changed, 35 insertions(+), 11 deletions(-) diff --git a/ChangeLog b/ChangeLog index e2a5b21..7df4cc1 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2011-09-23 Don Porter + + * tests/thread.test: Stop using the deprecated thread management + commands of the tcltest package. The test suite ought to provide + these tools for itself. They do not belong in a testing harness. + 2011-09-22 Don Porter * generic/tclCmdIL.c: Revise [info frame] so that it stops creating diff --git a/tests/thread.test b/tests/thread.test index 732f5fd..74f7043 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -23,23 +23,41 @@ testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] testConstraint notValgrind [expr {![testConstraint valgrind]}] -if {[testConstraint testthread]} { - testthread errorproc ThreadError +proc ThreadError {id info} { + global threadId threadError + set threadId $id + set threadError $info } + if {[testConstraint thread]} { thread::errorproc ThreadError } - proc ThreadError {id info} { - global threadId threadError - set threadId $id - set threadError $info - } +if {[testConstraint testthread]} { + testthread errorproc ThreadError + + set mainThread [testthread id] proc ThreadNullError {id info} { # ignore } + proc threadReap {} { + testthread errorproc ThreadNullError + while {[llength [testthread names]] > 1} { + foreach tid [testthread names] { + if {$tid != [testthread id]} { + catch { + testthread send -async $tid {testthread exit} + } + } + } + after 1 + } + testthread errorproc ThreadError + return [llength [testthread names]] + } +} test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} { list [catch {testthread} msg] $msg @@ -80,14 +98,14 @@ test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {testthread} { list $x $msg } {1 {wrong # args: should be "testthread id"}} test thread-1.8 {Tcl_ThreadObjCmd: thread id} {testthread} { - string compare [testthread id] $::tcltest::mainThread + string compare [testthread id] $mainThread } {0} test thread-1.9 {Tcl_ThreadObjCmd: thread names args} {testthread} { set x [catch {testthread names x} msg] list $x $msg } {1 {wrong # args: should be "testthread names"}} test thread-1.10 {Tcl_ThreadObjCmd: thread id} {testthread} { - string compare [testthread names] $::tcltest::mainThread + string compare [testthread names] $mainThread } {0} test thread-1.11 {Tcl_ThreadObjCmd: send args} {testthread} { set x [catch {testthread send} msg] @@ -104,7 +122,7 @@ test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} { set five } 5 test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} { - set tid [expr $::tcltest::mainThread + 10] + set tid [expr $mainThread + 10] set x [catch {testthread send $tid {set x 5}} msg] list $x $msg } {1 {invalid thread id}} @@ -248,7 +266,7 @@ test thread-7.2 {cancel: nonint} {testthread} { list $x $msg } {1 {expected integer but got "abc"}} test thread-7.3 {cancel: bad id} {testthread} { - set tid [expr $::tcltest::mainThread + 10] + set tid [expr $mainThread + 10] set x [catch {testthread cancel $tid} msg] list $x $msg } {1 {invalid thread id}} -- cgit v0.12 From e3352567a2a3af2547b61485e6b91c0efd03533b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 23 Sep 2011 19:16:23 +0000 Subject: More revisions to get finalization of ReflectedTransforms correct, including adopting a "dead" field as was done in tclIORChan.c. --- ChangeLog | 4 ++ generic/tclIORTrans.c | 119 ++++++++++++++++++++++++++------------------------ 2 files changed, 67 insertions(+), 56 deletions(-) diff --git a/ChangeLog b/ChangeLog index 7df4cc1..ecac917 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,9 @@ 2011-09-23 Don Porter + * generic/tclIORTrans.c: More revisions to get finalization of + ReflectedTransforms correct, including adopting a "dead" field as + was done in tclIORChan.c. + * tests/thread.test: Stop using the deprecated thread management commands of the tcltest package. The test suite ought to provide these tools for itself. They do not belong in a testing harness. diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 0617df3..b095dcf 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -161,6 +161,8 @@ typedef struct { int mode; /* Mask of R/W mode */ int nonblocking; /* Flag: Channel is blocking or not. */ int readIsDrained; /* Flag: Read buffers are flushed. */ + int dead; /* Boolean signal that some operations + * should no longer be attempted. */ ResultBuffer result; } ReflectedTransform; @@ -1008,27 +1010,27 @@ ReflectClose( * the per-interp DeleteReflectedTransformMap exit-handler. */ - if (rtPtr->interp) { + if (!rtPtr->dead) { rtmPtr = GetReflectedTransformMap(rtPtr->interp); hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } - } - /* - * In a threaded interpreter we manage a per-thread map as well, to allow - * us to survive if the script level pulls the rug out under a channel by - * deleting the owning thread. - */ + /* + * In a threaded interpreter we manage a per-thread map as well, + * to allow us to survive if the script level pulls the rug out + * under a channel by deleting the owning thread. + */ #ifdef TCL_THREADS - rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); - if (hPtr) { - Tcl_DeleteHashEntry(hPtr); - } + rtmPtr = GetThreadReflectedTransformMap(); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); + if (hPtr) { + Tcl_DeleteHashEntry(hPtr); + } #endif + } Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return errorCodeSet ? errorCode : ((result == TCL_OK) ? EOK : EINVAL); @@ -1771,6 +1773,7 @@ NewReflectedTransform( rtPtr->readIsDrained = 0; rtPtr->nonblocking = (((Channel *) parentChan)->state->flags & CHANNEL_NONBLOCKING); + rtPtr->dead = 0; /* * Query parent for current blocking mode. @@ -1950,7 +1953,7 @@ InvokeTclMethod( int result; /* Result code of method invokation */ Tcl_Obj *resObj = NULL; /* Result of method invokation. */ - if (!rtPtr->interp) { + if (rtPtr->dead) { /* * The transform is marked as dead. Bail out immediately, with an * appropriate error. @@ -2163,7 +2166,8 @@ DeleteReflectedTransformMap( hPtr != NULL; hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) { rtPtr = Tcl_GetHashValue(hPtr); - rtPtr->interp = NULL; + + rtPtr->dead = 1; Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&rtmPtr->map); @@ -2175,6 +2179,32 @@ DeleteReflectedTransformMap( */ /* + * Get the map of all channels handled by the current thread. This is a + * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go + * through the channels and remove all which were handled by this + * interpreter. They have already been marked as dead. + */ + + rtmPtr = GetThreadReflectedTransformMap(); + for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + rtPtr = Tcl_GetHashValue(hPtr); + + if (rtPtr->interp != interp) { + /* + * Ignore entries for other interpreters. + */ + + continue; + } + + rtPtr->dead = 1; + FreeReflectedTransformArgs(rtPtr); + Tcl_DeleteHashEntry(hPtr); + } + + /* * Go through the list of pending results and cancel all whose events were * destined for this interpreter. While this is in progress we block any * other access to the list of pending results. @@ -2210,29 +2240,6 @@ DeleteReflectedTransformMap( } Tcl_MutexUnlock(&rtForwardMutex); - /* - * Get the map of all channels handled by the current thread. This is a - * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go - * through the channels and remove all which were handled by this - * interpreter. They have already been marked as dead. - */ - - rtmPtr = GetThreadReflectedTransformMap(); - for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - rtPtr = Tcl_GetHashValue(hPtr); - - if (rtPtr->interp != interp) { - /* - * Ignore entries for other interpreters. - */ - - continue; - } - - Tcl_DeleteHashEntry(hPtr); - } #endif }  @@ -2303,6 +2310,24 @@ DeleteThreadReflectedTransformMap( */ /* + * Get the map of all channels handled by the current thread. This is a + * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go + * through the channels, remove all, mark them as dead. + */ + + rtmPtr = GetThreadReflectedTransformMap(); + for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) { + ReflectedTransform *rtPtr = Tcl_GetHashValue(hPtr); + + rtPtr->dead = 1; + FreeReflectedTransformArgs(rtPtr); + Tcl_DeleteHashEntry(hPtr); + } + ckfree(rtmPtr); + + /* * Go through the list of pending results and cancel all whose events were * destined for this thread. While this is in progress we block any * other access to the list of pending results. @@ -2340,24 +2365,6 @@ DeleteThreadReflectedTransformMap( Tcl_ConditionNotify(&resultPtr->done); } Tcl_MutexUnlock(&rtForwardMutex); - - /* - * Get the map of all channels handled by the current thread. This is a - * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go - * through the channels, remove all, mark them as dead. - */ - - rtmPtr = GetThreadReflectedTransformMap(); - for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); - hPtr != NULL; - hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) { - ReflectedTransform *rtPtr = Tcl_GetHashValue(hPtr); - - rtPtr->interp = NULL; - FreeReflectedTransformArgs(rtPtr); - Tcl_DeleteHashEntry(hPtr); - } - ckfree(rtmPtr); }  static void @@ -2377,7 +2384,7 @@ ForwardOpToOwnerThread( Tcl_MutexLock(&rtForwardMutex); - if (rtPtr->interp == NULL) { + if (rtPtr->dead) { /* * The channel is marked as dead. Bail out immediately, with an * appropriate error. Do not forget to unlock the mutex on this path. -- cgit v0.12 From 41f3276be0691e2867d69d5b0f47004312f5d72a Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 26 Sep 2011 10:09:11 +0000 Subject: Proposed patch to fix [Bug 3413857]... --- generic/tclIndexObj.c | 38 ++++++++++++++------------------------ 1 file changed, 14 insertions(+), 24 deletions(-) diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 6f378a4..4e04f71 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -1113,13 +1113,15 @@ Tcl_ParseArgsObjv( if (remObjv != NULL) { /* - * Then we should copy the name of the command (0th argument). + * Then we should copy the name of the command (0th argument). The + * upper bound on the number of elements is known, and (undocumented, + * but historically true) there should be a NULL argument after the + * last result. [Bug 3413857] */ nrem = 1; - leftovers = ckalloc((nrem + 1) * sizeof(Tcl_Obj *)); - leftovers[nrem-1] = objv[0]; - leftovers[nrem] = NULL; + leftovers = ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *)); + leftovers[0] = objv[0]; } else { nrem = 0; leftovers = NULL; @@ -1182,14 +1184,7 @@ Tcl_ParseArgsObjv( } dstIndex++; /* This argument is now handled */ - nrem++; - - /* - * Allocate nrem (+1 extra for NULL terminator) pointers. - */ - - leftovers = ckrealloc(leftovers, (nrem+1) * sizeof(Tcl_Obj *)); - leftovers[nrem-1] = curArg; + leftovers[nrem++] = curArg; continue; } @@ -1282,7 +1277,9 @@ Tcl_ParseArgsObjv( /* * If we broke out of the loop because of an OPT_REST argument, copy the - * remaining arguments down. + * remaining arguments down. Note that there is always at least one + * argument left over - the command name - so we always have a result if + * our caller is willing to receive it. [Bug 3413857] */ argsDone: @@ -1295,19 +1292,12 @@ Tcl_ParseArgsObjv( } if (objc > 0) { - leftovers = ckrealloc(leftovers, (nrem+objc+1) * sizeof(Tcl_Obj *)); - while (objc) { - leftovers[nrem] = objv[srcIndex]; - nrem++; - srcIndex++; - objc--; - } - } else if (leftovers != NULL) { - ckfree(leftovers); + memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *)); + nrem += objc; } leftovers[nrem] = NULL; - *objcPtr = nrem; - *remObjv = leftovers; + *objcPtr = nrem++; + *remObjv = ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *)); return TCL_OK; /* -- cgit v0.12 From 643c7a2aa4c7b5cb1412a098ecacd72dc5f09aac Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 26 Sep 2011 10:46:36 +0000 Subject: Make [file] itself be safe, to reduce breakage in existing code. [Bug 3211758] --- ChangeLog | 7 +++++++ generic/tclCmdAH.c | 11 +++++++++++ tests/safe.test | 16 ++++++++++++++++ 3 files changed, 34 insertions(+) diff --git a/ChangeLog b/ChangeLog index ecac917..9673852 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2011-09-26 Donal K. Fellows + + * generic/tclCmdAH.c (TclMakeFileCommandSafe): [Bug 3211758]: Also + make the main [file] command hidden by default in safe interpreters, + because that's what existing code expects. This will reduce the amount + which the code breaks, but not necessarily eliminate it... + 2011-09-23 Don Porter * generic/tclIORTrans.c: More revisions to get finalization of diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index fc9d39d..d036bd6 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1063,6 +1063,17 @@ TclMakeFileCommandSafe( } Tcl_DStringFree(&oldBuf); Tcl_DStringFree(&newBuf); + + /* + * Ugh. The [file] command is now actually safe, but it is assumed by + * scripts that it is not, which messes up security policies. [Bug + * 3211758] + */ + + if (Tcl_HideCommand(interp, "file", "file") != TCL_OK) { + Tcl_Panic("problem making 'file' safe: %s", + Tcl_GetString(Tcl_GetObjResult(interp))); + } return TCL_OK; }  diff --git a/tests/safe.test b/tests/safe.test index 0f82a6a..4190976 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -541,6 +541,22 @@ test safe-12.7 {glob is restricted} -setup { } -cleanup { safe::interpDelete $i } -match glob -result * + +test safe-13.1 {safe file ensemble does not surprise code} -setup { + set i [interp create -safe] +} -body { + set result [expr {"file" in [interp hidden $i]}] + lappend result [interp eval $i {tcl::file::split a/b/c}] + lappend result [catch {interp eval $i {tcl::file::isdirectory .}}] + lappend result [interp invokehidden $i file split a/b/c] + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp invokehidden $i file isdirectory .}] + interp expose $i file + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg +} -cleanup { + interp delete $i +} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {invalid command name "::tcl::file::isdirectory"}}  set ::auto_path $saveAutoPath # cleanup -- cgit v0.12 From 0f5c9c8a346e3b691776746c83dfa947b2f41fd6 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 27 Sep 2011 09:44:56 +0000 Subject: Unbreak TCL_ARGV_AUTO_REST macro, found during testing. --- generic/tclIndexObj.c | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 4e04f71..8651542 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -1222,7 +1222,14 @@ Tcl_ParseArgsObjv( objc--; break; case TCL_ARGV_REST: - *((int *) infoPtr->dstPtr) = dstIndex; + /* + * Only store the point where we got to if it's not to be written + * to NULL, so that TCL_ARGV_AUTO_REST works. + */ + + if (infoPtr->dstPtr != NULL) { + *((int *) infoPtr->dstPtr) = dstIndex; + } goto argsDone; case TCL_ARGV_FLOAT: if (objc == 0) { -- cgit v0.12 From a235eed74f319d7860e973935e2064bd1bb30e18 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 27 Sep 2011 09:45:40 +0000 Subject: Test harness for Tcl_ParseArgsObjv --- generic/tclTest.c | 45 +++++++++++++++++++++++++++++++++++++++++++++ tests/indexObj.test | 38 ++++++++++++++++++++++++++++++++------ 2 files changed, 77 insertions(+), 6 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 96dcb36..5b74663 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -311,6 +311,8 @@ static int TestpanicCmd(ClientData dummy, static int TestfinexitObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); static int TestparserObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -624,6 +626,7 @@ Tcltest_Init( NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfinexit", TestfinexitObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, @@ -7082,6 +7085,48 @@ TestconcatobjCmd( }  /* + *---------------------------------------------------------------------- + * + * TestparseargsCmd -- + * + * This procedure implements the "testparseargs" command. It is used to + * test that Tcl_ParseArgsObjv does indeed return the right number of + * arguments. In other words, that [Bug 3413857] was fixed properly. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestparseargsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Arguments. */ +{ + int count = objc, foo = 0; + Tcl_Obj **remObjv, *result[3]; + Tcl_ArgvInfo argTable[] = { + {TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL}, + TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END + }; + + if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) { + return TCL_ERROR; + } + result[0] = Tcl_NewIntObj(foo); + result[1] = Tcl_NewIntObj(count); + result[2] = Tcl_NewListObj(count, remObjv); + Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/tests/indexObj.test b/tests/indexObj.test index 098aec0..479cc3b 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -1,20 +1,21 @@ # This file is a Tcl script to test out the the procedures in file -# tkIndexObj.c, which implement indexed table lookups. The tests here -# are organized in the standard fashion for Tcl tests. +# tkIndexObj.c, which implement indexed table lookups. The tests here are +# organized in the standard fashion for Tcl tests. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } testConstraint testindexobj [llength [info commands testindexobj]] - +testConstraint testparseargs [llength [info commands testparseargs]] + test indexObj-1.1 {exact match} testindexobj { testindexobj 1 1 xyz abc def xyz alm } {2} @@ -128,6 +129,31 @@ test indexObj-6.4 {Tcl_GetIndexFromObjStruct} testindexobj { testgetindexfromobjstruct $x 1 } "wrong # args: should be \"testgetindexfromobjstruct c 1\"" +test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs { + testparseargs +} {0 1 testparseargs} +test indexObj-7.2 {Tcl_ParseArgsObjv} testparseargs { + testparseargs -bool +} {1 1 testparseargs} +test indexObj-7.3 {Tcl_ParseArgsObjv} testparseargs { + testparseargs -bool bar +} {1 2 {testparseargs bar}} +test indexObj-7.4 {Tcl_ParseArgsObjv} testparseargs { + testparseargs bar +} {0 2 {testparseargs bar}} +test indexObj-7.5 {Tcl_ParseArgsObjv} -constraints testparseargs -body { + testparseargs -help +} -returnCodes error -result {Command-specific options: + -bool: booltest + --: Marks the end of the options + -help: Print summary of command-line options and abort} +test indexObj-7.6 {Tcl_ParseArgsObjv} testparseargs { + testparseargs -- -bool -help +} {0 3 {testparseargs -bool -help}} +test indexObj-7.7 {Tcl_ParseArgsObjv memory management} testparseargs { + testparseargs 1 2 3 4 5 6 7 8 9 0 -bool 1 2 3 4 5 6 7 8 9 0 +} {1 21 {testparseargs 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0}} + # cleanup ::tcltest::cleanupTests return -- cgit v0.12 From 2b8e3fffb5153cb9fb7c567988338ad6cd163f72 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 27 Sep 2011 09:57:02 +0000 Subject: Release unused memory... --- generic/tclTest.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclTest.c b/generic/tclTest.c index 5b74663..30c95c8 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7123,6 +7123,7 @@ TestparseargsCmd( result[1] = Tcl_NewIntObj(count); result[2] = Tcl_NewListObj(count, remObjv); Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); + ckfree(remObjv); return TCL_OK; }  -- cgit v0.12 From 89b3c7f11e1bdf0e7c9b8cfe622f383ec7ca0a4d Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 29 Sep 2011 10:56:52 +0000 Subject: [Bug 3414769]: Updated list of default-hidden commands for safe interps. --- tests/interp.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/interp.test b/tests/interp.test index c146355..ab91f77 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { testConstraint testinterpdelete [llength [info commands testinterpdelete]] -set hidden_cmds {cd encoding exec exit fconfigure glob load open pwd socket source tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} +set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} foreach i [interp slaves] { interp delete $i -- cgit v0.12 From 9f6d7b9f3e4e3b2920f51e94c6444e6e41c8e195 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 29 Sep 2011 14:58:10 +0000 Subject: More polishing of Tcl's HTML doc converter. --- ChangeLog | 7 + tools/tcltk-man2html-utils.tcl | 388 ++++++++++++++++++++++++++++++++++++++++- tools/tcltk-man2html.tcl | 378 +++------------------------------------ 3 files changed, 414 insertions(+), 359 deletions(-) diff --git a/ChangeLog b/ChangeLog index 117246f..1bcaf49 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2011-09-29 Donal K. Fellows + + * tools/tcltk-man2html.tcl, tools/tcltk-man2html-utils.tcl: More + refactoring so that more of the utility code is decently out of the + way. Adjusted the header-material generator so that version numbers + are only included in locations where there is room. + 2011-09-28 Jan Nijtmans * generic/tclOO.h: [RFE 3010352]: make all TclOO API functions diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl index ef1f62a..c0c6a75 100644 --- a/tools/tcltk-man2html-utils.tcl +++ b/tools/tcltk-man2html-utils.tcl @@ -35,7 +35,7 @@ proc fatal {msg} { uplevel 1 [list manerror $msg] exit 1 } - + ## ## templating ## @@ -46,6 +46,7 @@ proc indexfile {} { return "contents.htm" } } + proc copyright {copyright {level {}}} { # We don't actually generate a separate copyright page anymore #set page "${level}copyright.htm" @@ -54,6 +55,7 @@ proc copyright {copyright {level {}}} { set who [string map {@ (at)} [lrange $copyright 2 end]] return "Copyright © [htmlize-text $who]" } + proc copyout {copyrights {level {}}} { set out "

$manual(section-toc)

" set manual(merge-copyrights) {} - set LQ \u201c - set RQ \u201d - foreach arg $args { # preprocess to set up subheader for the rest of the files if {![llength $arg]} { continue } - set name [lindex $arg 1] - set file [lindex $arg 2] + lassign $arg -> name file + if {[regexp {(.*)(?: Package)? Commands(?:, version .*)?} $name -> pkg]} { + set name "$pkg Commands" + } elseif {[regexp {(.*)(?: Package)? C API(?:, version .*)?} $name -> pkg]} { + set name "$pkg C API" + } lappend manual(subheader) $name $file } - foreach arg $args { - if {![llength $arg]} { - continue - } - set manual(wing-glob) [lindex $arg 0] - set manual(wing-name) [lindex $arg 1] - set manual(wing-file) [lindex $arg 2] - set manual(wing-description) [lindex $arg 3] - set manual(wing-copyrights) {} - makedirhier $html/$manual(wing-file) - set manual(wing-toc-fp) [open $html/$manual(wing-file)/[indexfile] w] - # whistle - puts stderr "scanning section $manual(wing-name)" - # put the entry for this section into the short table of contents - puts $manual(short-toc-fp) "

$manual(wing-name)

$manual(wing-description)

" - # initialize the wing table of contents - puts $manual(wing-toc-fp) [htmlhead $manual(wing-name) \ - $manual(wing-name) $overall_title "../[indexfile]"] - # initialize the short table of contents for this section - set manual(wing-toc) {} - # initialize the man directory for this section - makedirhier $html/$manual(wing-file) - # initialize the long table of contents for this section - set manual(long-toc-n) 1 - # get the manual pages for this section - set manual(pages) [lsort -dictionary [glob -nocomplain $manual(wing-glob)]] - # Some pages have to go first so that their links override others - foreach pat $process_first_patterns { - set n [lsearch -glob $manual(pages) $pat] - if {$n >= 0} { - set f [lindex $manual(pages) $n] - puts stderr "shuffling [file tail $f] to front of processing queue" - set manual(pages) \ - [linsert [lreplace $manual(pages) $n $n] 0 $f] - } - } - # set manual(pages) [lrange $manual(pages) 0 5] - foreach manual_page $manual(pages) { - set manual(page) [file normalize $manual_page] - # whistle - if {$verbose} { - puts stderr "scanning page $manual(page)" - } else { - puts -nonewline stderr . - } - set manual(tail) [file tail $manual(page)] - set manual(name) [file root $manual(tail)] - set manual(section) {} - if {$manual(name) in $excluded_pages} { - # obsolete - if {!$verbose} { - puts stderr "" - } - manerror "discarding $manual(name)" - continue - } - set manual(infp) [open $manual(page)] - set manual(text) {} - set manual(partial-text) {} - foreach p {.RS .DS .CS .SO} { - set manual($p) 0 - } - set manual(stack) {} - set manual(section) {} - set manual(section-toc) {} - set manual(section-toc-n) 1 - set manual(copyrights) {} - lappend manual(all-pages) $manual(wing-file)/$manual(tail) - manreport 100 $manual(name) - while {[gets $manual(infp) line] >= 0} { - manreport 100 $line - if {[regexp {^[`'][/\\]} $line]} { - if {[regexp {Copyright (?:\(c\)|\\\(co).*$} $line copyright]} { - lappend manual(copyrights) $copyright - } - # comment - continue - } - if {"$line" eq {'}} { - # comment - continue - } - if {![parse-directive $line code rest]} { - addbuffer $line - continue - } - switch -exact -- $code { - .if - .nr - .ti - .in - .ie - .el - - .ad - .na - .so - .ne - .AS - .VE - .VS - . { - # ignore - continue - } - } - switch -exact -- $code { - .SH - .SS { - flushbuffer - if {[llength $rest] == 0} { - gets $manual(infp) rest - } - lappend manual(text) "$code [unquote $rest]" - } - .TH { - flushbuffer - lappend manual(text) "$code [unquote $rest]" - } - .QW { - lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \ - inQuote afterwards - addbuffer $LQ [unquote $inQuote] $RQ [unquote $afterwards] - } - .PQ { - lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \ - inQuote punctuation afterwards - addbuffer ( $LQ [unquote $inQuote] $RQ \ - [unquote $punctuation] ) \ - [unquote $afterwards] - } - .QR { - lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \ - rangeFrom rangeTo afterwards - addbuffer $LQ [unquote $rangeFrom] "–" \ - [unquote $rangeTo] $RQ [unquote $afterwards] - } - .MT { - addbuffer $LQ$RQ - } - .HS - .UL - .ta { - flushbuffer - lappend manual(text) "$code [unquote $rest]" - } - .BS - .BE - .br - .fi - .sp - .nf { - flushbuffer - if {$rest ne ""} { - if {!$verbose} { - puts stderr "" - } - manerror "unexpected argument: $line" - } - lappend manual(text) $code - } - .AP { - flushbuffer - lappend manual(text) [concat .IP [process-text "[lindex $rest 0] \\fB[lindex $rest 1]\\fR ([lindex $rest 2])"]] - } - .IP { - flushbuffer - regexp {^(.*) +\d+$} $rest all rest - lappend manual(text) ".IP [process-text [unquote [string trim $rest]]]" - } - .TP { - flushbuffer - while {[is-a-directive [set next [gets $manual(infp)]]]} { - if {!$verbose} { - puts stderr "" - } - manerror "ignoring $next after .TP" - } - if {"$next" ne {'}} { - lappend manual(text) ".IP [process-text $next]" - } - } - .OP { - flushbuffer - lassign $rest cmdName dbName dbClass - lappend manual(text) [concat .OP [process-text \ - "\\fB$cmdName\\fR \\fB$dbName\\fR \\fB$dbClass\\fR"]] - } - .PP - .LP { - flushbuffer - lappend manual(text) {.PP} - } - .RS { - flushbuffer - incr manual(.RS) - lappend manual(text) $code - } - .RE { - flushbuffer - incr manual(.RS) -1 - lappend manual(text) $code - } - .SO { - flushbuffer - incr manual(.SO) - if {[llength $rest] == 0} { - lappend manual(text) "$code options" - } else { - lappend manual(text) "$code [unquote $rest]" - } - } - .SE { - flushbuffer - incr manual(.SO) -1 - lappend manual(text) $code - } - .DS { - flushbuffer - incr manual(.DS) - lappend manual(text) $code - } - .DE { - flushbuffer - incr manual(.DS) -1 - lappend manual(text) $code - } - .CS { - flushbuffer - incr manual(.CS) - lappend manual(text) $code - } - .CE { - flushbuffer - incr manual(.CS) -1 - lappend manual(text) $code - } - .de { - while {[gets $manual(infp) line] >= 0} { - if {[string match "..*" $line]} { - break - } - } - } - .. { - if {!$verbose} { - puts stderr "" - } - error "found .. outside of .de" - } - default { - if {!$verbose} { - puts stderr "" - } - flushbuffer - manerror "unrecognized format directive: $line" - } - } - } - flushbuffer - close $manual(infp) - # fixups - if {$manual(.RS) != 0} { - if {!$verbose} { - puts stderr "" - } - puts "unbalanced .RS .RE" - } - if {$manual(.DS) != 0} { - if {!$verbose} { - puts stderr "" - } - puts "unbalanced .DS .DE" - } - if {$manual(.CS) != 0} { - if {!$verbose} { - puts stderr "" - } - puts "unbalanced .CS .CE" - } - if {$manual(.SO) != 0} { - if {!$verbose} { - puts stderr "" - } - puts "unbalanced .SO .SE" - } - # output conversion - open-text - set haserror 0 - if {[next-op-is .HS rest]} { - set manual($manual(wing-file)-$manual(name)-title) \ - "[join [lrange $rest 1 end] { }] [lindex $rest 0] manual page" - } elseif {[next-op-is .TH rest]} { - set manual($manual(wing-file)-$manual(name)-title) \ - "[lindex $rest 0] manual page - [join [lrange $rest 4 end] { }]" - } else { - set haserror 1 - if {!$verbose} { - puts stderr "" - } - manerror "no .HS or .TH record found" - } - if {!$haserror} { - while {[more-text]} { - set line [next-text] - if {[is-a-directive $line]} { - output-directive $line - } else { - man-puts $line - } - } - man-puts [copyout $manual(copyrights) "../"] - set manual(wing-copyrights) [merge-copyrights \ - $manual(wing-copyrights) $manual(copyrights)] - } - # - # make the long table of contents for this page - # - set manual(toc-$manual(wing-file)-$manual(name)) \ - [concat

$manual(section-toc)

] - } - if {!$verbose} { - puts stderr "" - } - # - # make the wing table of contents for the section - # - set width 0 - foreach name $manual(wing-toc) { - if {[string length $name] > $width} { - set width [string length $name] - } - } - set perline [expr {118 / $width}] - set nrows [expr {([llength $manual(wing-toc)]+$perline)/$perline}] - set n 0 - catch {unset rows} - foreach name [lsort -dictionary $manual(wing-toc)] { - set tail $manual(name-$name) - if {[llength $tail] > 1} { - manerror "$name is defined in more than one file: $tail" - set tail [lindex $tail [expr {[llength $tail]-1}]] - } - set tail [file tail $tail] - append rows([expr {$n%$nrows}]) \ - " $name " - incr n - } - puts $manual(wing-toc-fp) - foreach row [lsort -integer [array names rows]] { - puts $manual(wing-toc-fp) $rows($row) + ## + ## parse the manpages in a section of the docs (split by + ## package) and construct formatted manpages + ## + foreach arg $args { + if {[llength $arg]} { + make-manpage-section $html $arg } - puts $manual(wing-toc-fp) - - # - # insert wing copyrights - # - puts $manual(wing-toc-fp) [copyout $manual(wing-copyrights) "../"] - puts $manual(wing-toc-fp) "" - close $manual(wing-toc-fp) - set manual(merge-copyrights) [merge-copyrights \ - $manual(merge-copyrights) $manual(wing-copyrights)] } ## ## build the keyword index. ## + if {!$verbose} { + puts stderr "Assembling index" + } file delete -force -- $html/Keywords makedirhier $html/Keywords set keyfp [open $html/Keywords/[indexfile] w] @@ -688,9 +358,9 @@ proc make-man-pages {html args} { ## unset manual(section) if {!$verbose} { - puts stderr "Rescanning [llength $manual(all-pages)] pages to build cross links" + puts stderr "Rescanning [llength $manual(all-pages)] pages to build cross links and write out" } - foreach path $manual(all-pages) { + foreach path $manual(all-pages) wing_name $manual(all-page-domains) { set manual(wing-file) [file dirname $path] set manual(tail) [file tail $path] set manual(name) [file root $manual(tail)] @@ -714,7 +384,7 @@ proc make-man-pages {html args} { } set outfd [open $html/$manual(wing-file)/$manual(name).htm w] puts $outfd [htmlhead "$manual($manual(wing-file)-$manual(name)-title)" \ - $manual(name) $manual(wing-file) "[indexfile]" \ + $manual(name) $wing_name "[indexfile]" \ $overall_title "../[indexfile]"] if {($ntext > 60) && ($ntoc > 32)} { foreach item $toc { @@ -789,7 +459,7 @@ proc plus-pkgs {type args} { "The additional commands provided by the $name package." } 3 { - set title "$name Package Library" + set title "$name Package C API" if {$version ne ""} { append title ", version $version" } @@ -990,9 +660,9 @@ try { [plus-base $build_tk $tkdir/doc/*.n {Tk Commands} TkCmd \ "The additional commands which the wish interpreter implements."] \ {*}[plus-pkgs n {*}$packageDirNameMap] \ - [plus-base $build_tcl $tcldir/doc/*.3 {Tcl Library} TclLib \ + [plus-base $build_tcl $tcldir/doc/*.3 {Tcl C API} TclLib \ "The C functions which a Tcl extended C program may use."] \ - [plus-base $build_tk $tkdir/doc/*.3 {Tk Library} TkLib \ + [plus-base $build_tk $tkdir/doc/*.3 {Tk C API} TkLib \ "The additional C functions which a Tk extended C program may use."] \ {*}[plus-pkgs 3 {*}$packageDirNameMap] } on error {msg opts} { @@ -1001,7 +671,7 @@ try { puts $msg\n[dict get $opts -errorinfo] exit 1 } - + # Local-Variables: # mode: tcl # End: -- cgit v0.12 From 28efdc8a7830a383b4c27727ce1a879727756958 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 2 Oct 2011 16:29:42 +0000 Subject: Experimental compilation of the [dict with] subcommand. No tests yet, and not yet certain that the added bytecode opcodes are correct; evaluation is still needed (but the test suite does pass...) --- ChangeLog | 7 ++ generic/tclCompCmds.c | 179 ++++++++++++++++++++++++++ generic/tclCompExpr.c | 340 +++++++++++++++++++++++++++----------------------- generic/tclCompile.c | 10 ++ generic/tclCompile.h | 5 +- generic/tclDictObj.c | 213 +++++++++++++++++++++---------- generic/tclExecute.c | 45 ++++++- generic/tclInt.h | 8 ++ 8 files changed, 584 insertions(+), 223 deletions(-) diff --git a/ChangeLog b/ChangeLog index 1bcaf49..c112d2b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2011-10-02 Donal K. Fellows + + * generic/tclDictObj.c (TclDictWithInit, TclDictWithFinish): + * generic/tclCompCmds.c (TclCompileDictWithCmd): Experimental + compilation for the [dict with] subcommand, using parts factored out + from the interpreted version of the command. + 2011-09-29 Donal K. Fellows * tools/tcltk-man2html.tcl, tools/tcltk-man2html-utils.tcl: More diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 66c03ab..172a58d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1234,6 +1234,185 @@ TclCompileDictLappendCmd( TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); return TCL_OK; } + +int +TclCompileDictWithCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + int i, range, varNameTmp, pathTmp, keysTmp, gotPath; + Tcl_Token *dictVarTokenPtr, *tokenPtr; + int savedStackDepth = envPtr->currStackDepth; + JumpFixup jumpFixup; + + /* + * There must be at least one argument after the command and we must be in + * a procedure so we can have local temporaries. + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + + /* + * Parse the command (trivially). Expect the following: + * dict with ? ...? + */ + + dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr); + tokenPtr = TokenAfter(dictVarTokenPtr); + for (i=3 ; inumWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + } + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + + /* + * Allocate local (unnamed, untraced) working variables. + */ + + gotPath = (parsePtr->numWords > 3); + varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); + if (gotPath) { + pathTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); + } else { + pathTmp = -1; + } + keysTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); + + /* + * Issue instructions. First, the part to expand the dictionary. + */ + + tokenPtr = dictVarTokenPtr; + CompileWord(envPtr, tokenPtr, interp, 0); + if (varNameTmp <= 255) { + TclEmitInstInt1( INST_STORE_SCALAR1, varNameTmp, envPtr); + } else { + TclEmitInstInt4( INST_STORE_SCALAR4, varNameTmp, envPtr); + } + tokenPtr = TokenAfter(tokenPtr); + if (gotPath) { + for (i=2 ; inumWords-1 ; i++) { + CompileWord(envPtr, tokenPtr, interp, i-1); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); + if (pathTmp <= 255) { + TclEmitInstInt1( INST_STORE_SCALAR1, pathTmp, envPtr); + } else { + TclEmitInstInt4( INST_STORE_SCALAR4, pathTmp, envPtr); + } + TclEmitOpcode( INST_POP, envPtr); + } + TclEmitOpcode( INST_LOAD_STK, envPtr); + if (gotPath) { + if (pathTmp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, pathTmp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, pathTmp, envPtr); + } + } else { + PushLiteral(envPtr, "", 0); + } + TclEmitOpcode( INST_DICT_EXPAND, envPtr); + if (keysTmp <= 255) { + TclEmitInstInt1( INST_STORE_SCALAR1, keysTmp, envPtr); + } else { + TclEmitInstInt4( INST_STORE_SCALAR4, keysTmp, envPtr); + } + TclEmitOpcode( INST_POP, envPtr); + + /* + * Now the body of the [dict with]. + */ + + range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + + ExceptionRangeStarts(envPtr, range); + envPtr->currStackDepth++; + SetLineInformation(parsePtr->numWords-1); + CompileBody(envPtr, tokenPtr, interp); + envPtr->currStackDepth = savedStackDepth; + ExceptionRangeEnds(envPtr, range); + + /* + * Now fold the results back into the dictionary in the OK case. + */ + + TclEmitOpcode( INST_END_CATCH, envPtr); + if (varNameTmp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, varNameTmp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, varNameTmp, envPtr); + } + if (gotPath) { + if (pathTmp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, pathTmp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, pathTmp, envPtr); + } + } else { + PushLiteral(envPtr, "", 0); + } + if (keysTmp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, keysTmp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, keysTmp, envPtr); + } + TclEmitOpcode( INST_DICT_RECOMBINE, envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + + /* + * Now fold the results back into the dictionary in the exception case. + */ + + ExceptionRangeTarget(envPtr, range, catchOffset); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + if (varNameTmp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, varNameTmp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, varNameTmp, envPtr); + } + if (parsePtr->numWords > 3) { + if (pathTmp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, pathTmp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, pathTmp, envPtr); + } + } else { + PushLiteral(envPtr, "", 0); + } + if (keysTmp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, keysTmp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, keysTmp, envPtr); + } + TclEmitOpcode( INST_DICT_RECOMBINE, envPtr); + TclEmitOpcode( INST_RETURN_STK, envPtr); + + /* + * Prepare for the start of the next command. + */ + + if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { + Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", + (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); + } + return TCL_OK; +}  /* *---------------------------------------------------------------------- diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index d96670c..b043fed 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -167,135 +167,135 @@ enum Marks { /* Leaf lexemes */ -#define NUMBER ( LEAF | 1) /* For literal numbers */ -#define SCRIPT ( LEAF | 2) /* Script substitution; [foo] */ -#define BOOLEAN ( LEAF | BAREWORD) /* For literal booleans */ -#define BRACED ( LEAF | 4) /* Braced string; {foo bar} */ -#define VARIABLE ( LEAF | 5) /* Variable substitution; $x */ -#define QUOTED ( LEAF | 6) /* Quoted string; "foo $bar [soom]" */ -#define EMPTY ( LEAF | 7) /* Used only for an empty argument - * list to a function. Represents the - * empty string within parens in the - * expression: rand() */ +#define NUMBER (LEAF | 1) + /* For literal numbers */ +#define SCRIPT (LEAF | 2) + /* Script substitution; [foo] */ +#define BOOLEAN (LEAF | BAREWORD) + /* For literal booleans */ +#define BRACED (LEAF | 4) + /* Braced string; {foo bar} */ +#define VARIABLE (LEAF | 5) + /* Variable substitution; $x */ +#define QUOTED (LEAF | 6) + /* Quoted string; "foo $bar [soom]" */ +#define EMPTY (LEAF | 7) + /* Used only for an empty argument list to a + * function. Represents the empty string + * within parens in the expression: rand() */ /* Unary operator lexemes */ -#define UNARY_PLUS ( UNARY | PLUS) -#define UNARY_MINUS ( UNARY | MINUS) -#define FUNCTION ( UNARY | BAREWORD) /* This is a bit of "creative - * interpretation" on the part of the - * parser. A function call is parsed - * into the parse tree according to - * the perspective that the function - * name is a unary operator and its - * argument list, enclosed in parens, - * is its operand. The additional - * requirements not implied generally - * by treatment as a unary operator -- - * for example, the requirement that - * the operand be enclosed in parens - * -- are hard coded in the relevant - * portions of ParseExpr(). We trade - * off the need to include such - * exceptional handling in the code - * against the need we would otherwise - * have for more lexeme categories. */ -#define START ( UNARY | 4) /* This lexeme isn't parsed from the - * expression text at all. It - * represents the start of the - * expression and sits at the root of - * the parse tree where it serves as - * the start/end point of - * traversals. */ -#define OPEN_PAREN ( UNARY | 5) /* Another bit of creative - * interpretation, where we treat "(" - * as a unary operator with the - * sub-expression between it and its - * matching ")" as its operand. See - * CLOSE_PAREN below. */ -#define NOT ( UNARY | 6) -#define BIT_NOT ( UNARY | 7) +#define UNARY_PLUS (UNARY | PLUS) +#define UNARY_MINUS (UNARY | MINUS) +#define FUNCTION (UNARY | BAREWORD) + /* This is a bit of "creative interpretation" + * on the part of the parser. A function call + * is parsed into the parse tree according to + * the perspective that the function name is a + * unary operator and its argument list, + * enclosed in parens, is its operand. The + * additional requirements not implied + * generally by treatment as a unary operator + * -- for example, the requirement that the + * operand be enclosed in parens -- are hard + * coded in the relevant portions of + * ParseExpr(). We trade off the need to + * include such exceptional handling in the + * code against the need we would otherwise + * have for more lexeme categories. */ +#define START (UNARY | 4) + /* This lexeme isn't parsed from the + * expression text at all. It represents the + * start of the expression and sits at the + * root of the parse tree where it serves as + * the start/end point of traversals. */ +#define OPEN_PAREN (UNARY | 5) + /* Another bit of creative interpretation, + * where we treat "(" as a unary operator with + * the sub-expression between it and its + * matching ")" as its operand. See + * CLOSE_PAREN below. */ +#define NOT (UNARY | 6) +#define BIT_NOT (UNARY | 7) /* Binary operator lexemes */ -#define BINARY_PLUS ( BINARY | PLUS) -#define BINARY_MINUS ( BINARY | MINUS) -#define COMMA ( BINARY | 3) /* The "," operator is a low - * precedence binary operator that - * separates the arguments in a - * function call. The additional - * constraint that this operator can - * only legally appear at the right - * places within a function call - * argument list are hard coded within - * ParseExpr(). */ -#define MULT ( BINARY | 4) -#define DIVIDE ( BINARY | 5) -#define MOD ( BINARY | 6) -#define LESS ( BINARY | 7) -#define GREATER ( BINARY | 8) -#define BIT_AND ( BINARY | 9) -#define BIT_XOR ( BINARY | 10) -#define BIT_OR ( BINARY | 11) -#define QUESTION ( BINARY | 12) /* These two lexemes make up the */ -#define COLON ( BINARY | 13) /* ternary conditional operator, - * $x ? $y : $z . We treat them as two - * binary operators to avoid another - * lexeme category, and code the - * additional constraints directly in - * ParseExpr(). For instance, the - * right operand of a "?" operator - * must be a ":" operator. */ -#define LEFT_SHIFT ( BINARY | 14) -#define RIGHT_SHIFT ( BINARY | 15) -#define LEQ ( BINARY | 16) -#define GEQ ( BINARY | 17) -#define EQUAL ( BINARY | 18) -#define NEQ ( BINARY | 19) -#define AND ( BINARY | 20) -#define OR ( BINARY | 21) -#define STREQ ( BINARY | 22) -#define STRNEQ ( BINARY | 23) -#define EXPON ( BINARY | 24) /* Unlike the other binary operators, - * EXPON is right associative and this - * distinction is coded directly in - * ParseExpr(). */ -#define IN_LIST ( BINARY | 25) -#define NOT_IN_LIST ( BINARY | 26) -#define CLOSE_PAREN ( BINARY | 27) /* By categorizing the CLOSE_PAREN - * lexeme as a BINARY operator, the - * normal parsing rules for binary - * operators assure that a close paren - * will not directly follow another - * operator, and the machinery already - * in place to connect operands to - * operators according to precedence - * performs most of the work of - * matching open and close parens for - * us. In the end though, a close - * paren is not really a binary - * operator, and some special coding - * in ParseExpr() make sure we never - * put an actual CLOSE_PAREN node in - * the parse tree. The sub-expression - * between parens becomes the single - * argument of the matching OPEN_PAREN - * unary operator. */ -#define END ( BINARY | 28) /* This lexeme represents the end of - * the string being parsed. Treating - * it as a binary operator follows the - * same logic as the CLOSE_PAREN - * lexeme and END pairs with START, in - * the same way that CLOSE_PAREN pairs - * with OPEN_PAREN. */ +#define BINARY_PLUS (BINARY | PLUS) +#define BINARY_MINUS (BINARY | MINUS) +#define COMMA (BINARY | 3) + /* The "," operator is a low precedence binary + * operator that separates the arguments in a + * function call. The additional constraint + * that this operator can only legally appear + * at the right places within a function call + * argument list are hard coded within + * ParseExpr(). */ +#define MULT (BINARY | 4) +#define DIVIDE (BINARY | 5) +#define MOD (BINARY | 6) +#define LESS (BINARY | 7) +#define GREATER (BINARY | 8) +#define BIT_AND (BINARY | 9) +#define BIT_XOR (BINARY | 10) +#define BIT_OR (BINARY | 11) +#define QUESTION (BINARY | 12) + /* These two lexemes make up the */ +#define COLON (BINARY | 13) + /* ternary conditional operator, $x ? $y : $z. + * We treat them as two binary operators to + * avoid another lexeme category, and code the + * additional constraints directly in + * ParseExpr(). For instance, the right + * operand of a "?" operator must be a ":" + * operator. */ +#define LEFT_SHIFT (BINARY | 14) +#define RIGHT_SHIFT (BINARY | 15) +#define LEQ (BINARY | 16) +#define GEQ (BINARY | 17) +#define EQUAL (BINARY | 18) +#define NEQ (BINARY | 19) +#define AND (BINARY | 20) +#define OR (BINARY | 21) +#define STREQ (BINARY | 22) +#define STRNEQ (BINARY | 23) +#define EXPON (BINARY | 24) + /* Unlike the other binary operators, EXPON is + * right associative and this distinction is + * coded directly in ParseExpr(). */ +#define IN_LIST (BINARY | 25) +#define NOT_IN_LIST (BINARY | 26) +#define CLOSE_PAREN (BINARY | 27) + /* By categorizing the CLOSE_PAREN lexeme as a + * BINARY operator, the normal parsing rules + * for binary operators assure that a close + * paren will not directly follow another + * operator, and the machinery already in + * place to connect operands to operators + * according to precedence performs most of + * the work of matching open and close parens + * for us. In the end though, a close paren is + * not really a binary operator, and some + * special coding in ParseExpr() make sure we + * never put an actual CLOSE_PAREN node in the + * parse tree. The sub-expression between + * parens becomes the single argument of the + * matching OPEN_PAREN unary operator. */ +#define END (BINARY | 28) + /* This lexeme represents the end of the + * string being parsed. Treating it as a + * binary operator follows the same logic as + * the CLOSE_PAREN lexeme and END pairs with + * START, in the same way that CLOSE_PAREN + * pairs with OPEN_PAREN. */ + /* * When ParseExpr() builds the parse tree it must choose which operands to * connect to which operators. This is done according to operator precedence. - * The greater an operator's precedence the greater claim it has to link to - * an available operand. The Precedence enumeration lists the precedence - * values used by Tcl expression operators, from lowest to highest claim. - * Each precedence level is commented with the operators that hold that - * precedence. + * The greater an operator's precedence the greater claim it has to link to an + * available operand. The Precedence enumeration lists the precedence values + * used by Tcl expression operators, from lowest to highest claim. Each + * precedence level is commented with the operators that hold that precedence. */ enum Precedence { @@ -320,9 +320,9 @@ enum Precedence { }; /* - * Here the same information contained in the comments above is stored - * in inverted form, so that given a lexeme, one can quickly look up - * its precedence value. + * Here the same information contained in the comments above is stored in + * inverted form, so that given a lexeme, one can quickly look up its + * precedence value. */ static const unsigned char prec[] = { @@ -599,7 +599,10 @@ ParseExpr( * actual leaf at the time the complete tree * is needed. */ - /* These variables control generation of the error message. */ + /* + * These variables control generation of the error message. + */ + Tcl_Obj *msg = NULL; /* The error message. */ Tcl_Obj *post = NULL; /* In a few cases, an additional postscript * for the error message, supplying more @@ -801,17 +804,19 @@ ParseExpr( } } /* Uncategorized lexemes */ - /* Handle lexeme based on its category. */ - switch (NODE_TYPE & lexeme) { - /* - * Each LEAF results in either a literal getting appended to the - * litList, or a sequence of Tcl_Tokens representing a Tcl word - * getting appended to the parsePtr->tokens. No OpNode is filled for - * this lexeme. + * Handle lexeme based on its category. */ + switch (NODE_TYPE & lexeme) { case LEAF: { + /* + * Each LEAF results in either a literal getting appended to the + * litList, or a sequence of Tcl_Tokens representing a Tcl word + * getting appended to the parsePtr->tokens. No OpNode is filled + * for this lexeme. + */ + Tcl_Token *tokenPtr; const char *end = start; int wordIndex; @@ -828,7 +833,10 @@ ParseExpr( scanned = 0; insertMark = 1; - /* Free any literal to avoid a memleak. */ + /* + * Free any literal to avoid a memleak. + */ + if ((lexeme == NUMBER) || (lexeme == BOOLEAN)) { Tcl_DecrRefCount(literal); } @@ -1027,7 +1035,10 @@ ParseExpr( goto error; } - /* Create an OpNode for the unary operator */ + /* + * Create an OpNode for the unary operator. + */ + nodePtr->lexeme = lexeme; nodePtr->precedence = prec[lexeme]; nodePtr->mark = MARK_RIGHT; @@ -1498,7 +1509,10 @@ ConvertTreeToTokens( case OT_LITERAL: - /* Skip any white space that comes before the literal */ + /* + * Skip any white space that comes before the literal. + */ + scanned = TclParseAllWhiteSpace(start, numBytes); start += scanned; numBytes -= scanned; @@ -1581,7 +1595,10 @@ ConvertTreeToTokens( default: - /* Advance to the child node, which is an operator. */ + /* + * Advance to the child node, which is an operator. + */ + nodePtr = nodes + next; /* @@ -1662,7 +1679,10 @@ ConvertTreeToTokens( case MARK_RIGHT: next = nodePtr->right; - /* Skip any white space that comes before the operator */ + /* + * Skip any white space that comes before the operator. + */ + scanned = TclParseAllWhiteSpace(start, numBytes); start += scanned; numBytes -= scanned; @@ -1679,7 +1699,10 @@ ConvertTreeToTokens( case COMMA: case COLON: - /* No tokens for these lexemes -> nothing to do. */ + /* + * No tokens for these lexemes -> nothing to do. + */ + break; default: @@ -1714,7 +1737,10 @@ ConvertTreeToTokens( case OPEN_PAREN: - /* Skip past matching close paren. */ + /* + * Skip past matching close paren. + */ + scanned = TclParseAllWhiteSpace(start, numBytes); start += scanned; numBytes -= scanned; @@ -1723,7 +1749,7 @@ ConvertTreeToTokens( numBytes -= scanned; break; - default: { + default: /* * Before we leave this node/operator/subexpression for the @@ -1757,7 +1783,6 @@ ConvertTreeToTokens( subExprTokenIdx = parentIdx; break; } - } /* * Since we're returning to parent, skip child handling code. @@ -2009,6 +2034,7 @@ ParseLexeme( */ if (literal->typePtr == &tclDoubleType) { const char *p = start; + while (p < end) { if (!isalnum(UCHAR(*p++))) { /* @@ -2028,6 +2054,7 @@ ParseLexeme( */ goto number; } + /* * Otherwise, fall through and parse the whole as a bareword. */ @@ -2290,22 +2317,22 @@ CompileExprTree( break; } case QUESTION: - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump)); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); break; case COLON: CLANG_ASSERT(jumpPtr); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &(jumpPtr->next->jump)); + &jumpPtr->next->jump); envPtr->currStackDepth = jumpPtr->depth; jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); jumpPtr->convert = convert; convert = 1; break; case AND: - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump)); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); break; case OR: - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &(jumpPtr->jump)); + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpPtr->jump); break; } } else { @@ -2348,12 +2375,12 @@ CompileExprTree( break; case COLON: CLANG_ASSERT(jumpPtr); - if (TclFixupForwardJump(envPtr, &(jumpPtr->next->jump), + if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, (envPtr->codeNext - envPtr->codeStart) - jumpPtr->next->jump.codeOffset, 127)) { jumpPtr->offset += 3; } - TclFixupForwardJump(envPtr, &(jumpPtr->jump), + TclFixupForwardJump(envPtr, &jumpPtr->jump, jumpPtr->offset - jumpPtr->jump.codeOffset, 127); convert |= jumpPtr->convert; envPtr->currStackDepth = jumpPtr->depth + 1; @@ -2369,18 +2396,18 @@ CompileExprTree( CLANG_ASSERT(jumpPtr); TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, - &(jumpPtr->next->jump)); + &jumpPtr->next->jump); TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &(jumpPtr->next->next->jump)); - TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->jump), 127); - if (TclFixupForwardJumpToHere(envPtr, &(jumpPtr->jump), 127)) { + &jumpPtr->next->next->jump); + TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127); + if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { jumpPtr->next->next->jump.codeOffset += 3; } TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); - TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->next->jump), + TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump, 127); convert = 0; envPtr->currStackDepth = jumpPtr->depth + 1; @@ -2400,8 +2427,8 @@ CompileExprTree( break; } if (nodePtr == rootPtr) { - /* We're done */ + return; } nodePtr = nodes + nodePtr->p.parent; @@ -2478,6 +2505,7 @@ CompileExprTree( * Don't generate a string rep, but if we have one * already, then use it to share via the literal table. */ + if (objPtr->bytes) { Tcl_Obj *tableValue; @@ -2486,7 +2514,10 @@ CompileExprTree( tableValue = envPtr->literalArrayPtr[index].objPtr; if ((tableValue->typePtr == NULL) && (objPtr->typePtr != NULL)) { - /* Same intrep surgery as for OT_LITERAL */ + /* + * Same intrep surgery as for OT_LITERAL. + */ + tableValue->typePtr = objPtr->typePtr; tableValue->internalRep = objPtr->internalRep; objPtr->typePtr = NULL; @@ -2511,6 +2542,7 @@ CompileExprTree( *---------------------------------------------------------------------- * * TclSingleOpCmd -- + * * Implements the commands: ~, !, <<, >>, %, !=, ne, in, ni * in the ::tcl::mathop namespace. These commands have no * extension to arbitrary arguments; they accept only exactly one @@ -2537,7 +2569,7 @@ TclSingleOpCmd( OpNode nodes[2]; Tcl_Obj *const *litObjv = objv + 1; - if (objc != 1+occdPtr->i.numArgs) { + if (objc != 1 + occdPtr->i.numArgs) { Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected); return TCL_ERROR; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 026503b..4b5d2bb 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -421,6 +421,16 @@ InstructionDesc const tclInstructionTable[] = { /* Make general variable cease to exist; unparsed variable name is * stktop; op1 is 1 for errors on problems, 0 otherwise */ + {"dictExpand", 1, -1, 0, {OPERAND_NONE}}, + /* Probe into a dict and extract it (or a subdict of it) into + * variables with matched names. Produces list of keys bound as + * result. Part of [dict with]. + * Stack: ... dict path => ... keyList */ + {"dictRecombine", 1, -3, 0, {OPERAND_NONE}}, + /* Map variable contents back into a dictionary in a variable. Part of + * [dict with]. + * Stack: ... dictVarName path keyList => ... */ + {NULL, 0, 0, 0, {OPERAND_NONE}} };  diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 45d50ea..0cd667c 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -676,8 +676,11 @@ typedef struct ByteCode { #define INST_UNSET_ARRAY_STK 136 #define INST_UNSET_STK 137 +#define INST_DICT_EXPAND 138 +#define INST_DICT_RECOMBINE 139 + /* The last opcode */ -#define LAST_INST_OPCODE 137 +#define LAST_INST_OPCODE 139  /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 83fc3a6..5b7ca9b 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -103,7 +103,7 @@ static const EnsembleImplMap implementationMap[] = { {"unset", DictUnsetCmd, NULL, NULL, NULL, 0 }, {"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 }, {"values", DictValuesCmd, NULL, NULL, NULL, 0 }, - {"with", DictWithCmd, NULL, NULL, NULL, 0 }, + {"with", DictWithCmd, TclCompileDictWithCmd, NULL, NULL, 0 }, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -3110,9 +3110,7 @@ DictWithCmd( Tcl_Obj *const *objv) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *dictPtr, *keysPtr, *keyPtr = NULL, *valPtr = NULL, *pathPtr; - Tcl_DictSearch s; - int done; + Tcl_Obj *dictPtr, *keysPtr, *pathPtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictVar ?key ...? script"); @@ -3127,39 +3125,13 @@ DictWithCmd( if (dictPtr == NULL) { return TCL_ERROR; } - if (objc > 3) { - dictPtr = TclTraceDictPath(interp, dictPtr, objc-3, objv+2, - DICT_PATH_READ); - if (dictPtr == NULL) { - return TCL_ERROR; - } - } - /* - * Go over the list of keys and write each corresponding value to a - * variable in the current context with the same name. Also keep a copy of - * the keys so we can write back properly later on even if the dictionary - * has been structurally modified. - */ - - if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr, - &done) != TCL_OK) { + keysPtr = TclDictWithInit(interp, dictPtr, objc-3, objv+2); + if (keysPtr == NULL) { return TCL_ERROR; } - - TclNewObj(keysPtr); Tcl_IncrRefCount(keysPtr); - for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) { - Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr); - if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr, - TCL_LEAVE_ERR_MSG) == NULL) { - TclDecrRefCount(keysPtr); - Tcl_DictObjDone(&s); - return TCL_ERROR; - } - } - /* * Execute the body, while making the invoking context available to the * loop body (TIP#280) and postponing the cleanup until later (NRE). @@ -3183,8 +3155,8 @@ FinalizeDictWith( Tcl_Interp *interp, int result) { - Tcl_Obj **keyv, *leafPtr, *dictPtr, *valPtr; - int keyc, i, allocdict = 0; + Tcl_Obj **pathv; + int pathc; Tcl_InterpState state; Tcl_Obj *varName = data[0]; Tcl_Obj *keysPtr = data[1]; @@ -3195,43 +3167,163 @@ FinalizeDictWith( } /* + * Save the result state; TDWF doesn't guarantee to not modify that on + * TCL_OK result. + */ + + state = Tcl_SaveInterpState(interp, result); + if (pathPtr != NULL) { + Tcl_ListObjGetElements(NULL, pathPtr, &pathc, &pathv); + } else { + pathc = 0; + pathv = NULL; + } + + /* + * Pack from local variables back into the dictionary. + */ + + result = TclDictWithFinish(interp, varName, pathc, pathv, keysPtr); + + /* + * Tidy up and return the real result (unless we had an error). + */ + + TclDecrRefCount(varName); + TclDecrRefCount(keysPtr); + if (pathPtr != NULL) { + TclDecrRefCount(pathPtr); + } + if (result != TCL_OK) { + Tcl_DiscardInterpState(state); + return TCL_ERROR; + } + return Tcl_RestoreInterpState(interp, state); +} + +/* + *---------------------------------------------------------------------- + * + * TclDictWithInit -- + * + * Part of the core of [dict with]. Pokes into a dictionary and converts + * the mappings there into assignments to (presumably) local variables. + * Returns a list of all the names that were mapped so that removal of + * either the variable or the dictionary entry won't surprise us when we + * come to stuffing everything back. + * + * Result: + * List of mapped names, or NULL if there was an error. + * + * Side effects: + * Assigns to variables, so potentially legion due to traces. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclDictWithInit( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + int pathc, + Tcl_Obj *const pathv[]) +{ + Tcl_DictSearch s; + Tcl_Obj *keyPtr, *valPtr, *keysPtr; + int done; + + if (pathc > 0) { + dictPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv, + DICT_PATH_READ); + if (dictPtr == NULL) { + return NULL; + } + } + + /* + * Go over the list of keys and write each corresponding value to a + * variable in the current context with the same name. Also keep a copy of + * the keys so we can write back properly later on even if the dictionary + * has been structurally modified. + */ + + if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr, + &done) != TCL_OK) { + return NULL; + } + + TclNewObj(keysPtr); + + for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) { + Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr); + if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(keysPtr); + Tcl_DictObjDone(&s); + return NULL; + } + } + + return keysPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclDictWithFinish -- + * + * Part of the core of [dict with]. Reassembles the piece of the dict (in + * varName, location given by pathc/pathv) from the variables named in + * the keysPtr argument. NB, does not try to preserve errors or manage + * argument lifetimes. + * + * Result: + * TCL_OK if we succeeded, or TCL_ERROR if we failed. + * + * Side effects: + * Assigns to a variable, so potentially legion due to traces. Updates + * the dictionary in the named variable. + * + *---------------------------------------------------------------------- + */ + +int +TclDictWithFinish( + Tcl_Interp *interp, + Tcl_Obj *varName, + int pathc, + Tcl_Obj *const pathv[], + Tcl_Obj *keysPtr) +{ + Tcl_Obj *dictPtr, *leafPtr, *valPtr; + int i, allocdict, keyc; + Tcl_Obj **keyv; + + /* * If the dictionary variable doesn't exist, drop everything silently. */ dictPtr = Tcl_ObjGetVar2(interp, varName, NULL, 0); if (dictPtr == NULL) { - TclDecrRefCount(varName); - TclDecrRefCount(keysPtr); - if (pathPtr) { - TclDecrRefCount(pathPtr); - } - return result; + return TCL_OK; } /* * Double-check that it is still a dictionary. */ - state = Tcl_SaveInterpState(interp, result); if (Tcl_DictObjSize(interp, dictPtr, &i) != TCL_OK) { - TclDecrRefCount(varName); - TclDecrRefCount(keysPtr); - if (pathPtr) { - TclDecrRefCount(pathPtr); - } - Tcl_DiscardInterpState(state); return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); allocdict = 1; + } else { + allocdict = 0; } - if (pathPtr != NULL) { - Tcl_Obj **pathv; - int pathc; - + if (pathc > 0) { /* * Want to get to the dictionary which we will update; need to do * prepare-for-update de-sharing along the path *but* avoid generating @@ -3241,26 +3333,19 @@ FinalizeDictWith( * perfectly efficient (but no memory should be leaked). */ - Tcl_ListObjGetElements(NULL, pathPtr, &pathc, &pathv); leafPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv, DICT_PATH_EXISTS | DICT_PATH_UPDATE); - TclDecrRefCount(pathPtr); if (leafPtr == NULL) { - TclDecrRefCount(varName); - TclDecrRefCount(keysPtr); if (allocdict) { TclDecrRefCount(dictPtr); } - Tcl_DiscardInterpState(state); return TCL_ERROR; } if (leafPtr == DICT_PATH_NON_EXISTENT) { - TclDecrRefCount(varName); - TclDecrRefCount(keysPtr); if (allocdict) { TclDecrRefCount(dictPtr); } - return Tcl_RestoreInterpState(interp, state); + return TCL_OK; } } else { leafPtr = dictPtr; @@ -3286,14 +3371,13 @@ FinalizeDictWith( Tcl_DictObjPut(NULL, leafPtr, keyv[i], valPtr); } } - TclDecrRefCount(keysPtr); /* * Ensure that none of the dictionaries in the chain still have a string * rep. */ - if (pathPtr != NULL) { + if (pathc > 0) { InvalidateDictChain(leafPtr); } @@ -3303,11 +3387,12 @@ FinalizeDictWith( if (Tcl_ObjSetVar2(interp, varName, NULL, dictPtr, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DiscardInterpState(state); + if (allocdict) { + TclDecrRefCount(dictPtr); + } return TCL_ERROR; } - TclDecrRefCount(varName); - return Tcl_RestoreInterpState(interp, state); + return TCL_OK; }  /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 691c8d7..e3db83e 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1992,9 +1992,8 @@ TclNRExecuteByteCode( * Push the callback for bytecode execution */ - TclNRAddCallback(interp, TEBCresume, TD, - /*resume*/ INT2PTR(0), NULL, NULL); - + TclNRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0), + NULL, NULL); return TCL_OK; } @@ -5625,7 +5624,7 @@ TEBCresume( { int opnd2, allocateDict, done, i, allocdict; - Tcl_Obj *dictPtr, *statePtr, *keyPtr; + Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr; Tcl_Obj *emptyPtr, **keyPtrPtr; Tcl_DictSearch *searchPtr; DictUpdateInfo *duiPtr; @@ -6105,6 +6104,44 @@ TEBCresume( } } NEXT_INST_F(9, 1, 0); + + case INST_DICT_EXPAND: + dictPtr = OBJ_UNDER_TOS; + listPtr = OBJ_AT_TOS; + if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", + O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); + goto gotError; + } + objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv); + if (objResultPtr == NULL) { + TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", + O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); + goto gotError; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + + case INST_DICT_RECOMBINE: + varNamePtr = OBJ_AT_DEPTH(2); + listPtr = OBJ_UNDER_TOS; + keysPtr = OBJ_AT_TOS; + if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + TRACE_WITH_OBJ(("%.30s %.30s %.30s => ERROR: ", + O2S(varNamePtr), O2S(listPtr), O2S(keysPtr)), + Tcl_GetObjResult(interp)); + goto gotError; + } + if (TclDictWithFinish(interp, varNamePtr, objc, objv, + keysPtr) != TCL_OK) { + TRACE_WITH_OBJ(("%.30s %.30s %.30s => ERROR: ", + O2S(varNamePtr), O2S(listPtr), O2S(keysPtr)), + Tcl_GetObjResult(interp)); + goto gotError; + } + TclDecrRefCount(keysPtr); + POP_OBJECT(); + NEXT_INST_F(1, 2, 0); } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index f30e83e..e7a84ce 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3231,6 +3231,11 @@ MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); +MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, + Tcl_Obj *varName, int pathc, + Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); +MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, + int pathc, Tcl_Obj *const pathv[]); MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3495,6 +3500,9 @@ MODULE_SCOPE int TclCompileDictSetCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileDictUpdateCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictWithCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileEnsemble(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From 12b24fa2fb8f381005e95bb52ab317ccfaae110e Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 3 Oct 2011 07:51:00 +0000 Subject: Add assembler support for the new INST that I think has a stable interface. --- generic/tclAssembly.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index cd6dc38..2133ebe 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -370,6 +370,7 @@ TalInstDesc TalInstructionTable[] = { {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1}, {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, + {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1}, {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, {"dictIncrImm", ASSEM_SINT4_LVT4, INST_DICT_INCR_IMM, 1, 1}, -- cgit v0.12 From f5da66af9b1d20982f24f809029662cdf55fe3b0 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 3 Oct 2011 10:45:35 +0000 Subject: Added support for having the dict var itself referenced by LVT index. --- generic/tclCompCmds.c | 69 ++++++++++++++++++++++++++++++++++++++++----------- generic/tclCompile.c | 6 ++++- generic/tclCompile.h | 5 ++-- generic/tclDictObj.c | 43 +++++++++++++++++++++++++------- generic/tclExecute.c | 60 ++++++++++++++++++++++++++++++++++---------- generic/tclInt.h | 5 ++-- 6 files changed, 147 insertions(+), 41 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 172a58d..0b6b76b 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1245,7 +1245,7 @@ TclCompileDictWithCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int i, range, varNameTmp, pathTmp, keysTmp, gotPath; + int i, range, varNameTmp, pathTmp, keysTmp, gotPath, dictVar = -1; Tcl_Token *dictVarTokenPtr, *tokenPtr; int savedStackDepth = envPtr->currStackDepth; JumpFixup jumpFixup; @@ -1281,7 +1281,32 @@ TclCompileDictWithCmd( */ gotPath = (parsePtr->numWords > 3); - varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); + if (dictVarTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + const char *ptr = dictVarTokenPtr[1].start; + const char *end = ptr + dictVarTokenPtr[1].size; + int notArray = 1; + + /* + * A conservative check for if we're working with an array since we + * have a reasonable fallback if things are tricky. + */ + + for (; ptr -1) { + CompileWord(envPtr, tokenPtr, interp, 0); + if (varNameTmp <= 255) { + TclEmitInstInt1( INST_STORE_SCALAR1, varNameTmp, envPtr); + } else { + TclEmitInstInt4( INST_STORE_SCALAR4, varNameTmp, envPtr); + } } tokenPtr = TokenAfter(tokenPtr); if (gotPath) { @@ -1314,7 +1341,13 @@ TclCompileDictWithCmd( } TclEmitOpcode( INST_POP, envPtr); } - TclEmitOpcode( INST_LOAD_STK, envPtr); + if (dictVar == -1) { + TclEmitOpcode( INST_LOAD_STK, envPtr); + } else if (dictVar <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, dictVar, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, dictVar, envPtr); + } if (gotPath) { if (pathTmp <= 255) { TclEmitInstInt1( INST_LOAD_SCALAR1, pathTmp, envPtr); @@ -1351,9 +1384,9 @@ TclCompileDictWithCmd( */ TclEmitOpcode( INST_END_CATCH, envPtr); - if (varNameTmp <= 255) { + if (varNameTmp > -1 && varNameTmp <= 255) { TclEmitInstInt1( INST_LOAD_SCALAR1, varNameTmp, envPtr); - } else { + } else if (varNameTmp > -1) { TclEmitInstInt4( INST_LOAD_SCALAR4, varNameTmp, envPtr); } if (gotPath) { @@ -1370,7 +1403,11 @@ TclCompileDictWithCmd( } else { TclEmitInstInt4( INST_LOAD_SCALAR4, keysTmp, envPtr); } - TclEmitOpcode( INST_DICT_RECOMBINE, envPtr); + if (dictVar == -1) { + TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); + } else { + TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); + } TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); /* @@ -1381,9 +1418,9 @@ TclCompileDictWithCmd( TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_END_CATCH, envPtr); - if (varNameTmp <= 255) { + if (varNameTmp > -1 && varNameTmp <= 255) { TclEmitInstInt1( INST_LOAD_SCALAR1, varNameTmp, envPtr); - } else { + } else if (varNameTmp > -1) { TclEmitInstInt4( INST_LOAD_SCALAR4, varNameTmp, envPtr); } if (parsePtr->numWords > 3) { @@ -1400,7 +1437,11 @@ TclCompileDictWithCmd( } else { TclEmitInstInt4( INST_LOAD_SCALAR4, keysTmp, envPtr); } - TclEmitOpcode( INST_DICT_RECOMBINE, envPtr); + if (dictVar == -1) { + TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); + } else { + TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); + } TclEmitOpcode( INST_RETURN_STK, envPtr); /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 4b5d2bb..97e2a8a 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -426,10 +426,14 @@ InstructionDesc const tclInstructionTable[] = { * variables with matched names. Produces list of keys bound as * result. Part of [dict with]. * Stack: ... dict path => ... keyList */ - {"dictRecombine", 1, -3, 0, {OPERAND_NONE}}, + {"dictRecombineStk", 1, -3, 0, {OPERAND_NONE}}, /* Map variable contents back into a dictionary in a variable. Part of * [dict with]. * Stack: ... dictVarName path keyList => ... */ + {"dictRecombineImm", 1, -2, 1, {OPERAND_LVT4}}, + /* Map variable contents back into a dictionary in the local variable + * indicated by the LVT index. Part of [dict with]. + * Stack: ... path keyList => ... */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 0cd667c..8e7f0d0 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -677,10 +677,11 @@ typedef struct ByteCode { #define INST_UNSET_STK 137 #define INST_DICT_EXPAND 138 -#define INST_DICT_RECOMBINE 139 +#define INST_DICT_RECOMBINE_STK 139 +#define INST_DICT_RECOMBINE_IMM 140 /* The last opcode */ -#define LAST_INST_OPCODE 139 +#define LAST_INST_OPCODE 140  /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 5b7ca9b..d50c0a2 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -3161,6 +3161,7 @@ FinalizeDictWith( Tcl_Obj *varName = data[0]; Tcl_Obj *keysPtr = data[1]; Tcl_Obj *pathPtr = data[2]; + Var *varPtr, *arrayPtr; if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (body of \"dict with\")"); @@ -3183,7 +3184,14 @@ FinalizeDictWith( * Pack from local variables back into the dictionary. */ - result = TclDictWithFinish(interp, varName, pathc, pathv, keysPtr); + varPtr = TclObjLookupVarEx(interp, varName, NULL, TCL_LEAVE_ERR_MSG, "set", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + result = TCL_ERROR; + } else { + result = TclDictWithFinish(interp, varPtr, arrayPtr, varName, NULL, -1, + pathc, pathv, keysPtr); + } /* * Tidy up and return the real result (unless we had an error). @@ -3289,11 +3297,27 @@ TclDictWithInit( int TclDictWithFinish( - Tcl_Interp *interp, - Tcl_Obj *varName, - int pathc, - Tcl_Obj *const pathv[], - Tcl_Obj *keysPtr) + Tcl_Interp *interp, /* Command interpreter in which variable + * exists. Used for state management, traces + * and error reporting. */ + Var *varPtr, /* Reference to the variable holding the + * dictionary. */ + Var *arrayPtr, /* Reference to the array containing the + * variable, or NULL if the variable is a + * scalar. */ + Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or + * the name of a variable. NULL if the 'index' + * parameter is >= 0 */ + Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element + * in the array part1. */ + int index, /* Index into the local variable table of the + * variable, or -1. Only used when part1Ptr is + * NULL. */ + int pathc, /* The number of elements in the path into the + * dictionary. */ + Tcl_Obj *const pathv[], /* The elements of the path to the subdict. */ + Tcl_Obj *keysPtr) /* List of keys to be synchronized. This is + * the result value from TclDictWithInit. */ { Tcl_Obj *dictPtr, *leafPtr, *valPtr; int i, allocdict, keyc; @@ -3303,7 +3327,8 @@ TclDictWithFinish( * If the dictionary variable doesn't exist, drop everything silently. */ - dictPtr = Tcl_ObjGetVar2(interp, varName, NULL, 0); + dictPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + TCL_LEAVE_ERR_MSG, index); if (dictPtr == NULL) { return TCL_OK; } @@ -3385,8 +3410,8 @@ TclDictWithFinish( * Write back the outermost dictionary to the variable. */ - if (Tcl_ObjSetVar2(interp, varName, NULL, dictPtr, - TCL_LEAVE_ERR_MSG) == NULL) { + if (TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, dictPtr, + TCL_LEAVE_ERR_MSG, index) == NULL) { if (allocdict) { TclDecrRefCount(dictPtr); } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e3db83e..953c63e 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6122,26 +6122,60 @@ TEBCresume( TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - case INST_DICT_RECOMBINE: - varNamePtr = OBJ_AT_DEPTH(2); - listPtr = OBJ_UNDER_TOS; - keysPtr = OBJ_AT_TOS; + case INST_DICT_RECOMBINE_STK: + keysPtr = POP_OBJECT(); + varNamePtr = OBJ_UNDER_TOS; + listPtr = OBJ_AT_TOS; + TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", + O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr))); if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s %.30s %.30s => ERROR: ", - O2S(varNamePtr), O2S(listPtr), O2S(keysPtr)), - Tcl_GetObjResult(interp)); + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TclDecrRefCount(keysPtr); goto gotError; } - if (TclDictWithFinish(interp, varNamePtr, objc, objv, - keysPtr) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s %.30s %.30s => ERROR: ", - O2S(varNamePtr), O2S(listPtr), O2S(keysPtr)), - Tcl_GetObjResult(interp)); + varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, + TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TclDecrRefCount(keysPtr); goto gotError; } + DECACHE_STACK_INFO(); + result = TclDictWithFinish(interp, varPtr,arrayPtr,varNamePtr,NULL,-1, + objc, objv, keysPtr); + CACHE_STACK_INFO(); TclDecrRefCount(keysPtr); - POP_OBJECT(); + if (result != TCL_OK) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + TRACE_APPEND(("OK\n")); NEXT_INST_F(1, 2, 0); + + case INST_DICT_RECOMBINE_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + listPtr = OBJ_UNDER_TOS; + keysPtr = OBJ_AT_TOS; + varPtr = LOCAL(opnd); + TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr), + O2S(keysPtr))); + if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + DECACHE_STACK_INFO(); + result = TclDictWithFinish(interp, varPtr, NULL, NULL, NULL, opnd, + objc, objv, keysPtr); + CACHE_STACK_INFO(); + if (result != TCL_OK) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + TRACE_APPEND(("OK\n")); + NEXT_INST_F(5, 2, 0); } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index e7a84ce..b375bb9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3231,8 +3231,9 @@ MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); -MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, - Tcl_Obj *varName, int pathc, +MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, + Var *arrayPtr, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, int index, int pathc, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, int pathc, Tcl_Obj *const pathv[]); -- cgit v0.12 From 7ca256492ade693ddedf767ac5f7711b24ed8be0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 5 Oct 2011 13:58:56 +0000 Subject: Remove tclWinProcs, as it is no longer being used --- ChangeLog | 6 ++++ win/tclWin32Dll.c | 80 --------------------------------------------------- win/tclWinInt.h | 86 ------------------------------------------------------- 3 files changed, 6 insertions(+), 166 deletions(-) diff --git a/ChangeLog b/ChangeLog index 05cfe7a..4e6c57c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,10 @@ +2011-10-05 Jan Nijtmans + + * generic/tclWinInt.h: Remove tclWinProcs, as it is no longer + * generic/tclWin32Dll.c: being used. + 2011-10-03 Venkat Iyer + * library/tzdata/Africa/Dar_es_Salaam: Update to Olson's tzdata2011k * library/tzdata/Africa/Kampala * library/tzdata/Africa/Nairobi diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 7972862..019d76f 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -17,20 +17,6 @@ #endif /* - * The following data structures are used when loading the thunking library - * for execing child processes under Win32s. - */ - -typedef DWORD (WINAPI UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined, - LPVOID *lpTranslationList); - -typedef BOOL (WINAPI UTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL, - LPCSTR InitName, LPCSTR ProcName, UT32PROC **ThirtyTwoBitThunk, - FARPROC UT32Callback, LPVOID Buff); - -typedef void (WINAPI UTUNREGISTER)(HANDLE hModule); - -/* * The following variables keep track of information about this DLL on a * per-instance basis. Each time this DLL is loaded, it gets its own new data * segment with its own copy of all static and global information. @@ -67,72 +53,6 @@ typedef struct EXCEPTION_REGISTRATION { static Tcl_Encoding winTCharEncoding = NULL; /* - * The following function table is used to dispatch to wide-character - * versions of the operating system calls. - */ - -static const TclWinProcs winProcs = { - 1, - (BOOL (WINAPI *)(const TCHAR *, LPDCB)) BuildCommDCB, - (TCHAR *(WINAPI *)(TCHAR *)) CharLower, - (BOOL (WINAPI *)(const TCHAR *, const TCHAR *, BOOL)) CopyFile, - (BOOL (WINAPI *)(const TCHAR *, LPSECURITY_ATTRIBUTES)) CreateDirectory, - (HANDLE (WINAPI *)(const TCHAR *, DWORD, DWORD, SECURITY_ATTRIBUTES *, - DWORD, DWORD, HANDLE)) CreateFile, - (BOOL (WINAPI *)(const TCHAR *, TCHAR *, LPSECURITY_ATTRIBUTES, - LPSECURITY_ATTRIBUTES, BOOL, DWORD, LPVOID, const TCHAR *, - LPSTARTUPINFO, LPPROCESS_INFORMATION)) CreateProcess, - (BOOL (WINAPI *)(const TCHAR *)) DeleteFile, - (HANDLE (WINAPI *)(const TCHAR *, WIN32_FIND_DATAT *)) FindFirstFile, - (BOOL (WINAPI *)(HANDLE, WIN32_FIND_DATAT *)) FindNextFile, - (BOOL (WINAPI *)(TCHAR *, LPDWORD)) GetComputerName, - (DWORD (WINAPI *)(DWORD, TCHAR *)) GetCurrentDirectory, - (DWORD (WINAPI *)(const TCHAR *)) GetFileAttributes, - (DWORD (WINAPI *)(const TCHAR *, DWORD nBufferLength, TCHAR *, - TCHAR **)) GetFullPathName, - (DWORD (WINAPI *)(const TCHAR *, TCHAR *, DWORD)) GetShortPathName, - (UINT (WINAPI *)(const TCHAR *, const TCHAR *, UINT uUnique, - TCHAR *)) GetTempFileName, - (DWORD (WINAPI *)(DWORD, TCHAR *)) GetTempPath, - (BOOL (WINAPI *)(const TCHAR *, TCHAR *, DWORD, LPDWORD, LPDWORD, LPDWORD, - TCHAR *, DWORD)) GetVolumeInformation, - (HINSTANCE (WINAPI *)(const TCHAR *, HANDLE, DWORD)) LoadLibraryEx, - (BOOL (WINAPI *)(const TCHAR *, const TCHAR *)) MoveFile, - (BOOL (WINAPI *)(const TCHAR *)) RemoveDirectory, - (DWORD (WINAPI *)(const TCHAR *, const TCHAR *, const TCHAR *, DWORD, - TCHAR *, TCHAR **)) SearchPath, - (BOOL (WINAPI *)(const TCHAR *)) SetCurrentDirectory, - (BOOL (WINAPI *)(const TCHAR *, DWORD)) SetFileAttributes, - (BOOL (WINAPI *)(const TCHAR *, GET_FILEEX_INFO_LEVELS, - LPVOID)) GetFileAttributesEx, - (BOOL (WINAPI *)(const TCHAR *, const TCHAR*, - LPSECURITY_ATTRIBUTES)) CreateHardLink, - (HANDLE (WINAPI *)(const TCHAR*, UINT, LPVOID, UINT, - LPVOID, DWORD)) FindFirstFileEx, - (BOOL (WINAPI *)(const TCHAR*, TCHAR*, - DWORD)) GetVolumeNameForVolumeMountPoint, - (DWORD (WINAPI *)(const TCHAR*, TCHAR*, - DWORD)) GetLongPathName, - /* Security SDK */ - (BOOL (WINAPI *)(LPCTSTR, SECURITY_INFORMATION, - PSECURITY_DESCRIPTOR, DWORD, LPDWORD)) GetFileSecurity, - (BOOL (WINAPI *) (SECURITY_IMPERSONATION_LEVEL)) ImpersonateSelf, - (BOOL (WINAPI *) (HANDLE, DWORD, BOOL, PHANDLE)) OpenThreadToken, - (BOOL (WINAPI *) (void)) RevertToSelf, - (void (WINAPI *) (PDWORD, PGENERIC_MAPPING)) MapGenericMask, - (BOOL (WINAPI *)(PSECURITY_DESCRIPTOR, HANDLE, DWORD, - PGENERIC_MAPPING, PPRIVILEGE_SET, LPDWORD, LPDWORD, LPBOOL)) AccessCheck, - /* ReadConsole and WriteConsole */ - (BOOL (WINAPI *)(HANDLE, LPVOID, DWORD, LPDWORD, LPVOID)) ReadConsole, - (BOOL (WINAPI *)(HANDLE, const void*, DWORD, LPDWORD, LPVOID)) WriteConsole, - (BOOL (WINAPI *)(LPTSTR, LPDWORD)) GetUserName, - (const TCHAR *(*)(const char *, int, Tcl_DString *)) Tcl_WinUtfToTChar, - (const char *(*)(const TCHAR *, int, Tcl_DString *)) Tcl_WinTCharToUtf -}; - -const TclWinProcs *const tclWinProcs = &winProcs; - -/* * The following declaration is for the VC++ DLL entry point. */ diff --git a/win/tclWinInt.h b/win/tclWinInt.h index c75084a..882b811 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -34,92 +34,6 @@ #endif /* - * The following structure keeps track of whether we are using the - * multi-byte or the wide-character interfaces to the operating system. - * System calls should be made through the following function table. - */ - -typedef union { - WIN32_FIND_DATAA a; - WIN32_FIND_DATAW w; -} WIN32_FIND_DATAT; - -typedef struct TclWinProcs { - int useWide; - BOOL (WINAPI *buildCommDCBProc)(const TCHAR *, LPDCB); - TCHAR * (WINAPI *charLowerProc)(TCHAR *); - BOOL (WINAPI *copyFileProc)(const TCHAR *, const TCHAR *, BOOL); - BOOL (WINAPI *createDirectoryProc)(const TCHAR *, LPSECURITY_ATTRIBUTES); - HANDLE (WINAPI *createFileProc)(const TCHAR *, DWORD, DWORD, - LPSECURITY_ATTRIBUTES, DWORD, DWORD, HANDLE); - BOOL (WINAPI *createProcessProc)(const TCHAR *, TCHAR *, - LPSECURITY_ATTRIBUTES, LPSECURITY_ATTRIBUTES, BOOL, DWORD, - LPVOID, const TCHAR *, LPSTARTUPINFO, LPPROCESS_INFORMATION); - BOOL (WINAPI *deleteFileProc)(const TCHAR *); - HANDLE (WINAPI *findFirstFileProc)(const TCHAR *, WIN32_FIND_DATAT *); - BOOL (WINAPI *findNextFileProc)(HANDLE, WIN32_FIND_DATAT *); - BOOL (WINAPI *getComputerNameProc)(TCHAR *, LPDWORD); - DWORD (WINAPI *getCurrentDirectoryProc)(DWORD, TCHAR *); - DWORD (WINAPI *getFileAttributesProc)(const TCHAR *); - DWORD (WINAPI *getFullPathNameProc)(const TCHAR *, DWORD, TCHAR *, - TCHAR **); - DWORD (WINAPI *getShortPathNameProc)(const TCHAR *, TCHAR *, DWORD); - UINT (WINAPI *getTempFileNameProc)(const TCHAR *, const TCHAR *, UINT, - TCHAR *); - DWORD (WINAPI *getTempPathProc)(DWORD, TCHAR *); - BOOL (WINAPI *getVolumeInformationProc)(const TCHAR *, TCHAR *, DWORD, - LPDWORD, LPDWORD, LPDWORD, TCHAR *, DWORD); - HINSTANCE (WINAPI *loadLibraryExProc)(const TCHAR *, HANDLE, DWORD); - BOOL (WINAPI *moveFileProc)(const TCHAR *, const TCHAR *); - BOOL (WINAPI *removeDirectoryProc)(const TCHAR *); - DWORD (WINAPI *searchPathProc)(const TCHAR *, const TCHAR *, - const TCHAR *, DWORD, TCHAR *, TCHAR **); - BOOL (WINAPI *setCurrentDirectoryProc)(const TCHAR *); - BOOL (WINAPI *setFileAttributesProc)(const TCHAR *, DWORD); - /* - * These two function pointers will only be set when - * Tcl_FindExecutable is called. If you don't ever call that - * function, the application will crash whenever WinTcl tries to call - * functions through these null pointers. That is not a bug in Tcl - * -- Tcl_FindExecutable is obligatory in recent Tcl releases. - */ - BOOL (WINAPI *getFileAttributesExProc)(const TCHAR *, - GET_FILEEX_INFO_LEVELS, LPVOID); - BOOL (WINAPI *createHardLinkProc)(const TCHAR *, const TCHAR *, - LPSECURITY_ATTRIBUTES); - - /* These two are also NULL at start; see comment above */ - HANDLE (WINAPI *findFirstFileExProc)(const TCHAR *, UINT, - LPVOID, UINT, LPVOID, DWORD); - BOOL (WINAPI *getVolumeNameForVMPProc)(const TCHAR *, TCHAR *, DWORD); - DWORD (WINAPI *getLongPathNameProc)(const TCHAR *, TCHAR *, DWORD); - /* - * These six are for the security sdk to get correct file - * permissions on NT, 2000, XP, etc. On 95,98,ME they are - * always null. - */ - BOOL (WINAPI *getFileSecurityProc)(LPCTSTR, SECURITY_INFORMATION, - PSECURITY_DESCRIPTOR, DWORD, LPDWORD); - BOOL (WINAPI *impersonateSelfProc) (SECURITY_IMPERSONATION_LEVEL); - BOOL (WINAPI *openThreadTokenProc) (HANDLE, DWORD, BOOL, PHANDLE); - BOOL (WINAPI *revertToSelfProc) (void); - void (WINAPI *mapGenericMaskProc) (PDWORD, PGENERIC_MAPPING); - BOOL (WINAPI *accessCheckProc)(PSECURITY_DESCRIPTOR, HANDLE, DWORD, - PGENERIC_MAPPING, PPRIVILEGE_SET, LPDWORD, LPDWORD, LPBOOL); - /* - * Unicode console support. WriteConsole and ReadConsole - */ - BOOL (WINAPI *readConsoleProc)(HANDLE, LPVOID, DWORD, LPDWORD, LPVOID); - BOOL (WINAPI *writeConsoleProc)(HANDLE, const void *, DWORD, LPDWORD, - LPVOID); - BOOL (WINAPI *getUserName)(LPTSTR, LPDWORD); - const TCHAR *(*utf2tchar)(const char *, int, Tcl_DString *); - const char *(*tchar2utf)(const TCHAR *, int, Tcl_DString *); -} TclWinProcs; - -MODULE_SCOPE const TclWinProcs *const tclWinProcs; - -/* * Declarations of functions that are not accessible by way of the * stubs table. */ -- cgit v0.12 From 1b98fe6855837a8d7d1b446067a4e5a1400ab4ad Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 5 Oct 2011 14:05:28 +0000 Subject: wrong copy/paste in ChangeLog --- ChangeLog | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4e6c57c..7b79f88 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,7 @@ 2011-10-05 Jan Nijtmans - * generic/tclWinInt.h: Remove tclWinProcs, as it is no longer - * generic/tclWin32Dll.c: being used. + * win/tclWinInt.h: Remove tclWinProcs, as it is no longer + * win/tclWin32Dll.c: being used. 2011-10-03 Venkat Iyer -- cgit v0.12 From 58307e4ecd7de78e0ef00884da41cfec0a2a4f2f Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 5 Oct 2011 14:19:47 +0000 Subject: Added some tests. --- tests/dict.test | 66 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 66 insertions(+) diff --git a/tests/dict.test b/tests/dict.test index d80a11f..41c21e2 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1358,6 +1358,72 @@ test dict-22.11 {dict with command: no recursive structures [Bug 1786481]} -body } -cleanup { unset foo t inner } -result OK +test dict-22.12 {dict with: compiled} { + apply {{} { + set d {a 1 b 2} + list [dict with d { + set a $b + unset b + dict set d c 3 + list ok + }] $d + }} +} {ok {a 2 c 3}} +test dict-22.13 {dict with: compiled} { + apply {i { + set d($i) {a 1 b 2} + list [dict with d($i) { + set a $b + unset b + dict set d($i) c 3 + list ok + }] [array get d] + }} e +} {ok {e {a 2 c 3}}} +test dict-22.14 {dict with: compiled} { + apply {{} { + set d {a 1 b 2} + foreach x {1 2 3} { + dict with d { + incr a $b + if {$x == 2} break + } + unset a b + } + list $a $b $x $d + }} +} {5 2 2 {a 5 b 2}} +test dict-22.15 {dict with: compiled} { + apply {i { + set d($i) {a 1 b 2} + foreach x {1 2 3} { + dict with d($i) { + incr a $b + if {$x == 2} break + } + unset a b + } + list $a $b $x [array get d] + }} e +} {5 2 2 {e {a 5 b 2}}} +test dict-22.16 {dict with: compiled} { + apply {{} { + set d {p {q {a 1 b 2}}} + dict with d p q { + set a $b.$a + } + return $d + }} +} {p {q {a 2.1 b 2}}} +test dict-22.17 {dict with: compiled} { + apply {i { + set d($i) {p {q {a 1 b 2}}} + dict with d($i) p q { + set a $b.$a + } + array get d + }} e +} {e {p {q {a 2.1 b 2}}}}  # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 00dba5b765820b786738f3f44963f26a250accda Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 6 Oct 2011 19:15:25 +0000 Subject: Add the other instructions to the assembler's nous. --- generic/tclAssembly.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 2133ebe..5b32ab0 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -375,6 +375,8 @@ TalInstDesc TalInstructionTable[] = { {"dictIncrImm", ASSEM_SINT4_LVT4, INST_DICT_INCR_IMM, 1, 1}, {"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1}, + {"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 0}, + {"dictRecombineImm",ASSEM_LVT4, INST_DICT_RECOMBINE_IMM,2, 0}, {"dictSet", ASSEM_DICT_SET, INST_DICT_SET, INT_MIN,1}, {"dictUnset", ASSEM_DICT_UNSET, INST_DICT_UNSET, INT_MIN,1}, -- cgit v0.12 From 2befc6793de3b9eba7c26d5def4cdfc023a8824b Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 9 Oct 2011 14:41:06 +0000 Subject: * generic/tclCompCmds.c (TclCompileDictWithCmd): Corrected handling of qualified names, and added spacial cases for empty bodies (used when [dict with] is just used for extracting variables). --- ChangeLog | 6 + generic/tclCompCmds.c | 615 +++++++++++++++++++++++++------------------------- generic/tclCompile.h | 1 + tests/dict.test | 48 ++++ 4 files changed, 367 insertions(+), 303 deletions(-) diff --git a/ChangeLog b/ChangeLog index 74aa3a4..d0c4986 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2011-10-09 Donal K. Fellows + + * generic/tclCompCmds.c (TclCompileDictWithCmd): Corrected handling of + qualified names, and added spacial cases for empty bodies (used when + [dict with] is just used for extracting variables). + 2011-10-07 Jan Nijtmans * generic/tcl.h: Fix gcc warnings (discovered with diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 0b6b76b..69b44ed 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -83,6 +83,18 @@ static int PushVarName(Tcl_Interp *interp, mapPtr->loc[eclIndex].next[(word)]) /* + * Often want to issue one of two versions of an instruction based on whether + * the argument will fit in a single byte or not. This makes it much clearer. + */ + +#define Emit14Inst(nm,idx,envPtr) \ + if (idx <= 255) { \ + TclEmitInstInt1(nm##1,idx,envPtr); \ + } else { \ + TclEmitInstInt4(nm##4,idx,envPtr); \ + } + +/* * Flags bits used by PushVarName. */ @@ -186,18 +198,14 @@ TclCompileAppendCmd( if (isScalar) { if (localIndex < 0) { TclEmitOpcode(INST_APPEND_STK, envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr); } else { - TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr); + Emit14Inst(INST_APPEND_SCALAR, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr); } else { - TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr); + Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr); } } } else { @@ -366,16 +374,16 @@ TclCompileCatchCmd( SetLineInformation(1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { savedStackDepth = envPtr->currStackDepth; - TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); + TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, cmdTokenPtr, interp); } else { CompileTokens(envPtr, cmdTokenPtr, interp); savedStackDepth = envPtr->currStackDepth; - TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); + TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - TclEmitOpcode(INST_DUP, envPtr); - TclEmitOpcode(INST_EVAL_STK, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_EVAL_STK, envPtr); } /* Stack at this point: * nonsimple: script result @@ -399,8 +407,8 @@ TclCompileCatchCmd( envPtr->currStackDepth = savedStackDepth; ExceptionRangeTarget(envPtr, range, catchOffset); /* Stack at this point: ?script? */ - TclEmitOpcode(INST_PUSH_RESULT, envPtr); - TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); /* * Update the target of the jump after the "no errors" code. @@ -415,7 +423,7 @@ TclCompileCatchCmd( /* Push the return options if the caller wants them */ if (optsIndex != -1) { - TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); } /* @@ -423,7 +431,7 @@ TclCompileCatchCmd( */ ExceptionRangeEnds(envPtr, range); - TclEmitOpcode(INST_END_CATCH, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); /* * At this point, the top of the stack is inconveniently ordered: @@ -432,9 +440,9 @@ TclCompileCatchCmd( */ if (optsIndex != -1) { - TclEmitInstInt4(INST_REVERSE, 3, envPtr); + TclEmitInstInt4( INST_REVERSE, 3, envPtr); } else { - TclEmitInstInt4(INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); } /* @@ -442,13 +450,9 @@ TclCompileCatchCmd( */ if (resultIndex != -1) { - if (resultIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr); - } + Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); } - TclEmitOpcode(INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); /* * Stack is now ?script? ?returnOptions? returnCode. @@ -458,13 +462,9 @@ TclCompileCatchCmd( */ if (optsIndex != -1) { - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - if (optsIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); } /* @@ -473,8 +473,8 @@ TclCompileCatchCmd( */ if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode(INST_POP, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_POP, envPtr); } /* @@ -844,9 +844,9 @@ TclCompileDictForCmd( */ CompileWord(envPtr, dictTokenPtr, interp, 3); - TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); + TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); emptyTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); + TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); /* * Now we catch errors from here on so that we can finalize the search @@ -854,7 +854,7 @@ TclCompileDictForCmd( */ catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); + TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); ExceptionRangeStarts(envPtr, catchRange); /* @@ -862,10 +862,10 @@ TclCompileDictForCmd( */ bodyTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + Emit14Inst( INST_STORE_SCALAR, keyVarIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + Emit14Inst( INST_STORE_SCALAR, valueVarIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); /* * Set up the loop exception targets. @@ -880,7 +880,7 @@ TclCompileDictForCmd( SetLineInformation(4); CompileBody(envPtr, bodyTokenPtr, interp); - TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); /* * Both exception target ranges (error and loop) end here. @@ -896,11 +896,11 @@ TclCompileDictForCmd( */ ExceptionRangeTarget(envPtr, loopRange, continueOffset); - TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); + TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); /* * Now do the final cleanup for the no-error case (this is where we break @@ -911,11 +911,11 @@ TclCompileDictForCmd( */ ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); endTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP4, 0, envPtr); + TclEmitInstInt4( INST_JUMP4, 0, envPtr); /* * Error handler "finally" clause, which force-terminates the iteration @@ -923,12 +923,12 @@ TclCompileDictForCmd( */ ExceptionRangeTarget(envPtr, catchRange, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitOpcode( INST_RETURN_STK, envPtr); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitOpcode( INST_RETURN_STK, envPtr); /* * Otherwise we're done (the jump after the DICT_FIRST points here) and we @@ -940,10 +940,10 @@ TclCompileDictForCmd( jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, envPtr->codeStart + emptyTargetOffset); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); /* * Final stage of the command (normal case) is that we push an empty @@ -1075,12 +1075,12 @@ TclCompileDictUpdateCmd( for (i=0 ; icurrStackDepth++; @@ -1093,10 +1093,10 @@ TclCompileDictUpdateCmd( * the body evaluation: swap them and finish the update code. */ - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); /* * Jump around the exceptional termination code. @@ -1111,14 +1111,14 @@ TclCompileDictUpdateCmd( */ ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt4( INST_REVERSE, 3, envPtr); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitInstInt4( INST_REVERSE, 3, envPtr); - TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_RETURN_STK, envPtr); + TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_RETURN_STK, envPtr); if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", @@ -1231,7 +1231,7 @@ TclCompileDictLappendCmd( } CompileWord(envPtr, keyTokenPtr, interp, 3); CompileWord(envPtr, valueTokenPtr, interp, 4); - TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); + TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); return TCL_OK; } @@ -1246,18 +1246,16 @@ TclCompileDictWithCmd( { DefineLineInformation; /* TIP #280 */ int i, range, varNameTmp, pathTmp, keysTmp, gotPath, dictVar = -1; - Tcl_Token *dictVarTokenPtr, *tokenPtr; + int bodyIsEmpty = 1; + Tcl_Token *varTokenPtr, *tokenPtr; int savedStackDepth = envPtr->currStackDepth; JumpFixup jumpFixup; + const char *ptr, *end; /* - * There must be at least one argument after the command and we must be in - * a procedure so we can have local temporaries. + * There must be at least one argument after the command. */ - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1267,8 +1265,8 @@ TclCompileDictWithCmd( * dict with ? ...? */ - dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr); - tokenPtr = TokenAfter(dictVarTokenPtr); + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + tokenPtr = TokenAfter(varTokenPtr); for (i=3 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); } @@ -1277,31 +1275,115 @@ TclCompileDictWithCmd( } /* - * Allocate local (unnamed, untraced) working variables. + * Test if the last word is an empty script; if so, we can compile it in + * all cases, but if it is non-empty we need local variable table entries + * to hold the temporary variables (used to keep stack usage simple). + */ + + for (ptr=tokenPtr[1].start,end=ptr+tokenPtr[1].size ; ptr!=end ; ptr++) { + if (*ptr!=' ' && *ptr!='\t' && *ptr!='\n' && *ptr!='\r') { + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + bodyIsEmpty = 0; + break; + } + } + + /* + * Determine if we're manipulating a dict in a simple local variable. */ gotPath = (parsePtr->numWords > 3); - if (dictVarTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - const char *ptr = dictVarTokenPtr[1].start; - const char *end = ptr + dictVarTokenPtr[1].size; - int notArray = 1; + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD && + TclIsLocalScalar(varTokenPtr[1].start, varTokenPtr[1].size)) { + dictVar = TclFindCompiledLocal(varTokenPtr[1].start, + varTokenPtr[1].size, 1, envPtr); + } - /* - * A conservative check for if we're working with an array since we - * have a reasonable fallback if things are tricky. - */ + /* + * Special case: an empty body means we definitely have no need to issue + * try-finally style code or to allocate local variable table entries for + * storing temporaries. Still need to do both INST_DICT_EXPAND and + * INST_DICT_RECOMBINE_* though, because we can't determine if we're free + * of traces. + */ - for (; ptr= 0) { + if (gotPath) { + /* + * Case: Path into dict in LVT with empty body. + */ + + tokenPtr = TokenAfter(varTokenPtr); + for (i=2 ; inumWords-1 ; i++) { + CompileWord(envPtr, tokenPtr, interp, i-1); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); + Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitOpcode( INST_DICT_EXPAND, envPtr); + TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); + PushLiteral(envPtr, "", 0); + } else { + /* + * Case: Direct dict in LVT with empty body. + */ + + PushLiteral(envPtr, "", 0); + Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); + PushLiteral(envPtr, "", 0); + TclEmitOpcode( INST_DICT_EXPAND, envPtr); + TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); + PushLiteral(envPtr, "", 0); + } + } else { + if (gotPath) { + /* + * Case: Path into dict in non-simple var with empty body. + */ + + tokenPtr = varTokenPtr; + for (i=1 ; inumWords-1 ; i++) { + CompileWord(envPtr, tokenPtr, interp, i-1); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitOpcode( INST_LOAD_STK, envPtr); + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitOpcode( INST_DICT_EXPAND, envPtr); + TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); + PushLiteral(envPtr, "", 0); + } else { + /* + * Case: Direct dict in non-simple var with empty body. + */ + + CompileWord(envPtr, varTokenPtr, interp, 0); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LOAD_STK, envPtr); + PushLiteral(envPtr, "", 0); + TclEmitOpcode( INST_DICT_EXPAND, envPtr); + PushLiteral(envPtr, "", 0); + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); + PushLiteral(envPtr, "", 0); } } - if (notArray) { - dictVar = TclFindCompiledLocal(dictVarTokenPtr[1].start, - dictVarTokenPtr[1].size, 1, envPtr); - } + return TCL_OK; } + + /* + * OK, we have a non-trivial body. This means that the focus is on + * generating a try-finally structure where the INST_DICT_RECOMBINE_* goes + * in the 'finally' clause. + * + * Start by allocating local (unnamed, untraced) working variables. + */ + if (dictVar == -1) { varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); } else { @@ -1318,51 +1400,32 @@ TclCompileDictWithCmd( * Issue instructions. First, the part to expand the dictionary. */ - tokenPtr = dictVarTokenPtr; if (varNameTmp > -1) { - CompileWord(envPtr, tokenPtr, interp, 0); - if (varNameTmp <= 255) { - TclEmitInstInt1( INST_STORE_SCALAR1, varNameTmp, envPtr); - } else { - TclEmitInstInt4( INST_STORE_SCALAR4, varNameTmp, envPtr); - } + CompileWord(envPtr, varTokenPtr, interp, 0); + Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); } - tokenPtr = TokenAfter(tokenPtr); + tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { for (i=2 ; inumWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i-1); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); - if (pathTmp <= 255) { - TclEmitInstInt1( INST_STORE_SCALAR1, pathTmp, envPtr); - } else { - TclEmitInstInt4( INST_STORE_SCALAR4, pathTmp, envPtr); - } + Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr); TclEmitOpcode( INST_POP, envPtr); } if (dictVar == -1) { TclEmitOpcode( INST_LOAD_STK, envPtr); - } else if (dictVar <= 255) { - TclEmitInstInt1( INST_LOAD_SCALAR1, dictVar, envPtr); } else { - TclEmitInstInt4( INST_LOAD_SCALAR4, dictVar, envPtr); + Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); } if (gotPath) { - if (pathTmp <= 255) { - TclEmitInstInt1( INST_LOAD_SCALAR1, pathTmp, envPtr); - } else { - TclEmitInstInt4( INST_LOAD_SCALAR4, pathTmp, envPtr); - } + Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); } else { PushLiteral(envPtr, "", 0); } TclEmitOpcode( INST_DICT_EXPAND, envPtr); - if (keysTmp <= 255) { - TclEmitInstInt1( INST_STORE_SCALAR1, keysTmp, envPtr); - } else { - TclEmitInstInt4( INST_STORE_SCALAR4, keysTmp, envPtr); - } + Emit14Inst( INST_STORE_SCALAR, keysTmp, envPtr); TclEmitOpcode( INST_POP, envPtr); /* @@ -1384,25 +1447,15 @@ TclCompileDictWithCmd( */ TclEmitOpcode( INST_END_CATCH, envPtr); - if (varNameTmp > -1 && varNameTmp <= 255) { - TclEmitInstInt1( INST_LOAD_SCALAR1, varNameTmp, envPtr); - } else if (varNameTmp > -1) { - TclEmitInstInt4( INST_LOAD_SCALAR4, varNameTmp, envPtr); + if (varNameTmp > -1) { + Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); } if (gotPath) { - if (pathTmp <= 255) { - TclEmitInstInt1( INST_LOAD_SCALAR1, pathTmp, envPtr); - } else { - TclEmitInstInt4( INST_LOAD_SCALAR4, pathTmp, envPtr); - } + Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); } else { PushLiteral(envPtr, "", 0); } - if (keysTmp <= 255) { - TclEmitInstInt1( INST_LOAD_SCALAR1, keysTmp, envPtr); - } else { - TclEmitInstInt4( INST_LOAD_SCALAR4, keysTmp, envPtr); - } + Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); if (dictVar == -1) { TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); } else { @@ -1418,25 +1471,15 @@ TclCompileDictWithCmd( TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_END_CATCH, envPtr); - if (varNameTmp > -1 && varNameTmp <= 255) { - TclEmitInstInt1( INST_LOAD_SCALAR1, varNameTmp, envPtr); - } else if (varNameTmp > -1) { - TclEmitInstInt4( INST_LOAD_SCALAR4, varNameTmp, envPtr); + if (varNameTmp > -1) { + Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); } if (parsePtr->numWords > 3) { - if (pathTmp <= 255) { - TclEmitInstInt1( INST_LOAD_SCALAR1, pathTmp, envPtr); - } else { - TclEmitInstInt4( INST_LOAD_SCALAR4, pathTmp, envPtr); - } + Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); } else { PushLiteral(envPtr, "", 0); } - if (keysTmp <= 255) { - TclEmitInstInt1( INST_LOAD_SCALAR1, keysTmp, envPtr); - } else { - TclEmitInstInt4( INST_LOAD_SCALAR4, keysTmp, envPtr); - } + Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); if (dictVar == -1) { TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); } else { @@ -1990,12 +2033,8 @@ TclCompileForeachCmd( SetLineInformation(i); CompileTokens(envPtr, tokenPtr, interp); tempVar = (firstValueTemp + loopIndex); - if (tempVar <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); + Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); + TclEmitOpcode( INST_POP, envPtr); loopIndex++; } } @@ -2004,7 +2043,7 @@ TclCompileForeachCmd( * Initialize the temporary var that holds the count of loop iterations. */ - TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); + TclEmitInstInt4( INST_FOREACH_START4, infoIndex, envPtr); /* * Top of loop code: assign each loop variable and check whether @@ -2012,7 +2051,7 @@ TclCompileForeachCmd( */ ExceptionRangeTarget(envPtr, range, continueOffset); - TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + TclEmitInstInt4( INST_FOREACH_STEP4, infoIndex, envPtr); TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); /* @@ -2024,7 +2063,7 @@ TclCompileForeachCmd( CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; - TclEmitOpcode(INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); /* * Jump back to the test at the top of the loop. Generate a 4 byte jump if @@ -2299,14 +2338,14 @@ TclCompileGlobalCmd( } CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr); + TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); } /* * Pop the namespace, and set the result to empty */ - TclEmitOpcode(INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); PushLiteral(envPtr, "", 0); return TCL_OK; } @@ -2705,43 +2744,41 @@ TclCompileIncrCmd( * Emit the instruction to increment the variable. */ - if (simpleVarName) { - if (isScalar) { - if (localIndex >= 0) { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); - } else { - TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); - } + if (!simpleVarName) { + if (haveImmValue) { + TclEmitInstInt1( INST_INCR_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode( INST_INCR_STK, envPtr); + } + } else if (isScalar) { /* Simple scalar variable. */ + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); + TclEmitInt1(immValue, envPtr); } else { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr); - } + TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); } } else { - if (localIndex >= 0) { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); - } else { - TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); - } + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr); } else { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr); - } + TclEmitOpcode( INST_INCR_SCALAR_STK, envPtr); } } - } else { /* Non-simple variable name. */ - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr); + } else { /* Simple array variable. */ + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); + } } else { - TclEmitOpcode(INST_INCR_STK, envPtr); + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode( INST_INCR_ARRAY_STK, envPtr); + } } } @@ -2799,22 +2836,20 @@ TclCompileInfoExistsCmd( * Emit instruction to check the variable for existence. */ - if (simpleVarName) { - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode(INST_EXIST_STK, envPtr); - } else { - TclEmitInstInt4(INST_EXIST_SCALAR, localIndex, envPtr); - } + if (!simpleVarName) { + TclEmitOpcode( INST_EXIST_STK, envPtr); + } else if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode( INST_EXIST_STK, envPtr); } else { - if (localIndex < 0) { - TclEmitOpcode(INST_EXIST_ARRAY_STK, envPtr); - } else { - TclEmitInstInt4(INST_EXIST_ARRAY, localIndex, envPtr); - } + TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); } } else { - TclEmitOpcode(INST_EXIST_STK, envPtr); + if (localIndex < 0) { + TclEmitOpcode( INST_EXIST_ARRAY_STK, envPtr); + } else { + TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr); + } } return TCL_OK; @@ -2904,26 +2939,20 @@ TclCompileLappendCmd( * LOAD/STORE instructions. */ - if (simpleVarName) { - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode(INST_LAPPEND_STK, envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr); - } else { - TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr); - } + if (!simpleVarName) { + TclEmitOpcode( INST_LAPPEND_STK, envPtr); + } else if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode( INST_LAPPEND_STK, envPtr); } else { - if (localIndex < 0) { - TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr); - } else { - TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr); - } + Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr); } } else { - TclEmitOpcode(INST_LAPPEND_STK, envPtr); + if (localIndex < 0) { + TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr); + } else { + Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr); + } } return TCL_OK; @@ -2996,50 +3025,44 @@ TclCompileLassignCmd( * the stack and assign it to the variable. */ - if (simpleVarName) { - if (isScalar) { - if (localIndex >= 0) { - TclEmitOpcode(INST_DUP, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - if (localIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1,localIndex,envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4,localIndex,envPtr); - } - } else { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr); - } + if (!simpleVarName) { + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode( INST_STORE_STK, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } else if (isScalar) { + if (localIndex >= 0) { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); } else { - if (localIndex >= 0) { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - if (localIndex <= 255) { - TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr); - } - } else { - TclEmitInstInt4(INST_OVER, 2, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr); - } + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr); + TclEmitOpcode( INST_POP, envPtr); } } else { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode(INST_STORE_STK, envPtr); + if (localIndex >= 0) { + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } else { + TclEmitInstInt4(INST_OVER, 2, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } } - TclEmitOpcode(INST_POP, envPtr); } /* * Generate code to leave the rest of the list on the stack. */ - TclEmitInstInt4(INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4(-2, envPtr); /* -2 == "end" */ + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); + TclEmitInt4( -2 /* == "end" */, envPtr); return TCL_OK; } @@ -3107,7 +3130,7 @@ TclCompileLindexCmd( */ CompileWord(envPtr, valTokenPtr, interp, 1); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); return TCL_OK; } @@ -3133,9 +3156,9 @@ TclCompileLindexCmd( */ if (numWords == 3) { - TclEmitOpcode(INST_LIST_INDEX, envPtr); + TclEmitOpcode( INST_LIST_INDEX, envPtr); } else { - TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr); + TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr); } return TCL_OK; @@ -3169,6 +3192,8 @@ TclCompileListCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ + Tcl_Token *valueTokenPtr; + int i, numWords; /* * If we're not in a procedure, don't compile. @@ -3189,17 +3214,13 @@ TclCompileListCmd( * Push the all values onto the stack. */ - Tcl_Token *valueTokenPtr; - int i, numWords; - numWords = parsePtr->numWords; - valueTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i = 1; i < numWords; i++) { CompileWord(envPtr, valueTokenPtr, interp, i); valueTokenPtr = TokenAfter(valueTokenPtr); } - TclEmitInstInt4(INST_LIST, numWords - 1, envPtr); + TclEmitInstInt4( INST_LIST, numWords - 1, envPtr); } return TCL_OK; @@ -3241,7 +3262,7 @@ TclCompileLlengthCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitOpcode(INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); return TCL_OK; }  @@ -3347,7 +3368,7 @@ TclCompileLsetCmd( } else { tempDepth = parsePtr->numWords - 1; } - TclEmitInstInt4(INST_OVER, tempDepth, envPtr); + TclEmitInstInt4( INST_OVER, tempDepth, envPtr); } /* @@ -3360,7 +3381,7 @@ TclCompileLsetCmd( } else { tempDepth = parsePtr->numWords - 2; } - TclEmitInstInt4(INST_OVER, tempDepth, envPtr); + TclEmitInstInt4( INST_OVER, tempDepth, envPtr); } /* @@ -3368,22 +3389,18 @@ TclCompileLsetCmd( */ if (!simpleVarName) { - TclEmitOpcode(INST_LOAD_STK, envPtr); + TclEmitOpcode( INST_LOAD_STK, envPtr); } else if (isScalar) { if (localIndex < 0) { - TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); - } else if (localIndex < 0x100) { - TclEmitInstInt1(INST_LOAD_SCALAR1, localIndex, envPtr); + TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr); } else { - TclEmitInstInt4(INST_LOAD_SCALAR4, localIndex, envPtr); + Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); } } else { if (localIndex < 0) { - TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); - } else if (localIndex < 0x100) { - TclEmitInstInt1(INST_LOAD_ARRAY1, localIndex, envPtr); + TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr); } else { - TclEmitInstInt4(INST_LOAD_ARRAY4, localIndex, envPtr); + Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr); } } @@ -3392,9 +3409,9 @@ TclCompileLsetCmd( */ if (parsePtr->numWords == 4) { - TclEmitOpcode(INST_LSET_LIST, envPtr); + TclEmitOpcode( INST_LSET_LIST, envPtr); } else { - TclEmitInstInt4(INST_LSET_FLAT, parsePtr->numWords-1, envPtr); + TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr); } /* @@ -3402,22 +3419,18 @@ TclCompileLsetCmd( */ if (!simpleVarName) { - TclEmitOpcode(INST_STORE_STK, envPtr); + TclEmitOpcode( INST_STORE_STK, envPtr); } else if (isScalar) { if (localIndex < 0) { - TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr); - } else if (localIndex < 0x100) { - TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); + TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr); } else { - TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); } } else { if (localIndex < 0) { - TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr); - } else if (localIndex < 0x100) { - TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr); + TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); } else { - TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr); + Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); } } @@ -3495,14 +3508,14 @@ TclCompileNamespaceUpvarCmd( if ((localIndex < 0) || !isScalar) { return TCL_ERROR; } - TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr); + TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); } /* * Pop the namespace, and set the result to empty */ - TclEmitOpcode(INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); PushLiteral(envPtr, "", 0); return TCL_OK; } @@ -3653,9 +3666,9 @@ TclCompileRegexpCmd( if (simple) { if (exact && !nocase) { - TclEmitOpcode(INST_STR_EQ, envPtr); + TclEmitOpcode( INST_STR_EQ, envPtr); } else { - TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); + TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr); } } else { /* @@ -3666,7 +3679,7 @@ TclCompileRegexpCmd( int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); - TclEmitInstInt1(INST_REGEXP, cflags, envPtr); + TclEmitInstInt1( INST_REGEXP, cflags, envPtr); } return TCL_OK; @@ -3864,7 +3877,7 @@ TclCompileSyntaxError( TclErrorStackResetIf(interp, bytes, numBytes); TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, - TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); + TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); }  /* @@ -3964,14 +3977,14 @@ TclCompileUpvarCmd( if ((localIndex < 0) || !isScalar) { return TCL_ERROR; } - TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); + TclEmitInstInt4( INST_UPVAR, localIndex, envPtr); } /* * Pop the frame index, and set the result to empty */ - TclEmitOpcode(INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); PushLiteral(envPtr, "", 0); return TCL_OK; } @@ -4036,7 +4049,7 @@ TclCompileVariableCmd( } CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr); + TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); if (i != numWords) { /* @@ -4044,12 +4057,8 @@ TclCompileVariableCmd( */ CompileWord(envPtr, valueTokenPtr, interp, 1); - if (localIndex < 0x100) { - TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); + Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); } } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 8e7f0d0..e80a710 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -676,6 +676,7 @@ typedef struct ByteCode { #define INST_UNSET_ARRAY_STK 136 #define INST_UNSET_STK 137 +/* For [dict with] compilation */ #define INST_DICT_EXPAND 138 #define INST_DICT_RECOMBINE_STK 139 #define INST_DICT_RECOMBINE_IMM 140 diff --git a/tests/dict.test b/tests/dict.test index 41c21e2..87e5107 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1424,6 +1424,54 @@ test dict-22.17 {dict with: compiled} { array get d }} e } {e {p {q {a 2.1 b 2}}}} +test dict-22.18 {dict with: compiled} { + set ::d {a 1 b 2} + apply {{} { + dict with ::d { + set a $b.$a + } + return $::d + }} +} {a 2.1 b 2} +test dict-22.19 {dict with: compiled} { + set ::d {p {q {r {a 1 b 2}}}} + apply {{} { + dict with ::d p q r { + set a $b.$a + } + return $::d + }} +} {p {q {r {a 2.1 b 2}}}} +test dict-22.20 {dict with: compiled} { + apply {d { + dict with d { + } + return $a,$b + }} {a 1 b 2} +} 1,2 +test dict-22.21 {dict with: compiled} { + apply {d { + dict with d p q { + } + return $a,$b + }} {p {q {a 1 b 2}}} +} 1,2 +test dict-22.22 {dict with: compiled} { + set ::d {a 1 b 2} + apply {{} { + dict with ::d { + } + return $a,$b + }} +} 1,2 +test dict-22.23 {dict with: compiled} { + set ::d {p {q {a 1 b 2}}} + apply {{} { + dict with ::d p q { + } + return $a,$b + }} +} 1,2  # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 6a82abf5e33b58989732a0858f89347235fabb42 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Oct 2011 18:02:27 +0000 Subject: 3423069 silence compiler warnings. --- generic/tclTest.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 30c95c8..03afad9 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -75,7 +75,7 @@ typedef struct TestAsyncHandler { /* Next is list of handlers. */ } TestAsyncHandler; -TCL_DECLARE_MUTEX(asyncTestMutex); +TCL_DECLARE_MUTEX(asyncTestMutex) static TestAsyncHandler *firstHandler = NULL; @@ -7109,7 +7109,8 @@ TestparseargsCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Arguments. */ { - int count = objc, foo = 0; + static int foo = 0; + int count = objc; Tcl_Obj **remObjv, *result[3]; Tcl_ArgvInfo argTable[] = { {TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL}, -- cgit v0.12 From c0473e256855d4fd008395dd43e4cad66af222d5 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Oct 2011 18:10:20 +0000 Subject: 3423059 silence compiler warning --- generic/tclNamesp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 9a2152a..73bc644 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -170,7 +170,7 @@ static const EnsembleImplMap defaultNamespaceMap[] = { {"export", NamespaceExportCmd, NULL, NULL, NULL, 0}, {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0}, {"import", NamespaceImportCmd, NULL, NULL, NULL, 0}, - {"inscope", NamespaceInscopeCmd, NULL, NULL, NRNamespaceInscopeCmd, 0}, + {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0}, {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0}, {"path", NamespacePathCmd, NULL, NULL, NULL, 0}, -- cgit v0.12 From 18dff8dc18b2826f2160ce237232b1c73a08be93 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Oct 2011 18:19:26 +0000 Subject: Correct botch. --- generic/tclTest.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclTest.c b/generic/tclTest.c index 03afad9..cbebacd 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7117,6 +7117,7 @@ TestparseargsCmd( TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END }; + foo = 0; if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) { return TCL_ERROR; } -- cgit v0.12 From 971594ecc4d41c4f217aa38a911f6858e81ca5d0 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 15 Oct 2011 15:57:08 +0000 Subject: Commit of patch relating to interp resolvers --- generic/tclBasic.c | 46 +++++++++++++ generic/tclCompile.h | 2 + generic/tclLiteral.c | 40 +++++++++++ generic/tclTest.c | 184 +++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 272 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 9758449..d10e8e6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1922,6 +1922,17 @@ Tcl_ExposeCommand( } /* + * Command resolvers (per-interp, per-namespace) might have resolved to a + * command for the given namespace scope with this command not being + * registered with the namespace's command table. During BC compilation, + * the so-resolved command turns into a CmdName literal. Without + * invalidating a possible CmdName literal here explicitly, such literals + * keep being reused while pointing to overhauled commands. + */ + + TclInvalidateCmdLiteral(interp, cmdName, nsPtr); + + /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we need * the info will be soon enough. @@ -2069,6 +2080,18 @@ Tcl_CreateCommand( } } else { /* + * Command resolvers (per-interp, per-namespace) might have resolved + * to a command for the given namespace scope with this command not + * being registered with the namespace's command table. During BC + * compilation, the so-resolved command turns into a CmdName literal. + * Without invalidating a possible CmdName literal here explicitly, + * such literals keep being reused while pointing to overhauled + * commands. + */ + + TclInvalidateCmdLiteral(interp, tail, nsPtr); + + /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we * need the info will be soon enough. @@ -2242,6 +2265,18 @@ Tcl_CreateObjCommand( } } else { /* + * Command resolvers (per-interp, per-namespace) might have resolved + * to a command for the given namespace scope with this command not + * being registered with the namespace's command table. During BC + * compilation, the so-resolved command turns into a CmdName literal. + * Without invalidating a possible CmdName literal here explicitly, + * such literals keep being reused while pointing to overhauled + * commands. + */ + + TclInvalidateCmdLiteral(interp, tail, nsPtr); + + /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we * need the info will be soon enough. @@ -2551,6 +2586,17 @@ TclRenameCommand( TclInvalidateNsCmdLookup(cmdPtr->nsPtr); /* + * Command resolvers (per-interp, per-namespace) might have resolved to a + * command for the given namespace scope with this command not being + * registered with the namespace's command table. During BC compilation, + * the so-resolved command turns into a CmdName literal. Without + * invalidating a possible CmdName literal here explicitly, such literals + * keep being reused while pointing to overhauled commands. + */ + + TclInvalidateCmdLiteral(interp, newTail, cmdPtr->nsPtr); + + /* * Script for rename traces can delete the command "oldName". Therefore * increment the reference count for cmdPtr so that it's Command structure * is freed only towards the end of this function by calling diff --git a/generic/tclCompile.h b/generic/tclCompile.h index e80a710..58663fd 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -960,6 +960,8 @@ MODULE_SCOPE void TclRegisterAuxDataType(const AuxDataType *typePtr); MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, char *bytes, int length, int flags); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); +MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, + const char *name, Namespace *nsPtr); MODULE_SCOPE int TclSingleOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 3a9f8e1..441ea91 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -936,6 +936,46 @@ RebuildLiteralTable( } }  +/* + *---------------------------------------------------------------------- + * + * TclInvalidateCmdLiteral -- + * + * Invalidate a command literal entry, if present in the literal hash + * tables, by resetting its internal representation. This invalidation + * leaves it in the literal tables and in existing literal arrays. As a + * result, existing references continue to work but we force a fresh + * command look-up upon the next use (see, in particular, + * TclSetCmdNameObj()). + * + * Results: + * None. + * + * Side effects: + * Resets the internal representation of the CmdName Tcl_Obj + * using TclFreeIntRep(). + * + *---------------------------------------------------------------------- + */ + +void +TclInvalidateCmdLiteral( + Tcl_Interp *interp, /* Interpreter for which to invalidate a + * command literal. */ + const char *name, /* Points to the start of the cmd literal + * name. */ + Namespace *nsPtr) /* The namespace for which to lookup and + * invalidate a cmd literal. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name, + strlen(name), -1, NULL, nsPtr, 0, NULL); + + if (literalObjPtr != NULL && literalObjPtr->typePtr == &tclCmdNameType) { + TclFreeIntRep(literalObjPtr); + } +} + #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- diff --git a/generic/tclTest.c b/generic/tclTest.c index cbebacd..299ba0e 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -411,6 +411,9 @@ static int TestHashSystemHashCmd(ClientData clientData, static int TestNRELevels(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TestInterpResolversCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static const Tcl_Filesystem testReportingFilesystem = { "reporting", @@ -675,6 +678,8 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, NULL, NULL); + Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolversCmd, + NULL, NULL); if (TclObjTest_Init(interp) != TCL_OK) { return TCL_ERROR; @@ -7129,6 +7134,185 @@ TestparseargsCmd( return TCL_OK; }  +static int +InterpCmdResolver( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *context, + int flags, + Tcl_Command *rPtr) +{ + Tcl_Command sourceCmdPtr; + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ? + varFramePtr->procPtr : NULL; + Namespace *ns2NsPtr; + + ns2NsPtr = Tcl_FindNamespace(interp, "::ns2", NULL, 0); + + if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr + || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) { + const char *callingCmdName = + Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr); + + if ((*callingCmdName == 'x') && (*(callingCmdName + 1) == '\0') + && (*name == 'z') && (*(name + 1) == '\0')) { + sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL, + TCL_GLOBAL_ONLY); + if (sourceCmdPtr != NULL) { + *rPtr = sourceCmdPtr; + return TCL_OK; + } + } + } + return TCL_CONTINUE; +} + +static int +InterpVarResolver( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *context, + int flags, + Tcl_Var *rPtr) +{ + return TCL_CONTINUE; +} + +typedef struct MyResolvedVarInfo { + Tcl_ResolvedVarInfo vInfo; /* This must be the first element. */ + Tcl_Var var; + Tcl_Obj *nameObj; +} MyResolvedVarInfo; + +static void +HashVarFree( + Tcl_Var var) +{ + if (VarHashRefCount(var) < 2) { + ckfree((char *) var); + } else { + VarHashRefCount(var)--; + } +} + +static void +MyCompiledVarFree( + Tcl_ResolvedVarInfo *vInfoPtr) +{ + MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vInfoPtr; + + Tcl_DecrRefCount(resVarInfo->nameObj); + if (resVarInfo->var) { + HashVarFree(resVarInfo->var); + } + ckfree((char *)vInfoPtr); +} + +#define TclVarHashGetValue(hPtr) \ + ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) + +static Tcl_Var +MyCompiledVarFetch( + Tcl_Interp *interp, + Tcl_ResolvedVarInfo *vinfoPtr) +{ + MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vinfoPtr; + Tcl_Var var = resVarInfo->var; + Namespace *nsPtr; + int isNewVar; + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + + if (var && !(((Var *)var)->flags & VAR_DEAD_HASH)) { + /* + * The cached variable is valid, return it. + */ + + return var; + } + + if (var) { + /* + * The variable is not valid anymore. Clean it up. + */ + + HashVarFree(var); + } + + nsPtr = iPtr->globalNsPtr; + hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &nsPtr->varTable, + (char *) resVarInfo->nameObj, &isNewVar); + if (hPtr) { + var = (Tcl_Var) TclVarHashGetValue(hPtr); + } else { + var = NULL; + } + resVarInfo->var = var; + + /* + * Increment the reference counter to avoid ckfree() of the variable in + * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree(); + */ + + VarHashRefCount(var); + return var; +} + +static int +InterpCompiledVarResolver( + Tcl_Interp *interp, + const char *name, + int length, + Tcl_Namespace *context, + Tcl_ResolvedVarInfo **rPtr) +{ + if (*name == 'T') { + MyResolvedVarInfo *resVarInfo = ckalloc(sizeof(MyResolvedVarInfo)); + + resVarInfo->vInfo.fetchProc = MyCompiledVarFetch; + resVarInfo->vInfo.deleteProc = MyCompiledVarFree; + resVarInfo->var = NULL; + resVarInfo->nameObj = Tcl_NewStringObj(name, -1); + Tcl_IncrRefCount(resVarInfo->nameObj); + *rPtr = (Tcl_ResolvedVarInfo *) resVarInfo; + return TCL_OK; + } + return TCL_CONTINUE; +} + +static int +TestInterpResolversCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + const char *option; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "up|down"); + return TCL_ERROR; + } + option = TclGetString(objv[1]); + if (*option == 'u' && strcmp(option, "up") == 0) { + Tcl_AddInterpResolvers(interp, "interpResolver", InterpCmdResolver, + InterpVarResolver, InterpCompiledVarResolver); + } else if (*option == 'd' && strcmp(option, "down") == 0) { + if (Tcl_RemoveInterpResolvers(interp, "interpResolver") == 0) { + Tcl_AppendResult(interp, "could not remove the resolver scheme", + NULL); + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "bad option \"", option, + "\": must be 'up' or 'down'", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + /* * Local Variables: * mode: c -- cgit v0.12 From c340a3859f1dfc7b1e77c4d0db35a94d3463f60d Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 15 Oct 2011 16:48:16 +0000 Subject: And the failing test file too... --- tests/resolver.test | 200 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 200 insertions(+) create mode 100644 tests/resolver.test diff --git a/tests/resolver.test b/tests/resolver.test new file mode 100644 index 0000000..bb9f59d --- /dev/null +++ b/tests/resolver.test @@ -0,0 +1,200 @@ +# This test collection covers some unwanted interactions between command +# literal sharing and the use of command resolvers (per-interp) which cause +# command literals to be re-used with their command references being invalid +# in the reusing context. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 2011 Gustaf Neumann +# Copyright (c) 2011 Stefan Sobernig +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require tcltest 2 +if {"::tcltest" in [namespace children]} { + namespace import -force ::tcltest::* +} + +testConstraint testinterpresolver [llength [info commands testinterpresolver]] + +test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup { + testinterpresolver up + namespace eval ::ns1 { + proc z {} { return Z } + namespace export z + } + proc ::y {} { return Y } + proc ::x {} { + z + } +} -constraints testinterpresolver -body { + # 1) Have the proc body compiled: During compilation or, alternatively, + # the first evaluation of the compiled body, the InterpCmdResolver (see + # tclTest.c) maps the cmd token "z" to "::y"; this mapping is saved in the + # resulting CmdName Tcl_Obj with the print string "z". The CmdName Tcl_Obj + # is turned into a command literal shared for a given (here: the global) + # namespace. + set r0 [x]; # --> The result of [x] is "Y" + # 2) After having requested cmd resolution above, we can now use the + # globally shared CmdName Tcl_Obj "z", now bound to cmd ::y. This is + # certainly questionable, but defensible + set r1 [z]; # --> The result of [z] is "Y" + # 3) We import from the namespace ns1 another z. [namespace import] takes + # care "shadowed" cmd references, however, till now cmd literals have not + # been touched. This is, however, necessary since the BC compiler (used in + # the [namespace eval]) seems to be eager to reuse CmdName Tcl_Objs as cmd + # literals for a given NS scope. We expect, that r2 is "Z", the result of + # the namespace imported cmd. + namespace eval :: { + namespace import ::ns1::z + set r2 [z] + } + list $r0 $r1 $::r2 +} -cleanup { + testinterpresolver down + rename ::x "" + rename ::y "" + namespace delete ::ns1 +} -result {Y Y Z} +test resolver-1.2 {cmdNameObj sharing vs. cmd resolver: proc creation} -setup { + testinterpresolver up + proc ::y {} { return Y } + proc ::x {} { + z + } +} -constraints testinterpresolver -body { + set r0 [x] + set r1 [z] + proc ::foo {} { + proc ::z {} { return Z } + return [z] + } + list $r0 $r1 [::foo] +} -cleanup { + testinterpresolver down + rename ::x "" + rename ::y "" + rename ::foo "" + rename ::z "" +} -result {Y Y Z} +test resolver-1.3 {cmdNameObj sharing vs. cmd resolver: rename} -setup { + testinterpresolver up + proc ::Z {} { return Z } + proc ::y {} { return Y } + proc ::x {} { + z + } +} -constraints testinterpresolver -body { + set r0 [x] + set r1 [z] + namespace eval :: { + rename ::Z ::z + set r2 [z] + } + list $r0 $r1 $r2 +} -cleanup { + testinterpresolver down + rename ::x "" + rename ::y "" + rename ::z "" +} -result {Y Y Z} +test resolver-1.4 {cmdNameObj sharing vs. cmd resolver: interp expose} -setup { + testinterpresolver up + proc ::Z {} { return Z } + interp hide {} Z + proc ::y {} { return Y } + proc ::x {} { + z + } +} -constraints testinterpresolver -body { + set r0 [x] + set r1 [z] + interp expose {} Z z + namespace eval :: { + set r2 [z] + } + list $r0 $r1 $r2 +} -cleanup { + testinterpresolver down + rename ::x "" + rename ::y "" + rename ::z "" +} -result {Y Y Z} +test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -setup { + testinterpresolver up + namespace eval ::ns1 { + proc z {} { return Z } + namespace export z + } + proc ::y {} { return Y } + namespace eval ::ns2 { + proc x {} { + z + } + } +} -constraints testinterpresolver -body { + set r0 [namespace eval ::ns2 {x}] + set r1 [namespace eval ::ns2 {z}] + namespace eval ::ns2 { + namespace import ::ns1::z + set r2 [z] + } + list $r0 $r1 $r2 +} -cleanup { + testinterpresolver down + namespace delete ::ns2 + namespace delete ::ns1 +} -result {Y Y Z} +test resolver-1.6 {cmdNameObj sharing vs. cmd resolver: interp alias} -setup { + testinterpresolver up + proc ::Z {} { return Z } + proc ::y {} { return Y } + proc ::x {} { + z + } +} -constraints testinterpresolver -body { + set r0 [x] + set r1 [z] + namespace eval :: { + interp alias {} ::z {} ::Z + set r2 [z] + } + list $r0 $r1 $r2 +} -cleanup { + testinterpresolver down + rename ::x "" + rename ::y "" + rename ::Z "" +} -result {Y Y Z} + +test resolver-2.1 {compiled var resolver: Bug #3383616} -setup { + testinterpresolver up + # The compiled var resolver fetches just variables starting with a capital + # "T" and stores some test information in the resolver-specific resolver + # var info. + proc ::x {} { + set T1 100 + return $T1 + } +} -constraints testinterpresolver -body { + # Call "x" the first time, causing a byte code compilation of the body. + # During the compilation the compiled var resolver, the resolve-specific + # var info is allocated, during the execution of the body, the variable is + # fetched and cached. + x; + # During later calls, the cached variable is reused. + x + # When the proc is freed, the resolver-specific resolver var info is + # freed. This did not happen before fix #3383616. + rename ::x "" +} -cleanup { + testinterpresolver down +} -result {} + +cleanupTests +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: -- cgit v0.12 From ab5335a4c951b478bbedd4f5561b8a314da5b074 Mon Sep 17 00:00:00 2001 From: max Date: Tue, 18 Oct 2011 13:08:55 +0000 Subject: Don't cache the system timezone when it was derived from TCL_TZ or TZ. --- ChangeLog | 7 +++++++ library/clock.tcl | 27 ++++++++++++++++----------- tests/clock.test | 33 +++++++++++++++++++++++++++++++++ 3 files changed, 56 insertions(+), 11 deletions(-) diff --git a/ChangeLog b/ChangeLog index d219048..5cf8570 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2011-10-18 Reinhard Max + + * library/clock.tcl (::tcl::clock::GetSystemTimeZone): Cache the + time zone only if it was detected by one of the expensive + methods. Otherwise after unsetting TCL_TZ or TZ the previous value + will still be used. + 2011-10-15 Venkat Iyer * library/tzdata/America/Sitka : Update to Olson's tzdata2011l * library/tzdata/Pacific/Fiji diff --git a/library/clock.tcl b/library/clock.tcl index b6ff359..2a4c7bd 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -3012,18 +3012,23 @@ proc ::tcl::clock::GetSystemTimeZone {} { set timezone $result } elseif {[set result [getenv TZ]] ne {}} { set timezone $result - } elseif { [info exists CachedSystemTimeZone] } { - set timezone $CachedSystemTimeZone - } elseif { $::tcl_platform(platform) eq {windows} } { - set timezone [GuessWindowsTimeZone] - } elseif { [file exists /etc/localtime] - && ![catch {ReadZoneinfoFile \ - Tcl/Localtime /etc/localtime}] } { - set timezone :Tcl/Localtime - } else { - set timezone :localtime } - set CachedSystemTimeZone $timezone + if {![info exists timezone]} { + # Cache the time zone only if it was detected by one of the + # expensive methods. + if { [info exists CachedSystemTimeZone] } { + set timezone $CachedSystemTimeZone + } elseif { $::tcl_platform(platform) eq {windows} } { + set timezone [GuessWindowsTimeZone] + } elseif { [file exists /etc/localtime] + && ![catch {ReadZoneinfoFile \ + Tcl/Localtime /etc/localtime}] } { + set timezone :Tcl/Localtime + } else { + set timezone :localtime + } + set CachedSystemTimeZone $timezone + } if { ![dict exists $TimeZoneBad $timezone] } { dict set TimeZoneBad $timezone [catch {SetupTimeZone $timezone}] } diff --git a/tests/clock.test b/tests/clock.test index 8c31f83..bda5e76 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -35895,6 +35895,39 @@ test clock-38.1 {regression - convertUTCToLocalViaC - east of Greenwich} \ } \ -result {01:00:00} +test clock-38.2 {make sure TZ is not cached after unset} \ + -setup { + if { [info exists env(TZ)] } { + set oldTZ $env(TZ) + unset env(TZ) + } + if { [info exists env(TCL_TZ)] } { + set oldTCLTZ $env(TCL_TZ) + unset env(TCL_TZ) + } + } \ + -body { + set t1 [clock format 0] + # a time zone that is unlikely to anywhere + set env(TZ) "+04:20" + set t2 [clock format 0] + unset env(TZ) + set t3 [clock format 0] + expr {$t1 eq $t3 && $t1 ne $t2} + } \ + -cleanup { + if { [info exists oldTZ] } { + set env(TZ) $oldTZ + unset oldTZ + } + if { [info exists oldTclTZ] } { + set env(TCL_TZ) $oldTclTZ + unset oldTclTZ + } + } \ + -result 1 + + test clock-39.1 {regression - synonym timezones} { clock format 0 -format {%H:%M:%S} -timezone :US/Eastern } {19:00:00} -- cgit v0.12 From af3c0b7aa062161e708224346b62b7e8d6fec876 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 19 Oct 2011 20:21:29 +0000 Subject: Stop warnings and segfault. --- generic/tclTest.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 299ba0e..af467f0 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7149,7 +7149,7 @@ InterpCmdResolver( varFramePtr->procPtr : NULL; Namespace *ns2NsPtr; - ns2NsPtr = Tcl_FindNamespace(interp, "::ns2", NULL, 0); + ns2NsPtr = (Namespace *)Tcl_FindNamespace(interp, "::ns2", NULL, 0); if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) { @@ -7256,7 +7256,7 @@ MyCompiledVarFetch( * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree(); */ - VarHashRefCount(var); + VarHashRefCount(var) ++; return var; } -- cgit v0.12 From 87f901722efaedd3a6c7b91b25f0d8f90e078649 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 20 Oct 2011 13:50:43 +0000 Subject: Tidying up. --- generic/tclTest.c | 76 +++++++++++++++++++++++++++++++------------------------ 1 file changed, 43 insertions(+), 33 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index af467f0..4027816 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7134,6 +7134,10 @@ TestparseargsCmd( return TCL_OK; }  +/** + * Test harness for command and variable resolvers. + */ + static int InterpCmdResolver( Tcl_Interp *interp, @@ -7142,24 +7146,23 @@ InterpCmdResolver( int flags, Tcl_Command *rPtr) { - Tcl_Command sourceCmdPtr; Interp *iPtr = (Interp *) interp; CallFrame *varFramePtr = iPtr->varFramePtr; Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ? - varFramePtr->procPtr : NULL; - Namespace *ns2NsPtr; - - ns2NsPtr = (Namespace *)Tcl_FindNamespace(interp, "::ns2", NULL, 0); + varFramePtr->procPtr : NULL; + Namespace *ns2NsPtr = (Namespace *) + Tcl_FindNamespace(interp, "::ns2", NULL, 0); if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) { const char *callingCmdName = Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr); - if ((*callingCmdName == 'x') && (*(callingCmdName + 1) == '\0') - && (*name == 'z') && (*(name + 1) == '\0')) { - sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL, + if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0') + && (name[0] == 'z') && (name[1] == '\0')) { + Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY); + if (sourceCmdPtr != NULL) { *rPtr = sourceCmdPtr; return TCL_OK; @@ -7177,6 +7180,10 @@ InterpVarResolver( int flags, Tcl_Var *rPtr) { + /* + * Don't resolve the variable; use standard rules. + */ + return TCL_CONTINUE; } @@ -7186,12 +7193,12 @@ typedef struct MyResolvedVarInfo { Tcl_Obj *nameObj; } MyResolvedVarInfo; -static void +static inline void HashVarFree( Tcl_Var var) { if (VarHashRefCount(var) < 2) { - ckfree((char *) var); + ckfree(var); } else { VarHashRefCount(var)--; } @@ -7207,7 +7214,7 @@ MyCompiledVarFree( if (resVarInfo->var) { HashVarFree(resVarInfo->var); } - ckfree((char *)vInfoPtr); + ckfree(vInfoPtr); } #define TclVarHashGetValue(hPtr) \ @@ -7220,20 +7227,19 @@ MyCompiledVarFetch( { MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vinfoPtr; Tcl_Var var = resVarInfo->var; - Namespace *nsPtr; int isNewVar; Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; - if (var && !(((Var *)var)->flags & VAR_DEAD_HASH)) { - /* - * The cached variable is valid, return it. - */ + if (var != NULL) { + if (!(((Var *) var)->flags & VAR_DEAD_HASH)) { + /* + * The cached variable is valid, return it. + */ - return var; - } + return var; + } - if (var) { /* * The variable is not valid anymore. Clean it up. */ @@ -7241,8 +7247,7 @@ MyCompiledVarFetch( HashVarFree(var); } - nsPtr = iPtr->globalNsPtr; - hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &nsPtr->varTable, + hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &iPtr->globalNsPtr->varTable, (char *) resVarInfo->nameObj, &isNewVar); if (hPtr) { var = (Tcl_Var) TclVarHashGetValue(hPtr); @@ -7256,7 +7261,7 @@ MyCompiledVarFetch( * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree(); */ - VarHashRefCount(var) ++; + VarHashRefCount(var)++; return var; } @@ -7276,7 +7281,7 @@ InterpCompiledVarResolver( resVarInfo->var = NULL; resVarInfo->nameObj = Tcl_NewStringObj(name, -1); Tcl_IncrRefCount(resVarInfo->nameObj); - *rPtr = (Tcl_ResolvedVarInfo *) resVarInfo; + *rPtr = &resVarInfo->vInfo; return TCL_OK; } return TCL_CONTINUE; @@ -7289,26 +7294,31 @@ TestInterpResolversCmd( int objc, Tcl_Obj *const objv[]) { - const char *option; + static const char *const table[] = { + "down", "up", NULL + }; + int idx; +#define RESOLVER_KEY "testInterpResolver" if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "up|down"); return TCL_ERROR; } - option = TclGetString(objv[1]); - if (*option == 'u' && strcmp(option, "up") == 0) { - Tcl_AddInterpResolvers(interp, "interpResolver", InterpCmdResolver, + if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT, + &idx) != TCL_OK) { + return TCL_ERROR; + } + switch (idx) { + case 1: /* up */ + Tcl_AddInterpResolvers(interp, RESOLVER_KEY, InterpCmdResolver, InterpVarResolver, InterpCompiledVarResolver); - } else if (*option == 'd' && strcmp(option, "down") == 0) { - if (Tcl_RemoveInterpResolvers(interp, "interpResolver") == 0) { + break; + case 0: /*down*/ + if (!Tcl_RemoveInterpResolvers(interp, RESOLVER_KEY)) { Tcl_AppendResult(interp, "could not remove the resolver scheme", NULL); return TCL_ERROR; } - } else { - Tcl_AppendResult(interp, "bad option \"", option, - "\": must be 'up' or 'down'", NULL); - return TCL_ERROR; } return TCL_OK; } -- cgit v0.12 From 37aa42f79dede55e98bf0684b0163c11dfa27f81 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 20 Oct 2011 14:24:53 +0000 Subject: ChangeLog entry. --- ChangeLog | 10 ++++++++++ generic/tclTest.c | 6 +++--- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index d219048..a36534d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2011-10-20 Donal K. Fellows + + * generic/tclLiteral.c (TclInvalidateCmdLiteral): [Bug 3418547]: + Additional code for handling the invalidation of literals. + * generic/tclBasic.c (Tcl_CreateObjCommand, Tcl_CreateCommand) + (TclRenameCommand, Tcl_ExposeCommand): The four additional places that + need extra care when dealing with literals. + * generic/tclTest.c (TestInterpResolverCmd): Additional test machinery + for interpreter resolvers. + 2011-10-15 Venkat Iyer * library/tzdata/America/Sitka : Update to Olson's tzdata2011l * library/tzdata/Pacific/Fiji diff --git a/generic/tclTest.c b/generic/tclTest.c index 4027816..86941c6 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -411,7 +411,7 @@ static int TestHashSystemHashCmd(ClientData clientData, static int TestNRELevels(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestInterpResolversCmd(ClientData clientData, +static int TestInterpResolverCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -678,7 +678,7 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, NULL, NULL); - Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolversCmd, + Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd, NULL, NULL); if (TclObjTest_Init(interp) != TCL_OK) { @@ -7288,7 +7288,7 @@ InterpCompiledVarResolver( } static int -TestInterpResolversCmd( +TestInterpResolverCmd( ClientData clientData, Tcl_Interp *interp, int objc, -- cgit v0.12 From 1468085ceb1552c3ff05b0d09c1f81f9b251c33f Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 20 Oct 2011 15:56:52 +0000 Subject: Update changes toward 8.6b3 release. Bump to http 2.8.3. --- ChangeLog | 9 +++++++++ changes | 35 +++++++++++++++++++++++++++++++++++ library/http/http.tcl | 2 +- library/http/pkgIndex.tcl | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 6 files changed, 50 insertions(+), 6 deletions(-) diff --git a/ChangeLog b/ChangeLog index ccecfcd..6729f15 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2011-10-20 Don Porter + + * library/http/http.tcl: Bump to version 2.8.3 + * library/http/pkgIndex.tcl: + * unix/Makefile.in: + * win/Makefile.in: + + * changes: Updates toward 8.6b3 release. + 2011-10-20 Donal K. Fellows * generic/tclLiteral.c (TclInvalidateCmdLiteral): [Bug 3418547]: diff --git a/changes b/changes index 88ea3e6..7a928e0 100644 --- a/changes +++ b/changes @@ -7954,3 +7954,38 @@ memory with buffer backup (ferrieux) Many more Tcl built-in command errors now set an -errorcode. --- Released 8.6b2, August 8, 2011 --- See ChangeLog for details --- + +2011-07-02 (bug fix)[3349507] correct double(1[string repeat 0 23]) (kenny) + +2011-07-19 (bug fix)[3371644] Tcl_ConvertElement() segfault (sader, ferrieux) + +2011-07-21 (bug fix)[3372130] hypot(.) segfault (nijtmans) + +2011-08-12 (bug fix)[3389764] memleaks due to reference cycles in dup'd paths + +2011-08-15 (bug fix)[3390272] leak of [info script] value (porter) + +2011-08-17 (bug fix)[3393150] bignum leaks in Tcl_Get*() routines (porter) + +2011-08-18 (bug fix)[3393714] [string toupper] overflow (nijtmans) + +2011-08-30 (bug fix)[3398794] panic in interp limit setting (gavlian,fellows) + +2011-09-08 (bug fix)[3401704] revised expr parser to permit function names +like "nano()" instead of parsing as "nan o()" with missing op (duquette,porter) + *** POTENTIAL INCOMPATIBILITY *** + +2011-09-13 (bug fix)[3390638] solaris studio cc workaround (kechel,porter) + +2011-09-13 (bug fix)[3405652] DTrace workaround (michelson,porter) + +2011-09-16 (bug fix)[3391977] -headers overrides -type (ziegenhagen,fellows) +=> http 2.7.7 + +2011-09-16 (bug fix)[3400658] wrong num args msg with TclOO (rsooltan,fellows) + +2011-10-11 (bug fix)[2935503] [file stat] returns bad mode (nadkarni,nijtmans) + +2011-10-15 tzdata updated to Olson's tzdata2011l (iyer) + +--- Released 8.6b3, November 20, 2011 --- See ChangeLog for details --- diff --git a/library/http/http.tcl b/library/http/http.tcl index 69817b8..12820af 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.6 # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.8.2 +package provide http 2.8.3 namespace eval http { # Allow resourcing to not clobber existing data diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 82b2e0b..d89b14b 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6]} {return} -package ifneeded http 2.8.2 [list tclPkgSetup $dir http 2.8.2 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.8.3 [list tclPkgSetup $dir http 2.8.3 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/unix/Makefile.in b/unix/Makefile.in index a2ade1d..77e87bc 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -829,8 +829,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \ done; - @echo "Installing package http 2.8.2 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.2.tm; + @echo "Installing package http 2.8.3 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.3.tm; @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ diff --git a/win/Makefile.in b/win/Makefile.in index 8a9359b..b2ce7c4 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -664,8 +664,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.8.2 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.2.tm; + @echo "Installing package http 2.8.3 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.3.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ -- cgit v0.12 From 7f9fe76ea2ebff9ae991765d371d1886fc7cd88f Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 21 Oct 2011 09:39:58 +0000 Subject: MINOR: Add emacs style info to end of C files. --- unix/tclUnixTest.c | 19 ++++++++++++++----- unix/tclXtTest.c | 9 +++++++++ win/tclWinError.c | 9 +++++++++ 3 files changed, 32 insertions(+), 5 deletions(-) diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index 0d79e47..46fc972 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -6,8 +6,8 @@ * Copyright (c) 1996-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef USE_TCL_STUBS @@ -38,8 +38,8 @@ */ typedef struct Pipe { - TclFile readFile; /* File handle for reading from the pipe. - * NULL means pipe doesn't exist yet. */ + TclFile readFile; /* File handle for reading from the pipe. NULL + * means pipe doesn't exist yet. */ TclFile writeFile; /* File handle for writing from the pipe. */ int readCount; /* Number of times the file handler for this * file has triggered and the file was @@ -699,7 +699,7 @@ TestchmodCmd( char *rest; if (argc < 2) { - usage: + usage: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " mode file ?file ...?", NULL); return TCL_ERROR; @@ -727,3 +727,12 @@ TestchmodCmd( } return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * tab-width: 8 + * End: + */ diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c index 93bcc81..fcb0773 100644 --- a/unix/tclXtTest.c +++ b/unix/tclXtTest.c @@ -124,3 +124,12 @@ TesteventloopCmd( } return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * tab-width: 8 + * End: + */ diff --git a/win/tclWinError.c b/win/tclWinError.c index ca1b0e8..4fee02b 100644 --- a/win/tclWinError.c +++ b/win/tclWinError.c @@ -387,3 +387,12 @@ TclWinConvertWSAError( Tcl_SetErrno(EINVAL); } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * tab-width: 8 + * End: + */ -- cgit v0.12 From 783d7dd4b08ca44c8fe4cce9cdc039e2199709e2 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 1 Nov 2011 18:53:11 +0000 Subject: Work in progress converting tests from [testthread cancel] to [thread::cancel] --- tests/thread.test | 613 +++++++++++++++++++++++---------------------------- tests/unixNotfy.test | 5 - 2 files changed, 270 insertions(+), 348 deletions(-) diff --git a/tests/thread.test b/tests/thread.test index 74f7043..dbfaec3 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -12,14 +12,14 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2.2 namespace import -force ::tcltest::* } # Some tests require the testthread command testConstraint testthread [expr {[info commands testthread] != {}}] -testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] +testConstraint thread [expr {0 == [catch {package require Thread 2.7}]}] testConstraint notValgrind [expr {![testConstraint valgrind]}] @@ -59,12 +59,6 @@ if {[testConstraint testthread]} { } } -test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} { - list [catch {testthread} msg] $msg -} {1 {wrong # args: should be "testthread option ?arg ...?"}} -test thread-1.2 {Tcl_ThreadObjCmd: bad option} {testthread} { - list [catch {testthread foo} msg] $msg -} {1 {bad option "foo": must be cancel, create, event, exit, id, join, names, send, wait, or errorproc}} test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} { llength [thread::names] } 1 @@ -93,53 +87,18 @@ test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} { after 10 llength [thread::names] } {1} -test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {testthread} { - set x [catch {testthread id x} msg] - list $x $msg -} {1 {wrong # args: should be "testthread id"}} -test thread-1.8 {Tcl_ThreadObjCmd: thread id} {testthread} { - string compare [testthread id] $mainThread -} {0} -test thread-1.9 {Tcl_ThreadObjCmd: thread names args} {testthread} { - set x [catch {testthread names x} msg] - list $x $msg -} {1 {wrong # args: should be "testthread names"}} -test thread-1.10 {Tcl_ThreadObjCmd: thread id} {testthread} { - string compare [testthread names] $mainThread -} {0} -test thread-1.11 {Tcl_ThreadObjCmd: send args} {testthread} { - set x [catch {testthread send} msg] - list $x $msg -} {1 {wrong # args: should be "testthread send ?-async? id script"}} -test thread-1.12 {Tcl_ThreadObjCmd: send nonint} {testthread} { - set x [catch {testthread send abc command} msg] - list $x $msg -} {1 {expected integer but got "abc"}} test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} { set serverthread [thread::create -preserved] set five [thread::send $serverthread {set x 5}] thread::release $serverthread set five } 5 -test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} { - set tid [expr $mainThread + 10] - set x [catch {testthread send $tid {set x 5}} msg] - list $x $msg -} {1 {invalid thread id}} test thread-1.15 {Tcl_ThreadObjCmd: wait} {thread} { set serverthread [thread::create -preserved {set z 5 ; thread::wait}] set five [thread::send $serverthread {set z}] thread::release $serverthread set five } 5 -test thread-1.16 {Tcl_ThreadObjCmd: errorproc args} {testthread} { - set x [catch {testthread errorproc foo bar} msg] - list $x $msg -} {1 {wrong # args: should be "testthread errorproc proc"}} -test thread-1.17 {Tcl_ThreadObjCmd: errorproc change} {testthread} { - testthread errorproc foo - testthread errorproc ThreadError -} {} # The tests above also cover: # TclCreateThread, except when pthread_create fails @@ -257,29 +216,16 @@ test thread-6.1 {freeing very large object trees in a thread} thread { } 0 # TIP #285: Script cancellation support -test thread-7.1 {cancel: args} {testthread} { - set x [catch {testthread cancel} msg] - list $x $msg -} {1 {wrong # args: should be "testthread cancel ?-unwind? id ?result?"}} -test thread-7.2 {cancel: nonint} {testthread} { - set x [catch {testthread cancel abc} msg] - list $x $msg -} {1 {expected integer but got "abc"}} -test thread-7.3 {cancel: bad id} {testthread} { - set tid [expr $mainThread + 10] - set x [catch {testthread cancel $tid} msg] - list $x $msg -} {1 {invalid thread id}} -test thread-7.4 {cancel: pure bytecode loop} {testthread} { - threadReap +test thread-7.4 {cancel: pure bytecode loop} -constraints {thread} -setup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } while {1} { @@ -287,30 +233,28 @@ test thread-7.4 {cancel: pure bytecode loop} {testthread} { } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} -test thread-7.5 {cancel: pure inside-command loop} {testthread} { - threadReap + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {eval canceled}} +test thread-7.5 {cancel: pure inside-command loop} -constraints {thread} -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } set while while @@ -319,30 +263,28 @@ test thread-7.5 {cancel: pure inside-command loop} {testthread} { } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} -test thread-7.6 {cancel: pure bytecode loop -unwind} {testthread} { - threadReap + vwait threadIdStarted + set res [thread::cancel $serverthread] + vwait threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {eval canceled}} +test thread-7.6 {cancel: pure bytecode loop -unwind} -constraints {thread} -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } while {1} { @@ -350,30 +292,28 @@ test thread-7.6 {cancel: pure bytecode loop -unwind} {testthread} { } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.7 {cancel: pure inside-command loop -unwind} {testthread} { - threadReap + vwait threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { - proc foobar {} { +} -result {{} 1 1 {eval unwound}} +test thread-7.7 {cancel: pure inside-command loop -unwind} -constraints thread -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } set while while @@ -382,30 +322,28 @@ test thread-7.7 {cancel: pure inside-command loop -unwind} {testthread} { } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.8 {cancel: pure bytecode loop custom result} {testthread} { - threadReap + vwait threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {eval unwound}} +test thread-7.8 {cancel: pure bytecode loop custom result} -constraints thread -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } while {1} { @@ -413,30 +351,30 @@ test thread-7.8 {cancel: pure bytecode loop custom result} {testthread} { } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread "the eval was canceled"] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {the eval was canceled}} -test thread-7.9 {cancel: pure inside-command loop custom result} {testthread} { - threadReap + vwait threadIdStarted + set res [thread::cancel $serverthread "the eval was canceled"] + vwait threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { - proc foobar {} { +} -result {{} 1 1 {the eval was canceled}} +test thread-7.9 {cancel: pure inside-command loop custom result} -constraints { + thread +} -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } set while while @@ -445,30 +383,30 @@ test thread-7.9 {cancel: pure inside-command loop custom result} {testthread} { } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread "the eval was canceled"] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {the eval was canceled}} -test thread-7.10 {cancel: pure bytecode loop custom result -unwind} {testthread} { - threadReap + vwait threadIdStarted + set res [thread::cancel $serverthread "the eval was canceled"] + vwait threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {the eval was canceled}} +test thread-7.10 {cancel: pure bytecode loop custom result -unwind} -constraints { + thread +} -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } while {1} { @@ -476,30 +414,30 @@ test thread-7.10 {cancel: pure bytecode loop custom result -unwind} {testthread} } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread "the eval was unwound"] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {the eval was unwound}} -test thread-7.11 {cancel: pure inside-command loop custom result -unwind} {testthread} { - threadReap + vwait threadIdStarted + set res [thread::cancel -unwind $serverthread "the eval was unwound"] + vwait threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { - proc foobar {} { +} -result {{} 1 1 {the eval was unwound}} +test thread-7.11 {cancel: pure inside-command loop custom result -unwind} -constraints { + thread +} -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } set while while @@ -508,196 +446,183 @@ test thread-7.11 {cancel: pure inside-command loop custom result -unwind} {testt } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread "the eval was unwound"] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {the eval was unwound}} -test thread-7.12 {cancel: after} {testthread} { - threadReap + vwait threadIdStarted + set res [thread::cancel -unwind $serverthread "the eval was unwound"] + vwait threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {the eval was unwound}} +test thread-7.12 {cancel: after} -constraints thread -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } after 30000 - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} -test thread-7.13 {cancel: after -unwind} {testthread} { - threadReap + vwait threadIdStarted + set res [thread::cancel $serverthread] + vwait threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {eval canceled}} +test thread-7.13 {cancel: after -unwind} -constraints thread -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } after 30000 - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.14 {cancel: vwait} {testthread} { - threadReap + vwait threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {eval unwound}} +test thread-7.14 {cancel: vwait} -constraints thread -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID [thread::id]] { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } vwait forever - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} -test thread-7.15 {cancel: vwait -unwind} {testthread} { - threadReap + vwait threadIdStarted + set res [thread::cancel $serverthread] + vwait threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {eval canceled}} +test thread-7.15 {cancel: vwait -unwind} -constraints thread -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } vwait forever - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.16 {cancel: expr} {testthread} { - threadReap + vwait threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {eval unwound}} +test thread-7.16 {cancel: expr} -constraints thread -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID [thread::id]] { set i [interp create] - interp alias $i testthread {} testthread + $i eval "package require -exact Thread [package present Thread]" $i eval { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } expr {[while {1} {incr x}]} } - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} -test thread-7.17 {cancel: expr -unwind} {testthread} { - threadReap + vwait threadIdStarted + set res [thread::cancel $serverthread] + vwait threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {eval canceled}} +test thread-7.17 {cancel: expr -unwind} -constraints thread -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { set i [interp create] - interp alias $i testthread {} testthread + $i eval "package require -exact Thread [package present Thread]" $i eval { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } expr {[while {1} {incr x}]} } - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.18 {cancel: expr bignum} {testthread} { - threadReap + vwait threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {eval unwound}} +test thread-7.18 {cancel: expr bignum} -constraints thread -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { set i [interp create] - interp alias $i testthread {} testthread + $i eval "package require -exact Thread [package present Thread]" $i eval { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } # @@ -706,32 +631,33 @@ test thread-7.18 {cancel: expr bignum} {testthread} { # expr {2**99999} } - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ + vwait threadIdStarted + set res [thread::cancel $serverthread] + after 1000 {set ::threadId timeout} + vwait threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ [expr {[info exists ::threadId] ? \ $::threadId == $serverthread : 0}] \ [expr {[info exists ::threadError] ? \ [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 0 {}} -test thread-7.19 {cancel: expr bignum -unwind} {testthread} { - threadReap +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 0 {}} +test thread-7.19 {cancel: expr bignum -unwind} -constraints thread -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { set i [interp create] - interp alias $i testthread {} testthread + $i eval "package require -exact Thread [package present Thread]" $i eval { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } # @@ -740,20 +666,21 @@ test thread-7.19 {cancel: expr bignum -unwind} {testthread} { # expr {2**99999} } - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ + vwait threadIdStarted + set res [thread::cancel -unwind $serverthread] + after 1000 {set ::threadId timeout} + vwait threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ [expr {[info exists ::threadId] ? \ $::threadId == $serverthread : 0}] \ [expr {[info exists ::threadError] ? \ [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 0 {}} +} -cleanup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -result {{} 1 0 {}} test thread-7.20 {cancel: subst} {testthread} { threadReap unset -nocomplain ::threadError ::threadId ::threadIdStarted diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 2a17098..067d225 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -10,10 +10,6 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# The tests should not be run if you have a notifier which is unable to -# detect infinite vwaits, as the tests below will hang. The presence of -# the "testthread" command indicates that this is the case. - if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* @@ -22,7 +18,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # When run in a Tk shell, these tests hang. testConstraint noTk [expr {0 != [catch {package present Tk}]}] testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] -testConstraint testthread [expr {[info commands testthread] != {}}] # Darwin always uses a threaded notifier testConstraint unthreaded [expr { (![info exist tcl_platform(threaded)] || !$tcl_platform(threaded)) -- cgit v0.12 From c0e38a0f1d5e32323e3654f682d3b339d3e54d54 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 3 Nov 2011 14:37:04 +0000 Subject: * unix/tclUnixCompat.c (TclpGetPwNam, TclpGetPwUid, TclpGetGrNam) (TclpGetGrGid): Use the elaborate memory management scheme outlined on http://www.opengroup.org/austin/docs/austin_328.txt to handle Tcl's use of standard reentrant versions of the passwd/group access functions so that everything can work on all BSDs. Problem identified by Stuart Cassoff. --- ChangeLog | 9 ++ unix/tclUnixCompat.c | 258 ++++++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 223 insertions(+), 44 deletions(-) diff --git a/ChangeLog b/ChangeLog index 6729f15..82e2fe0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2011-11-03 Donal K. Fellows + + * unix/tclUnixCompat.c (TclpGetPwNam, TclpGetPwUid, TclpGetGrNam) + (TclpGetGrGid): Use the elaborate memory management scheme outlined on + http://www.opengroup.org/austin/docs/austin_328.txt to handle Tcl's + use of standard reentrant versions of the passwd/group access + functions so that everything can work on all BSDs. Problem identified + by Stuart Cassoff. + 2011-10-20 Don Porter * library/http/http.tcl: Bump to version 2.8.3 diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 0ad3822..456a552 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -13,8 +13,10 @@ #include #include -/* See also: SC_BLOCKING_STYLE in unix/tcl.m4 +/* + * See also: SC_BLOCKING_STYLE in unix/tcl.m4 */ + #ifdef USE_FIONBIO # ifdef HAVE_SYS_FILIO_H # include /* For FIONBIO. */ @@ -23,39 +25,6 @@ # include # endif #endif /* USE_FIONBIO */ - -/* - *--------------------------------------------------------------------------- - * - * TclUnixSetBlockingMode -- - * - * Set the blocking mode of a file descriptor. - * - * Results: - * - * 0 on success, -1 (with errno set) on error. - * - *--------------------------------------------------------------------------- - */ -int -TclUnixSetBlockingMode( - int fd, /* File descriptor */ - int mode) /* TCL_MODE_BLOCKING or TCL_MODE_NONBLOCKING */ -{ -#ifndef USE_FIONBIO - int flags = fcntl(fd, F_GETFL); - - if (mode == TCL_MODE_BLOCKING) { - flags &= ~O_NONBLOCK; - } else { - flags |= O_NONBLOCK; - } - return fcntl(fd, F_SETFL, flags); -#else /* USE_FIONBIO */ - int state = (mode == TCL_MODE_NONBLOCKING); - return ioctl(fd, FIONBIO, &state); -#endif /* !USE_FIONBIO */ -}  /* * Used to pad structures at size'd boundaries @@ -82,10 +51,22 @@ TclUnixSetBlockingMode( typedef struct ThreadSpecificData { struct passwd pwd; +#if defined(HAVE_GETPWNAM_R_5) || defined(HAVE_GETPWUID_R_5) +#define NEED_PW_CLEANER 1 + char *pbuf; + int pbuflen; +#else char pbuf[2048]; +#endif struct group grp; +#if defined(HAVE_GETGRNAM_R_5) || defined(HAVE_GETGRGID_R_5) +#define NEED_GR_CLEANER 1 + char *gbuf; + int gbuflen; +#else char gbuf[2048]; +#endif #if !defined(HAVE_MTSAFE_GETHOSTBYNAME) || !defined(HAVE_MTSAFE_GETHOSTBYADDR) struct hostent hent; @@ -127,11 +108,54 @@ static int CopyPwd(struct passwd *tgtPtr, char *buf, int buflen); static int CopyString(const char *src, char *buf, int buflen); #endif + +#ifdef NEED_PW_CLEANER +static void FreePwBuf(ClientData ignored); +#endif +#ifdef NEED_GR_CLEANER +static void FreeGrBuf(ClientData ignored); +#endif #endif /* TCL_THREADS */  /* *--------------------------------------------------------------------------- * + * TclUnixSetBlockingMode -- + * + * Set the blocking mode of a file descriptor. + * + * Results: + * + * 0 on success, -1 (with errno set) on error. + * + *--------------------------------------------------------------------------- + */ + +int +TclUnixSetBlockingMode( + int fd, /* File descriptor */ + int mode) /* Either TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ +#ifndef USE_FIONBIO + int flags = fcntl(fd, F_GETFL); + + if (mode == TCL_MODE_BLOCKING) { + flags &= ~O_NONBLOCK; + } else { + flags |= O_NONBLOCK; + } + return fcntl(fd, F_SETFL, flags); +#else /* USE_FIONBIO */ + int state = (mode == TCL_MODE_NONBLOCKING); + + return ioctl(fd, FIONBIO, &state); +#endif /* !USE_FIONBIO */ +} + +/* + *--------------------------------------------------------------------------- + * * TclpGetPwNam -- * * Thread-safe wrappers for getpwnam(). See "man getpwnam" for more @@ -158,8 +182,33 @@ TclpGetPwNam( #if defined(HAVE_GETPWNAM_R_5) struct passwd *pwPtr = NULL; - return (getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf), - &pwPtr) == 0 && pwPtr != NULL) ? &tsdPtr->pwd : NULL; + /* + * How to allocate a buffer of the right initial size. If you want the + * gory detail, see http://www.opengroup.org/austin/docs/austin_328.txt + * and weep. + */ + + if (tsdPtr->pbuf == NULL) { + tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX); + if (tsdPtr->pbuflen < 1) { + tsdPtr->pbuflen = 1024; + } + tsdPtr->pbuf = ckalloc(tsdPtr->pbuflen); + Tcl_CreateThreadExitHandler(FreePwBuf, NULL); + } + while (1) { + int e = getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, tsdPtr->pbuflen, + &pwPtr); + + if (e == 0) { + break; + } else if (e != ERANGE) { + return NULL; + } + tsdPtr->pbuflen *= 2; + tsdPtr->pbuf = ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen); + } + return (pwPtr != NULL ? &tsdPtr->pwd : NULL); #elif defined(HAVE_GETPWNAM_R_4) return getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf)); @@ -214,8 +263,33 @@ TclpGetPwUid( #if defined(HAVE_GETPWUID_R_5) struct passwd *pwPtr = NULL; - return (getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf), - &pwPtr) == 0 && pwPtr != NULL) ? &tsdPtr->pwd : NULL; + /* + * How to allocate a buffer of the right initial size. If you want the + * gory detail, see http://www.opengroup.org/austin/docs/austin_328.txt + * and weep. + */ + + if (tsdPtr->pbuf == NULL) { + tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX); + if (tsdPtr->pbuflen < 1) { + tsdPtr->pbuflen = 1024; + } + tsdPtr->pbuf = ckalloc(tsdPtr->pbuflen); + Tcl_CreateThreadExitHandler(FreePwBuf, NULL); + } + while (1) { + int e = getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, tsdPtr->pbuflen, + &pwPtr); + + if (e == 0) { + break; + } else if (e != ERANGE) { + return NULL; + } + tsdPtr->pbuflen *= 2; + tsdPtr->pbuf = ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen); + } + return (pwPtr != NULL ? &tsdPtr->pwd : NULL); #elif defined(HAVE_GETPWUID_R_4) return getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf)); @@ -244,6 +318,29 @@ TclpGetPwUid( /* *--------------------------------------------------------------------------- * + * FreePwBuf -- + * + * Helper that is used to dispose of space allocated and referenced from + * the ThreadSpecificData for user entries. (Darn that baroque POSIX + * reentrant interface.) + * + *--------------------------------------------------------------------------- + */ + +#ifdef NEED_PW_CLEANER +static void +FreePwBuf( + ClientData ignored) +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + ckfree(tsdPtr->pbuf); +} +#endif /* NEED_PW_CLEANER */ + +/* + *--------------------------------------------------------------------------- + * * TclpGetGrNam -- * * Thread-safe wrappers for getgrnam(). See "man getgrnam" for more @@ -267,11 +364,36 @@ TclpGetGrNam( #else ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); -#if defined(HAVE_GETGRNAM_R_5) +#ifdef HAVE_GETGRNAM_R_5 struct group *grPtr = NULL; - return (getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf), - &grPtr) == 0 && grPtr != NULL) ? &tsdPtr->grp : NULL; + /* + * How to allocate a buffer of the right initial size. If you want the + * gory detail, see http://www.opengroup.org/austin/docs/austin_328.txt + * and weep. + */ + + if (tsdPtr->gbuf == NULL) { + tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX); + if (tsdPtr->gbuflen < 1) { + tsdPtr->gbuflen = 1024; + } + tsdPtr->gbuf = ckalloc(tsdPtr->gbuflen); + Tcl_CreateThreadExitHandler(FreeGrBuf, NULL); + } + while (1) { + int e = getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, tsdPtr->gbuflen, + &grPtr); + + if (e == 0) { + break; + } else if (e != ERANGE) { + return NULL; + } + tsdPtr->gbuflen *= 2; + tsdPtr->gbuf = ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen); + } + return (grPtr != NULL ? &tsdPtr->grp : NULL); #elif defined(HAVE_GETGRNAM_R_4) return getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf)); @@ -326,8 +448,33 @@ TclpGetGrGid( #if defined(HAVE_GETGRGID_R_5) struct group *grPtr = NULL; - return (getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf), - &grPtr) == 0 && grPtr != NULL) ? &tsdPtr->grp : NULL; + /* + * How to allocate a buffer of the right initial size. If you want the + * gory detail, see http://www.opengroup.org/austin/docs/austin_328.txt + * and weep. + */ + + if (tsdPtr->gbuf == NULL) { + tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX); + if (tsdPtr->gbuflen < 1) { + tsdPtr->gbuflen = 1024; + } + tsdPtr->gbuf = ckalloc(tsdPtr->gbuflen); + Tcl_CreateThreadExitHandler(FreeGrBuf, NULL); + } + while (1) { + int e = getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, tsdPtr->gbuflen, + &grPtr); + + if (e == 0) { + break; + } else if (e != ERANGE) { + return NULL; + } + tsdPtr->gbuflen *= 2; + tsdPtr->gbuf = ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen); + } + return (grPtr != NULL ? &tsdPtr->grp : NULL); #elif defined(HAVE_GETGRGID_R_4) return getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf)); @@ -356,6 +503,29 @@ TclpGetGrGid( /* *--------------------------------------------------------------------------- * + * FreeGrBuf -- + * + * Helper that is used to dispose of space allocated and referenced from + * the ThreadSpecificData for group entries. (Darn that baroque POSIX + * reentrant interface.) + * + *--------------------------------------------------------------------------- + */ + +#ifdef NEED_GR_CLEANER +static void +FreeGrBuf( + ClientData ignored) +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + ckfree(tsdPtr->gbuf); +} +#endif /* NEED_GR_CLEANER */ + +/* + *--------------------------------------------------------------------------- + * * TclpGetHostByName -- * * Thread-safe wrappers for gethostbyname(). See "man gethostbyname" for @@ -769,7 +939,7 @@ CopyArray( #ifdef NEED_COPYSTRING static int CopyString( - const char *src, /* String to copy. */ + const char *src, /* String to copy. */ char *buf, /* Buffer to copy into. */ int buflen) /* Size of buffer. */ { -- cgit v0.12 From ff1a9f1762b2a15086eb6422ca160377a1a4d783 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 8 Nov 2011 17:20:49 +0000 Subject: missing constraint and too brittle result --- tests/encoding.test | 3 ++- tests/safe.test | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/tests/encoding.test b/tests/encoding.test index a4f8449..51b7aa1 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -31,6 +31,7 @@ proc runtests {} { testConstraint testencoding [llength [info commands testencoding]] testConstraint exec [llength [info commands exec]] testConstraint testgetdefenc [llength [info commands testgetdefenc]] +testConstraint testfinexit [llength [info commands testfinexit]]  # TclInitEncodingSubsystem is tested by the rest of this file # TclFinalizeEncodingSubsystem is not currently tested @@ -417,7 +418,7 @@ test encoding-24.1 {EscapeFreeProc on open channels} exec { gets $f } } {} -test encoding-24.2 {EscapeFreeProc on open channels} exec { +test encoding-24.2 {EscapeFreeProc on open channels} {exec testfinexit} { # Bug #524674 output viewable [runInSubprocess { encoding system cp1252; # Bug #2891556 crash revelator diff --git a/tests/safe.test b/tests/safe.test index 4190976..2d7f476 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -205,7 +205,7 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { [catch {interp eval $i {package require http 1}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] -} -match glob -result "{\$p(:0:)} {\$p(:[expr 1+[llength [tcl::tm::list]]]:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" +} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" # test source control on file name test safe-8.1 {safe source control on file} -setup { -- cgit v0.12 From f9b9ca68f809e9a60a4f1c27c8ea43ef0167c26b Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 9 Nov 2011 20:40:46 +0000 Subject: More work in progress converting tests from [testthread] to Thread package. --- tests/thread.test | 497 ++++++++++++++++++++++++++---------------------------- 1 file changed, 235 insertions(+), 262 deletions(-) diff --git a/tests/thread.test b/tests/thread.test index dbfaec3..af4e4b6 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -611,7 +611,75 @@ test thread-7.17 {cancel: expr -unwind} -constraints thread -setup { } -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted } -result {{} 1 1 {eval unwound}} -test thread-7.18 {cancel: expr bignum} -constraints thread -setup { +test thread-7.18 {cancel: expr bignum} {testthread} { + threadReap + unset -nocomplain ::threadError ::threadId ::threadIdStarted + set serverthread [testthread create -joinable { + set i [interp create] + interp alias $i testthread {} testthread + $i eval { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + testthread send [testthread id -main] \ + [list set ::threadIdStarted [testthread id]] + set foo 1 + } + # + # TODO: This will not cancel because libtommath + # does not check Tcl_Canceled. + # + expr {2**99999} + } + }] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted; after 1000 + set res [testthread cancel $serverthread] + testthread join $serverthread + while {[testthread event]} {}; # force events to service + threadReap + list $res [expr {[info exists ::threadIdStarted] ? \ + $::threadIdStarted == $serverthread : 0}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError] ? \ + [lindex [split $::threadError \n] 0] : "" }] +} {{} 1 0 {}} +test thread-7.19 {cancel: expr bignum -unwind} {testthread} { + threadReap + unset -nocomplain ::threadError ::threadId ::threadIdStarted + set serverthread [testthread create -joinable { + set i [interp create] + interp alias $i testthread {} testthread + $i eval { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + testthread send [testthread id -main] \ + [list set ::threadIdStarted [testthread id]] + set foo 1 + } + # + # TODO: This will not cancel because libtommath + # does not check Tcl_Canceled. + # + expr {2**99999} + } + }] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted; after 1000 + set res [testthread cancel -unwind $serverthread] + testthread join $serverthread + while {[testthread event]} {}; # force events to service + threadReap + list $res [expr {[info exists ::threadIdStarted] ? \ + $::threadIdStarted == $serverthread : 0}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError] ? \ + [lindex [split $::threadError \n] 0] : "" }] +} {{} 1 0 {}} +test thread-7.20 {cancel: subst} -constraints {thread} -setup { unset -nocomplain ::threadError ::threadId ::threadIdStarted } -body { set serverthread [thread::create -joinable \ @@ -625,28 +693,21 @@ test thread-7.18 {cancel: expr bignum} -constraints thread -setup { thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } - # - # TODO: This will not cancel because libtommath - # does not check Tcl_Canceled. - # - expr {2**99999} + subst {[while {1} {incr x}]} } }]] # wait for other thread to signal "ready to cancel" - vwait threadIdStarted + vwait ::threadIdStarted set res [thread::cancel $serverthread] - after 1000 {set ::threadId timeout} - vwait threadId + vwait ::threadId thread::join $serverthread list $res [expr {$::threadIdStarted == $serverthread}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] } -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted -} -result {{} 1 0 {}} -test thread-7.19 {cancel: expr bignum -unwind} -constraints thread -setup { +} -result {{} 1 1 {eval canceled}} +test thread-7.21 {cancel: subst -unwind} -constraints {thread} -setup { unset -nocomplain ::threadError ::threadId ::threadIdStarted } -body { set serverthread [thread::create -joinable \ @@ -660,147 +721,76 @@ test thread-7.19 {cancel: expr bignum -unwind} -constraints thread -setup { thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } - # - # TODO: This will not cancel because libtommath - # does not check Tcl_Canceled. - # - expr {2**99999} + subst {[while {1} {incr x}]} } }]] # wait for other thread to signal "ready to cancel" - vwait threadIdStarted + vwait ::threadIdStarted set res [thread::cancel -unwind $serverthread] - after 1000 {set ::threadId timeout} - vwait threadId + vwait ::threadId thread::join $serverthread list $res [expr {$::threadIdStarted == $serverthread}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] } -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted -} -result {{} 1 0 {}} -test thread-7.20 {cancel: subst} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { - set i [interp create] - interp alias $i testthread {} testthread - $i eval { - if {![info exists foo]} then { - # signal the primary thread that we are ready - # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] - set foo 1 - } - subst {[while {1} {incr x}]} - } - }] - # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} -test thread-7.21 {cancel: subst -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { - set i [interp create] - interp alias $i testthread {} testthread - $i eval { - if {![info exists foo]} then { - # signal the primary thread that we are ready - # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] - set foo 1 - } - subst {[while {1} {incr x}]} - } - }] - # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.22 {cancel: slave interp} {testthread} { - threadReap +} -result {{} 1 1 {eval unwound}} +test thread-7.22 {cancel: slave interp} -constraints {thread} -setup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { set i [interp create] - interp alias $i testthread {} testthread + $i eval "package require -exact Thread [package present Thread]" $i eval { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } while {1} {} } - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} -test thread-7.23 {cancel: slave interp -unwind} {testthread} { - threadReap + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {eval canceled}} +test thread-7.23 {cancel: slave interp -unwind} -constraints {thread} -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { set i [interp create] - interp alias $i testthread {} testthread + $i eval "package require -exact Thread [package present Thread]" $i eval { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } set while while; $while {1} {} } - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} test thread-7.24 {cancel: nested catch inside pure bytecode loop} {notValgrind testthread} { threadReap unset -nocomplain ::threadError ::threadId ::threadIdStarted @@ -890,14 +880,13 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {notValg test thread-7.26 {cancel: send async cancel bad interp path} {thread} { unset -nocomplain ::threadIdStarted set serverthread [thread::create -preserved \ - [string map [list MAIN [thread::id]] { + [string map [list %ID% [thread::id]] { proc foobar {} { while {1} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - thread::send MAIN \ - [list set ::threadIdStarted [thread::id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } update @@ -906,28 +895,26 @@ test thread-7.26 {cancel: send async cancel bad interp path} {thread} { foobar }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 + vwait ::threadIdStarted catch {thread::send $serverthread {interp cancel -- bad}} msg thread::send -async $serverthread {interp cancel -unwind} thread::release -wait $serverthread - list [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - $msg + list [expr {$::threadIdStarted == $serverthread}] $msg } {1 {could not find interpreter "bad"}} -test thread-7.27 {cancel: send async cancel -- switch} {testthread} { - threadReap +test thread-7.27 {cancel: send async cancel -- switch} -constraints {thread} -setup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { - interp create -- -unwind - interp alias -unwind testthread {} testthread - interp eval -unwind { +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + set i [interp create -- -unwind] + $i eval "package require -exact Thread [package present Thread]" + $i eval { proc foobar {} { while {1} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } update @@ -935,20 +922,18 @@ test thread-7.27 {cancel: send async cancel -- switch} {testthread} { } foobar } - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread send -async $serverthread {interp cancel -- -unwind}] - after 1000; # wait for ThreadErrorProc to be called. - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} + vwait ::threadIdStarted + set res [thread::send -async $serverthread {interp cancel -- -unwind}] + vwait ::threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode loop} {notValgrind testthread} { threadReap unset -nocomplain ::threadError ::threadId ::threadIdStarted @@ -1121,17 +1106,17 @@ test thread-7.31 {cancel: send async testthread cancel nested catch pure inside- [expr {[info exists ::threadError] ? \ [lindex [split $::threadError \n] 0] : "" }] } {{} 1 0 {}} -test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} {testthread} { - threadReap +test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} -constraints {thread} -setup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { while {1} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } catch { @@ -1146,24 +1131,23 @@ test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} {testt } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} {testthread} { - threadReap + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {eval unwound}} +test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} -constraints {thread} -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { set catch catch set while while @@ -1171,8 +1155,7 @@ test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } $catch { @@ -1187,31 +1170,29 @@ test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode loop -unwind} {testthread} { - threadReap + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {eval unwound}} +test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode loop -unwind} -constraints {thread} -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { while {1} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } catch { @@ -1228,24 +1209,23 @@ test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode lo } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread send -async $serverthread {interp cancel -unwind}] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.35 {cancel: send async cancel nested catch inside pure inside-command loop -unwind} {testthread} { - threadReap + vwait ::threadIdStarted + set res [thread::send -async $serverthread {interp cancel -unwind}] + vwait ::threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {eval unwound}} +test thread-7.35 {cancel: send async cancel nested catch inside pure inside-command loop -unwind} -constraints {thread} -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { set catch catch set while while @@ -1253,8 +1233,7 @@ test thread-7.35 {cancel: send async cancel nested catch inside pure inside-comm if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } $catch { @@ -1271,31 +1250,29 @@ test thread-7.35 {cancel: send async cancel nested catch inside pure inside-comm } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread send -async $serverthread {interp cancel -unwind}] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.36 {cancel: send async testthread cancel nested catch inside pure bytecode loop -unwind} {testthread} { - threadReap + vwait ::threadIdStarted + set res [thread::send -async $serverthread {interp cancel -unwind}] + vwait ::threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {eval unwound}} +test thread-7.36 {cancel: send async thread cancel nested catch inside pure bytecode loop -unwind} -constraints {thread} -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { while {1} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } catch { @@ -1312,24 +1289,23 @@ test thread-7.36 {cancel: send async testthread cancel nested catch inside pure } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread send -async $serverthread {testthread cancel -unwind [testthread id]}] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.37 {cancel: send async testthread cancel nested catch inside pure inside-command loop -unwind} {testthread} { - threadReap + vwait ::threadIdStarted + set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}] + vwait ::threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +} -result {{} 1 1 {eval unwound}} +test thread-7.37 {cancel: send async thread cancel nested catch inside pure inside-command loop -unwind} -constraints {thread} -setup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID [thread::id]] { proc foobar {} { set catch catch set while while @@ -1337,8 +1313,7 @@ test thread-7.37 {cancel: send async testthread cancel nested catch inside pure if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } $catch { @@ -1355,20 +1330,18 @@ test thread-7.37 {cancel: send async testthread cancel nested catch inside pure } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread send -async $serverthread {testthread cancel -unwind [testthread id]}] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} + vwait ::threadIdStarted + set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}] + vwait ::threadId + thread::join $serverthread + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {$::threadId == $serverthread}] \ + [lindex [split $::threadError \n] 0] +} -cleanup { + unset -nocomplain ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 3ad283728dbcb52ba80de264ac53c6f9bac43b87 Mon Sep 17 00:00:00 2001 From: ferrieux Date: Fri, 11 Nov 2011 10:34:55 +0000 Subject: Use nonblocking writes in single-threaded IO tests to avoid deadlocks when going beyond OS buffers [Bug 3428756]. --- ChangeLog | 5 +++++ tests/zlib.test | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 82e2fe0..c82dfcc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2011-11-11 Alexandre Ferrieux + + * tests/zlib.test: Use nonblocking writes in single-threaded IO + tests to avoid deadlocks when going beyond OS buffers [Bug 3428756]. + 2011-11-03 Donal K. Fellows * unix/tclUnixCompat.c (TclpGetPwNam, TclpGetPwUid, TclpGetGrNam) diff --git a/tests/zlib.test b/tests/zlib.test index dac11e4..23f0229 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -197,7 +197,7 @@ test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { #puts "connection from $a:$p on $c" - chan configure $c -encoding binary -translation binary + chan configure $c -encoding binary -translation binary -blocking 0 puts -nonewline $c [string repeat a 81920] close $c }}} 0] -- cgit v0.12 From a907261ea1119035e5c0c7150e96c62127ec2390 Mon Sep 17 00:00:00 2001 From: ferrieux Date: Fri, 11 Nov 2011 10:58:43 +0000 Subject: Generalize previous fix to all of zlib.test; also, tidy up [chan configure] flags across zlib.test. --- ChangeLog | 1 + tests/zlib.test | 46 +++++++++++++++++++++++----------------------- 2 files changed, 24 insertions(+), 23 deletions(-) diff --git a/ChangeLog b/ChangeLog index c82dfcc..25d9aba 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,7 @@ * tests/zlib.test: Use nonblocking writes in single-threaded IO tests to avoid deadlocks when going beyond OS buffers [Bug 3428756]. + Tidy up [chan configure] flags across zlib.test. 2011-11-03 Donal K. Fellows diff --git a/tests/zlib.test b/tests/zlib.test index 23f0229..236e6b6 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -130,7 +130,7 @@ test zlib-8.2 {zlib transformation} -constraints zlib -setup { } -result ok test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - fconfigure $c -translation binary + fconfigure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] close $c }}} 0] @@ -175,7 +175,7 @@ test zlib-9.1 "check fcopy with push" -constraints zlib -setup { } -result {copied 81920 size 81920} test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -encoding binary -translation binary + chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] close $c }}} 0] @@ -197,7 +197,7 @@ test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { #puts "connection from $a:$p on $c" - chan configure $c -encoding binary -translation binary -blocking 0 + chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [string repeat a 81920] close $c }}} 0] @@ -222,7 +222,7 @@ test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup } -returnCodes {ok error} -result {read 81920 size 81920} test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -encoding binary -translation binary + chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] close $c }}} 0] @@ -247,7 +247,7 @@ test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup { } -result {read 81920 size 81920} test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -encoding binary -translation binary + chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] close $c }}} 0] @@ -281,7 +281,7 @@ test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup { } -result {{eof 81920} size 81920} test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary -buffering none -blocking 0 zlib push gzip $c puts -nonewline $c [string repeat hello 100] close $c @@ -290,7 +290,7 @@ test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup { lassign [chan configure $srv -sockname] addr name port after 1000 {set ::total timeout} set s [socket $addr $port] - chan configure $s -translation binary -buffering none + chan configure $s -translation binary zlib push gunzip $s chan event $s readable [list apply {{s} { set d [read $s] @@ -308,7 +308,7 @@ test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup { } -result {eof 500} test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary -buffering none -blocking 0 zlib push compress $c puts -nonewline $c [string repeat hello 100] close $c @@ -317,7 +317,7 @@ test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup { lassign [chan configure $srv -sockname] addr name port after 1000 {set ::total timeout} set s [socket $addr $port] - chan configure $s -translation binary -buffering none + chan configure $s -translation binary zlib push decompress $s chan event $s readable [list apply {{s} { set d [read $s] @@ -335,7 +335,7 @@ test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup { } -result {eof 500} test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary -buffering none -blocking 0 zlib push deflate $c puts -nonewline $c [string repeat hello 100] close $c @@ -344,7 +344,7 @@ test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup { lassign [chan configure $srv -sockname] addr name port after 1000 {set ::total timeout} set s [socket $addr $port] - chan configure $s -translation binary -buffering none + chan configure $s -translation binary zlib push inflate $s chan event $s readable [list apply {{s} { set d [read $s] @@ -363,7 +363,7 @@ test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup { test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup { proc bgerror {s} {set ::total [list error $s]} set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary -buffering none -blocking 0 zlib push gzip $c puts -nonewline $c [string repeat hello 100] close $c @@ -373,7 +373,7 @@ test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup { after 1000 {set ::total timeout} set s [socket $addr $port] try { - chan configure $s -translation binary -buffering none + chan configure $s -translation binary zlib push inflate $s chan event $s readable [list apply {{s} { set d [read $s] @@ -395,7 +395,7 @@ test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup { test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup { proc bgerror {s} {set ::total [list error $s]} set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary -buffering none -blocking 0 zlib push compress $c puts -nonewline $c [string repeat hello 100] close $c @@ -405,7 +405,7 @@ test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup { after 1000 {set ::total timeout} set s [socket $addr $port] try { - chan configure $s -translation binary -buffering none + chan configure $s -translation binary zlib push inflate $s chan event $s readable [list apply {{s} { set d [read $s] @@ -427,7 +427,7 @@ test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup { test zlib-9.11 "bug #2818131 (deflate mismatch)" -constraints zlib -setup { proc bgerror {s} {set ::total [list error $s]} set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary -buffering none -blocking 0 zlib push deflate $c puts -nonewline $c [string repeat hello 100] close $c @@ -437,7 +437,7 @@ test zlib-9.11 "bug #2818131 (deflate mismatch)" -constraints zlib -setup { after 1000 {set ::total timeout} set s [socket $addr $port] try { - chan configure $s -translation binary -buffering none + chan configure $s -translation binary zlib push gunzip $s chan event $s readable [list apply {{s} { set d [read $s] @@ -462,7 +462,7 @@ test zlib-10.0 "bug #2818131 (close with null interp)" -constraints { } -setup { proc bgerror {s} {set ::total [list error $s]} set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary zlib push inflate $c chan event $c readable [list apply {{c} { set d [read $c] @@ -477,7 +477,7 @@ test zlib-10.0 "bug #2818131 (close with null interp)" -constraints { lassign [chan configure $srv -sockname] addr name port after 1000 {set ::total timeout} set s [socket $addr $port] - chan configure $s -translation binary -buffering none + chan configure $s -translation binary -buffering none -blocking 0 zlib push gzip $s chan event $s xyzzy [list apply {{s} { if {[gets $s line] < 0} { @@ -509,7 +509,7 @@ test zlib-10.1 "bug #2818131 (mismatch read)" -constraints { } } set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary zlib push inflate $c chan event $c readable [list zlibRead $c] }}} 0] @@ -517,7 +517,7 @@ test zlib-10.1 "bug #2818131 (mismatch read)" -constraints { lassign [chan configure $srv -sockname] addr name port after 1000 {set ::total timeout} set s [socket $addr $port] - chan configure $s -translation binary -buffering none + chan configure $s -translation binary -buffering none -blocking 0 zlib push gzip $s chan event $s readable [list zlibRead $s] after idle [list apply {{s} { @@ -547,7 +547,7 @@ test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints { } } set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary zlib push inflate $c chan event $c readable [list zlibRead $c] }}} 0] @@ -555,7 +555,7 @@ test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints { lassign [chan configure $srv -sockname] addr