From 94919dd9c565db95ae21cf14b91f8cdeb2446b46 Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Mon, 23 Oct 2006 22:49:24 +0000 Subject: * library/clock.tcl (format, scan): corrected wrong # args * tests/clock.test (3.1, 34.1): messages to make use of the new rewrite capabilities of [info level] * generic/tcl.h: Lets TEOV update the iPtr->objc/objv * generic/tclBasic.c: fields, except when the (new) flag bit * generic/tclInt.h: TCL_EVAL_NOREWRITE is present. This * generic/tclNamesp.c: causes [info level] to know and use * generic/tclProc.c: ensemble rewrites [Bug 1577492] * tests/namespace.test: ***POTENTIAL INCOMPATIBILITY*** The return value from [info level 0] on interp alias calls is changed: previously returned the target command (including curried values), now returns the source - what was actually called. --- ChangeLog | 18 ++++++++++++++++++ generic/tcl.h | 5 ++++- generic/tclBasic.c | 14 +++++++++++++- generic/tclInt.h | 14 +++++++++++--- generic/tclNamesp.c | 24 ++++++++++++++---------- generic/tclProc.c | 5 +---- library/clock.tcl | 8 +++++--- tests/clock.test | 6 +++--- tests/namespace.test | 6 +++--- 9 files changed, 72 insertions(+), 28 deletions(-) diff --git a/ChangeLog b/ChangeLog index 0e75aa7..96c0cb1 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,23 @@ 2006-10-23 Miguel Sofer + * library/clock.tcl (format, scan): corrected wrong # args + * tests/clock.test (3.1, 34.1): messages to make use of the + new rewrite capabilities of [info level] + + * generic/tcl.h: Lets TEOV update the iPtr->objc/objv + * generic/tclBasic.c: fields, except when the (new) flag bit + * generic/tclInt.h: TCL_EVAL_NOREWRITE is present. This + * generic/tclNamesp.c: causes [info level] to know and use + * generic/tclProc.c: ensemble rewrites [Bug 1577492] + * tests/namespace.test: + + ***POTENTIAL INCOMPATIBILITY*** + The return value from [info level 0] on interp alias calls is + changed: previously returned the target command (including curried + values), now returns the source - what was actually called. + +2006-10-23 Miguel Sofer + * generic/tcl.h: Modified the Tcl call stack so * generic/tclBasic.c: there is always a valid CallFrame, even * generic/tclCmdIL.c: at level 0 [Patch 1577278]. Most of the diff --git a/generic/tcl.h b/generic/tcl.h index 2522fa2..8e309a2 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.223 2006/10/23 21:36:54 msofer Exp $ + * RCS: @(#) $Id: tcl.h,v 1.224 2006/10/23 22:49:24 msofer Exp $ */ #ifndef _TCL @@ -1066,11 +1066,14 @@ typedef struct Tcl_DString { * o Cut out of error traces * o Don't reset the flags controlling ensemble * error message rewriting. + * TCL_EVAL_NOREWRITE Do not update the interp's last call info; + * used by the ensemble rewrite machinery */ #define TCL_NO_EVAL 0x10000 #define TCL_EVAL_GLOBAL 0x20000 #define TCL_EVAL_DIRECT 0x40000 #define TCL_EVAL_INVOKE 0x80000 +#define TCL_EVAL_NOREWRITE 0x100000 /* * Special freeProc values that may be passed to Tcl_SetResult (see the man diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5bccd2e..a633a85 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.201 2006/10/23 21:36:54 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.202 2006/10/23 22:49:24 msofer Exp $ */ #include "tclInt.h" @@ -362,6 +362,8 @@ Tcl_CreateInterp(void) if (iPtr->globalNsPtr == NULL) { Tcl_Panic("Tcl_CreateInterp: can't create global namespace"); } + iPtr->callObjc = 0; + iPtr->callObjv = NULL; /* * Initialise the rootCallframe. It cannot be allocated on the stack, as @@ -3301,6 +3303,16 @@ TclEvalObjvInternal( } } + + /* + * Record the calling objc/objv except if requested not to + */ + + if (!(flags & TCL_EVAL_NOREWRITE)) { + iPtr->callObjc = objc; + iPtr->callObjv = objv; + } + /* * Find the function to execute this command. If there isn't one, then see * if there is an unknown command handler registered for this namespace. diff --git a/generic/tclInt.h b/generic/tclInt.h index fffcffe..6a06fb0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.282 2006/10/23 21:36:55 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.283 2006/10/23 22:49:25 msofer Exp $ */ #ifndef _TCLINT @@ -1529,8 +1529,16 @@ typedef struct Interp { * i.e the package require preferences. */ - int packagePrefer; /* Current package selection mode. - */ + int packagePrefer; /* Current package selection mode. */ + + /* + * Let [info level] know about ensemble rewriting + */ + + int callObjc; + Tcl_Obj *CONST *callObjv; + + /* * Statistical information about the bytecode compiler and interpreter's * operation. diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index b360211..a2a1632 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -22,7 +22,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.104 2006/10/23 21:36:55 msofer Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.105 2006/10/23 22:49:25 msofer Exp $ */ #include "tclInt.h" @@ -425,8 +425,8 @@ Tcl_PushCallFrame( nsPtr->activationCount++; framePtr->nsPtr = nsPtr; framePtr->isProcCallFrame = isProcCallFrame; - framePtr->objc = 0; - framePtr->objv = NULL; + framePtr->objc = iPtr->callObjc; + framePtr->objv = iPtr->callObjv; framePtr->callerPtr = iPtr->framePtr; framePtr->callerVarPtr = iPtr->varFramePtr; if (iPtr->varFramePtr != NULL) { @@ -3433,9 +3433,6 @@ NamespaceEvalCmd( if (result != TCL_OK) { return TCL_ERROR; } - framePtr->objc = objc; - framePtr->objv = objv; /* Reference counts do not need to be - * incremented here. */ if (objc == 4) { result = Tcl_EvalObjEx(interp, objv[3], 0); @@ -3834,8 +3831,6 @@ NamespaceInscopeCmd( if (result != TCL_OK) { return result; } - framePtr->objc = objc; - framePtr->objv = objv; /* * Execute the command. If there is just one argument, just treat it as a @@ -6281,7 +6276,7 @@ NsEnsembleImplementationCmd( memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2)); result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv, - TCL_EVAL_INVOKE); + TCL_EVAL_INVOKE|TCL_EVAL_NOREWRITE); Tcl_DecrRefCount(prefixObj); ckfree((char *) tempObjv); if (isRootEnsemble) { @@ -6301,10 +6296,11 @@ NsEnsembleImplementationCmd( */ if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) { + Interp *iPtr = (Interp *) interp; int paramc, i; Tcl_Obj **paramv, *unknownCmd, *ensObj; - unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler); + unknownCmd = Tcl_NewListObj(1, &ensemblePtr->unknownHandler); TclNewObj(ensObj); Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj); Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj); @@ -6346,6 +6342,14 @@ NsEnsembleImplementationCmd( } /* + * Restore the interp's call data, which may have been wiped out + * while processing the unknown handler. + */ + + iPtr->callObjc = objc; + iPtr->callObjv = objv; + + /* * Namespace alive & empty result => reparse. */ diff --git a/generic/tclProc.c b/generic/tclProc.c index e6a70ab..b0df000 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.96 2006/10/23 21:36:55 msofer Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.97 2006/10/23 22:49:25 msofer Exp $ */ #include "tclInt.h" @@ -1198,9 +1198,6 @@ ObjInterpProcEx( return result; } - - framePtr->objc = objc; - framePtr->objv = objv; /* ref counts for args are incremented below */ framePtr->procPtr = procPtr; /* diff --git a/library/clock.tcl b/library/clock.tcl index ab60089..61f905b 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: clock.tcl,v 1.35 2006/08/24 21:47:49 kennykb Exp $ +# RCS: @(#) $Id: clock.tcl,v 1.36 2006/10/23 22:49:25 msofer Exp $ # #---------------------------------------------------------------------- @@ -653,10 +653,11 @@ proc ::tcl::clock::format { args } { # Check the count of args if { [llength $args] < 1 || [llength $args] % 2 != 1 } { + set cmdName [lrange [info level 0] 0 end-[llength $args]] return -code error \ -errorcode [list CLOCK wrongNumArgs] \ "wrong \# args: should be\ - \"[lindex [info level 0] 0] clockval\ + \"$cmdName clockval\ ?-format string? ?-gmt boolean?\ ?-locale LOCALE? ?-timezone ZONE?\"" } @@ -1243,10 +1244,11 @@ proc ::tcl::clock::scan { args } { # Check the count of args if { [llength $args] < 1 || [llength $args] % 2 != 1 } { + set cmdName [lrange [info level 0] 0 end-[llength $args]] return -code error \ -errorcode [list CLOCK wrongNumArgs] \ "wrong \# args: should be\ - \"[lindex [info level 0] 0] string\ + \"$cmdName string\ ?-base seconds?\ ?-format string? ?-gmt boolean?\ ?-locale LOCALE? ?-timezone ZONE?\"" diff --git a/tests/clock.test b/tests/clock.test index 3eb6ed0..c1b9965 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: clock.test,v 1.68 2006/10/01 20:59:01 kennykb Exp $ +# RCS: @(#) $Id: clock.test,v 1.69 2006/10/23 22:49:25 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -252,7 +252,7 @@ proc ::testClock::registry { cmd path key } { test clock-1.0 "clock format - wrong # args" { list [catch {clock format} msg] $msg $::errorCode -} {1 {wrong # args: should be "::tcl::clock::format clockval ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"} {CLOCK wrongNumArgs}} +} {1 {wrong # args: should be "clock format clockval ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"} {CLOCK wrongNumArgs}} test clock-1.1 "clock format - bad time" { list [catch {clock format foo} msg] $msg @@ -35523,7 +35523,7 @@ test clock-33.11a {clock test, millis align with micros} { # clock scan test clock-34.1 {clock scan tests} { list [catch {clock scan} msg] $msg -} {1 {wrong # args: should be "::tcl::clock::scan string ?-base seconds? ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"}} +} {1 {wrong # args: should be "clock scan string ?-base seconds? ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"}} test clock-34.2 {clock scan tests} { list [catch {clock scan "bad-string"} msg] $msg } {1 {unable to convert date-time string "bad-string"}} diff --git a/tests/namespace.test b/tests/namespace.test index 4597b6f..2bc0f04 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: namespace.test,v 1.58 2006/10/10 18:23:03 dgp Exp $ +# RCS: @(#) $Id: namespace.test,v 1.59 2006/10/23 22:49:26 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -1529,7 +1529,7 @@ test namespace-42.7 {ensembles: nested} { set result [list [ns x0 z] [ns x1] [ns x2] [ns x3]] namespace delete ns set result -} {{1 ::ns::x0::z} 1 2 3} +} {{1 {ns x0 z}} 1 2 3} test namespace-43.1 {ensembles: dict-driven} { namespace eval ns { @@ -1815,7 +1815,7 @@ test namespace-47.1 {ensemble: unknown handler} { lappend result [catch {ns c d e} msg] $msg lappend result [catch {ns Magic foo bar spong wibble} msg] $msg list $result [lsort [info commands ::ns::*]] $log [namespace delete ns] -} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running ::ns::a b c} {running ::ns::a b c} {making b} {running ::ns::b c d} {making c} {running ::ns::c d e} {unknown Magic - args = foo bar spong wibble}} {}} +} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running ns a b c} {running ns a b c} {making b} {running ns b c d} {making c} {running ns c d e} {unknown Magic - args = foo bar spong wibble}} {}} test namespace-47.2 {ensemble: unknown handler} { namespace eval ns { namespace export {[a-z]*} -- cgit v0.12