From 0ca58aa64c618e56ba5a8e06c8030de1737ba015 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 31 Oct 2006 13:46:31 +0000 Subject: Fix [Bug 1587618], eliminating the callObjc and callObjv fields from the Interp structure. --- ChangeLog | 28 +++++++++++++++++----- generic/tclBasic.c | 37 +++++++----------------------- generic/tclInt.h | 19 +++------------ generic/tclNamesp.c | 21 ++++++++--------- generic/tclProc.c | 65 ++++++++++++++++++++++++++-------------------------- library/clock.tcl | 10 ++++---- tests/info.test | 8 +++---- tests/namespace.test | 6 ++--- 8 files changed, 85 insertions(+), 109 deletions(-) diff --git a/ChangeLog b/ChangeLog index 94103f2..5f44efa 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,19 +1,35 @@ +2006-10-31 Donal K. Fellows + + * generic/tclBasic.c, generic/tclNamesp.c, generic/tclProc.c: + * generic/tclInt.h: Removed the callObjc and callObjv fields from the + Interp structure. They did not function correctly and made other parts + of the core amazingly complex, resulting in a substantive change to + [info level] behaviour. [Bug 1587618] + * library/clock.tcl: Removed use of [info level 0] for calculating the + command name as used by the user and replace with a literal. What's + there now is sucky, but at least appears to be right to most users. + * tests/namespace.test (namespace-42.7,namespace-47.1): Reverted + changes to these tests. + * tests/info.test (info-9.11,info-9.12): Added knownBug constraint + since these tests require a different behaviour of [info level] than + is possible because of other dependencies. + 2006-10-30 Jeff Hobbs - * tools/tcltk-man2html.tcl (option-toc): handle any kind of - options defined toc section (needed for ttk docs) + * tools/tcltk-man2html.tcl (option-toc): handle any kind of options + defined toc section (needed for ttk docs) 2006-10-30 Miguel Sofer * generic/tclBasic.c (TEOVI): insured that the interp's callObjc/v fields are restored after traces run, as they be spoiled. This was - causing a segfault in tcllib's profiler tests. + causing a segfault in tcllib's profiler tests. 2006-10-30 Don Porter - * generic/tclExecute.c (INST_MOD): Corrected improper testing of - * tests/expr.test: the sign of bignums when applying Tcl's - division rules. Thanks to Peter Spjuth. [Bug 1585704] + * generic/tclExecute.c (INST_MOD): Corrected improper testing of the + * tests/expr.test: sign of bignums when applying Tcl's + division rules. Thanks to Peter Spjuth. [Bug 1585704] 2006-10-29 Miguel Sofer diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 9a40f38..194864b 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.206 2006/10/31 00:15:17 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.207 2006/10/31 13:46:31 dkf Exp $ */ #include "tclInt.h" @@ -362,8 +362,6 @@ 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 @@ -3286,10 +3284,11 @@ TclEvalObjvInternal( return TCL_OK; } - /* Configure evaluation context to match the requested flags */ + /* + * Configure evaluation context to match the requested flags. + */ - if ((flags & TCL_EVAL_GLOBAL) - && (varFramePtr != iPtr->rootFramePtr)) { + if ((flags & TCL_EVAL_GLOBAL) && (varFramePtr != iPtr->rootFramePtr)) { varFramePtr = iPtr->rootFramePtr; savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = varFramePtr; @@ -3303,15 +3302,6 @@ 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. * If so, create a new word array with the handler as the first words and @@ -3389,7 +3379,7 @@ TclEvalObjvInternal( */ cmdEpoch = cmdPtr->cmdEpoch; - if ((checkTraces) && (command != NULL)) { + if (checkTraces && (command != NULL)) { cmdPtr->refCount++; /* @@ -3401,27 +3391,16 @@ TclEvalObjvInternal( if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { traceCode = TclCheckInterpTraces(interp, command, length, cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); - checkTraces = 0; } if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); - checkTraces = 0; } cmdPtr->refCount--; - - /* - * Restore the calling objc/objv, in case it was spoiled by traces - */ - - if (!(checkTraces && (flags & TCL_EVAL_NOREWRITE))) { - iPtr->callObjc = objc; - iPtr->callObjv = objv; - } - } if (cmdEpoch != cmdPtr->cmdEpoch) { /* The command has been modified in some way. */ + checkTraces = 0; goto reparseBecauseOfTraces; } @@ -3432,7 +3411,7 @@ TclEvalObjvInternal( cmdPtr->refCount++; iPtr->cmdCount++; if (code == TCL_OK && traceCode == TCL_OK && !Tcl_LimitExceeded(interp)) { - if (!(flags & TCL_EVAL_INVOKE) && + if (!(flags & (TCL_EVAL_INVOKE|TCL_EVAL_NOREWRITE)) && (iPtr->ensembleRewrite.sourceObjs != NULL)) { iPtr->ensembleRewrite.sourceObjs = NULL; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 62a8fee..25a150a 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.288 2006/10/28 23:36:18 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.289 2006/10/31 13:46:31 dkf Exp $ */ #ifndef _TCLINT @@ -1547,19 +1547,6 @@ typedef struct Interp { int packagePrefer; /* Current package selection mode. */ /* - * Let [info level] know about ensemble rewriting. Note that this is just - * a temporary storage location until such time as it can be written into - * the call frame; it has to go there because that makes reentrant calls - * through the command dispatcher work. - */ - - int callObjc; /* Number of arguments to report through [info - * level]. */ - Tcl_Obj *CONST *callObjv; /* Array of arguments to report through [info - * level]. */ - - - /* * Statistical information about the bytecode compiler and interpreter's * operation. */ @@ -1577,8 +1564,8 @@ typedef struct Interp { typedef struct InterpList { Interp *interpPtr; - struct InterpList* prevPtr; - struct InterpList* nextPtr; + struct InterpList *prevPtr; + struct InterpList *nextPtr; } InterpList; /* diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 95c348e..fe4a3f8 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.111 2006/10/30 14:27:59 dkf Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.112 2006/10/31 13:46:32 dkf Exp $ */ #include "tclInt.h" @@ -423,8 +423,8 @@ Tcl_PushCallFrame( nsPtr->activationCount++; framePtr->nsPtr = nsPtr; framePtr->isProcCallFrame = isProcCallFrame; - framePtr->objc = iPtr->callObjc; - framePtr->objv = iPtr->callObjv; + framePtr->objc = 0; + framePtr->objv = NULL; framePtr->callerPtr = iPtr->framePtr; framePtr->callerVarPtr = iPtr->varFramePtr; if (iPtr->varFramePtr != NULL) { @@ -3433,6 +3433,9 @@ NamespaceEvalCmd( return TCL_ERROR; } + framePtr->objc = objc; + framePtr->objv = objv; + if (objc == 4) { result = Tcl_EvalObjEx(interp, objv[3], 0); } else { @@ -3832,6 +3835,9 @@ NamespaceInscopeCmd( return result; } + framePtr->objc = objc; + framePtr->objv = objv; + /* * Execute the command. If there is just one argument, just treat it as a * script and evaluate it. Otherwise, create a list from the arguments @@ -6296,7 +6302,6 @@ NsEnsembleImplementationCmd( */ if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) { - Interp *iPtr = (Interp *) interp; int paramc, i; Tcl_Obj **paramv, *unknownCmd, *ensObj; @@ -6342,14 +6347,6 @@ 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 b4c5696..1dfe606 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.101 2006/10/28 22:48:43 dkf Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.102 2006/10/31 13:46:32 dkf Exp $ */ #include "tclInt.h" @@ -38,7 +38,7 @@ static void MakeProcError(Tcl_Interp *interp, static void MakeLambdaError(Tcl_Interp *interp, Tcl_Obj *procNameObj); static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -static int ProcCompileProc (Tcl_Interp *interp, Proc *procPtr, +static int ProcCompileProc(Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, CONST char *description, CONST char *procName, Proc **procPtrPtr); @@ -309,7 +309,7 @@ TclCreateProc( * will be holding a reference to it. */ - procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr; + procPtr = bodyPtr->internalRep.otherValuePtr; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; @@ -1106,7 +1106,7 @@ TclInitCompiledLocals( if (bodyPtr->typePtr != &tclByteCodeType) { Tcl_Panic("body object for proc attached to frame is not a byte code type"); } - codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; + codePtr = bodyPtr->internalRep.otherValuePtr; InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); } @@ -1169,7 +1169,8 @@ ObjInterpProcEx( */ result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, - "body of proc", TclGetString(objv[0]), &procPtr); + (isLambda ? "body of lambda term" : "body of proc"), + TclGetString(objv[isLambda]), &procPtr); if (result != TCL_OK) { return result; @@ -1195,8 +1196,8 @@ ObjInterpProcEx( framePtr->objv = objv; framePtr->procPtr = procPtr; - return TclObjInterpProcCore(interp, framePtr, objv[0], isLambda, 1, - errorProc); + return TclObjInterpProcCore(interp, framePtr, objv[isLambda], isLambda, + isLambda+1, errorProc); } /* @@ -1321,7 +1322,7 @@ TclObjInterpProcCore( */ if (localPtr->flags & VAR_IS_ARGS) { - Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, &(argObjs[i])); + Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i); varPtr->value.objPtr = listPtr; Tcl_IncrRefCount(listPtr); /* local var is a reference */ } else if (argCt == numArgs) { @@ -1333,8 +1334,9 @@ TclObjInterpProcCore( varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* local var is a reference */ } else { - Tcl_Obj **desiredObjs, *argObj; + Tcl_Obj **desiredObjs; ByteCode *codePtr; + const char *final; /* * Do initialise all compiled locals, to avoid problems at @@ -1342,30 +1344,34 @@ TclObjInterpProcCore( */ incorrectArgs: - codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr; + final = NULL; + codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr); /* * Build up desired argument list for Tcl_WrongNumArgs */ - desiredObjs = (Tcl_Obj **) - ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1)); + desiredObjs = (Tcl_Obj **) TclStackAlloc(interp, + sizeof(Tcl_Obj *) * (unsigned)(numArgs+1)); #ifdef AVOID_HACKS_FOR_ITCL - desiredObjs[0] = framePtr->objv[0]; + desiredObjs[0] = framePtr->objv[skip-1]; #else - desiredObjs[0] = (isLambda ? framePtr->objv[0] : - Tcl_NewListObj(1, framePtr->objv)); + desiredObjs[0] = (isLambda ? framePtr->objv[skip-1] : + Tcl_NewListObj(skip, framePtr->objv)); #endif /* AVOID_HACKS_FOR_ITCL */ localPtr = procPtr->firstLocalPtr; for (i=1 ; i<=numArgs ; i++) { + Tcl_Obj *argObj; + TclNewObj(argObj); if (localPtr->defValuePtr != NULL) { Tcl_AppendStringsToObj(argObj, "?", localPtr->name, "?", NULL); } else if ((i==numArgs) && !strcmp(localPtr->name, "args")) { - Tcl_AppendStringsToObj(argObj, "...", NULL); + numArgs--; + final = "..."; } else { Tcl_AppendStringsToObj(argObj, localPtr->name, NULL); } @@ -1374,7 +1380,7 @@ TclObjInterpProcCore( } Tcl_ResetResult(interp); - Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, NULL); + Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final); result = TCL_ERROR; #ifndef AVOID_HACKS_FOR_ITCL @@ -1386,7 +1392,7 @@ TclObjInterpProcCore( for (i=1 ; i<=numArgs ; i++) { TclDecrRefCount(desiredObjs[i]); } - ckfree((char *) desiredObjs); + TclStackFree(interp); goto procDone; } @@ -1407,19 +1413,11 @@ TclObjInterpProcCore( runProc: if (localPtr) { - ByteCode *codePtr = (ByteCode *) - procPtr->bodyPtr->internalRep.otherValuePtr; + ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr); } - /* - * Set the callframe's objc/objv to be what [info level] expects. - */ - - framePtr->objc = ((Interp *) interp)->callObjc; - framePtr->objv = ((Interp *) interp)->callObjv; - #if defined(TCL_COMPILE_DEBUG) if (tclTraceExec >= 1) { if (isLambda) { @@ -1562,7 +1560,7 @@ ProcCompileProc( int i, result; Tcl_CallFrame *framePtr; Proc *saveProcPtr; - ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; + ByteCode *codePtr = bodyPtr->internalRep.otherValuePtr; CompiledLocal *localPtr; /* @@ -1935,7 +1933,7 @@ TclNewProcBodyObj( if (objPtr) { objPtr->typePtr = &tclProcBodyType; - objPtr->internalRep.otherValuePtr = (void *) procPtr; + objPtr->internalRep.otherValuePtr = procPtr; procPtr->refCount++; } @@ -1965,10 +1963,10 @@ ProcBodyDup( Tcl_Obj *srcPtr, /* object to copy */ Tcl_Obj *dupPtr) /* target object for the duplication */ { - Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr; + Proc *procPtr = srcPtr->internalRep.otherValuePtr; dupPtr->typePtr = &tclProcBodyType; - dupPtr->internalRep.otherValuePtr = (void *) procPtr; + dupPtr->internalRep.otherValuePtr = procPtr; procPtr->refCount++; } @@ -1995,7 +1993,8 @@ static void ProcBodyFree( Tcl_Obj *objPtr) /* the object to clean up */ { - Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr; + Proc *procPtr = objPtr->internalRep.otherValuePtr; + procPtr->refCount--; if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); @@ -2234,7 +2233,7 @@ Tcl_ApplyObjCmd( iPtr->ensembleRewrite.numInsertedObjs -= 1; } - result = ObjInterpProcEx((ClientData) procPtr, interp, objc-1, objv+1, 1, + result = ObjInterpProcEx((ClientData) procPtr, interp, objc, objv, 1, &MakeLambdaError); if (isRootEnsemble) { diff --git a/library/clock.tcl b/library/clock.tcl index 61f905b..523fc1e 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.36 2006/10/23 22:49:25 msofer Exp $ +# RCS: @(#) $Id: clock.tcl,v 1.37 2006/10/31 13:46:33 dkf Exp $ # #---------------------------------------------------------------------- @@ -653,7 +653,7 @@ 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]] + set cmdName "clock format" return -code error \ -errorcode [list CLOCK wrongNumArgs] \ "wrong \# args: should be\ @@ -1244,7 +1244,7 @@ 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]] + set cmdName "clock scan" return -code error \ -errorcode [list CLOCK wrongNumArgs] \ "wrong \# args: should be\ @@ -4318,11 +4318,11 @@ proc ::tcl::clock::BSearch { list key } { proc ::tcl::clock::add { clockval args } { if { [llength $args] % 2 != 0 } { + set cmdName "clock add" return -code error \ -errorcode [list CLOCK wrongNumArgs] \ "wrong \# args: should be\ - \"[lindex [info level 0] 0] clockval\ - ?number units?...\ + \"$cmdName clockval ?number units?...\ ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?\"" } if { [catch { expr {wide($clockval)} } result] } { diff --git a/tests/info.test b/tests/info.test index 1a4f1cd..d330ada 100644 --- a/tests/info.test +++ b/tests/info.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: info.test,v 1.38 2006/10/24 23:13:07 msofer Exp $ +# RCS: @(#) $Id: info.test,v 1.39 2006/10/31 13:46:33 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -29,7 +29,6 @@ namespace eval test_ns_info1 { proc q {{y 27} {z {}}} {return "y=$y"} } - test info-1.1 {info args option} { proc t1 {a bbb c} {return foo} info args t1 @@ -357,7 +356,7 @@ test info-9.10 {info level option, namespaces} { namespace delete t set msg } {namespace eval t {info level 0}} -test info-9.11 {info level option, aliases} -setup { +test info-9.11 {info level option, aliases} -constraints knownBug -setup { proc w {x y z} {info level 0} interp alias {} a {} w a b } -body { @@ -366,7 +365,7 @@ test info-9.11 {info level option, aliases} -setup { rename a {} rename w {} } -result {a c} -test info-9.12 {info level option, ensembles} -setup { +test info-9.12 {info level option, ensembles} -constraints knownBug -setup { proc w {x y z} {info level 0} namespace ensemble create -command a -map {foo ::w} } -body { @@ -376,7 +375,6 @@ test info-9.12 {info level option, ensembles} -setup { rename w {} } -result {a foo 1 2 3} - set savedLibrary $tcl_library test info-10.1 {info library option} { list [catch {info library x} msg] $msg diff --git a/tests/namespace.test b/tests/namespace.test index a655c9c..a9243bd 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.60 2006/10/29 21:40:43 msofer Exp $ +# RCS: @(#) $Id: namespace.test,v 1.61 2006/10/31 13:46:33 dkf 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