diff options
| -rw-r--r-- | jim.c | 47 | ||||
| -rw-r--r-- | jim.h | 1 | ||||
| -rw-r--r-- | tclcompat.tcl | 7 | ||||
| -rw-r--r-- | tests/alias.test | 43 |
4 files changed, 90 insertions, 8 deletions
@@ -3297,8 +3297,8 @@ int Jim_CreateCommand(Jim_Interp *interp, const char *cmdName, cmdPtr = Jim_Alloc(sizeof(*cmdPtr)); /* Store the new details for this proc */ + memset(cmdPtr, 0, sizeof(*cmdPtr)); cmdPtr->inUse = 1; - cmdPtr->isproc = 0; cmdPtr->u.native.delProc = delProc; cmdPtr->u.native.cmdProc = cmdProc; cmdPtr->u.native.privData = privData; @@ -3319,6 +3319,7 @@ static int JimCreateProcedure(Jim_Interp *interp, const char *cmdName, Jim_HashEntry *he; cmdPtr = Jim_Alloc(sizeof(*cmdPtr)); + memset(cmdPtr, 0, sizeof(*cmdPtr)); cmdPtr->inUse = 1; cmdPtr->isproc = 1; cmdPtr->u.proc.argListObjPtr = argListObjPtr; @@ -3331,6 +3332,7 @@ static int JimCreateProcedure(Jim_Interp *interp, const char *cmdName, cmdPtr->u.proc.rightArity = rightArity; cmdPtr->u.proc.staticVars = NULL; cmdPtr->u.proc.prevCmd = NULL; + cmdPtr->inUse = 1; /* Create the statics hash table. */ if (staticsListObjPtr) { @@ -3517,9 +3519,14 @@ int SetCommandFromAny(Jim_Interp *interp, Jim_Obj *objPtr) * stored in objPtr. It tries to specialize the objPtr to contain * a cached info instead to perform the lookup into the hash table * every time. The information cached may not be uptodate, in such - * a case the lookup is performed and the cache updated. */ + * a case the lookup is performed and the cache updated. + * + * Respects the 'upcall' setting + */ Jim_Cmd *Jim_GetCommand(Jim_Interp *interp, Jim_Obj *objPtr, int flags) { + Jim_Cmd *cmd; + if ((objPtr->typePtr != &commandObjType || objPtr->internalRep.cmdValue.procEpoch != interp->procEpoch) && SetCommandFromAny(interp, objPtr) == JIM_ERR) { @@ -3528,7 +3535,11 @@ Jim_Cmd *Jim_GetCommand(Jim_Interp *interp, Jim_Obj *objPtr, int flags) } return NULL; } - return objPtr->internalRep.cmdValue.cmdPtr; + cmd = objPtr->internalRep.cmdValue.cmdPtr; + while (cmd->isproc && cmd->u.proc.upcall) { + cmd = cmd->u.proc.prevCmd; + } + return cmd; } /* ----------------------------------------------------------------------------- @@ -12254,6 +12265,35 @@ static int Jim_LocalCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *ar return retcode; } +/* [upcall] */ +static int Jim_UpcallCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv) +{ + if (argc < 2) { + Jim_WrongNumArgs(interp, 1, argv, "cmd ?args ...?"); + return JIM_ERR; + } + else { + int retcode; + + Jim_Cmd *cmdPtr = Jim_GetCommand(interp, argv[1], JIM_ERRMSG); + if (cmdPtr == NULL || !cmdPtr->isproc || !cmdPtr->u.proc.prevCmd) { + Jim_SetResultFormatted(interp, "no previous proc: \"%#s\"", argv[1]); + return JIM_ERR; + } + /* OK. Mark this command as being in an upcall */ + cmdPtr->u.proc.upcall++; + JimIncrCmdRefCount(cmdPtr); + + /* Invoke the command as normal */ + retcode = Jim_EvalObjVector(interp, argc - 1, argv + 1); + + /* No longer in an upcall */ + cmdPtr->u.proc.upcall--; + JimDecrCmdRefCount(interp, cmdPtr); + + return retcode; + } +} /* [concat] */ static int Jim_ConcatCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv) @@ -13957,6 +13997,7 @@ static const struct { {"rand", Jim_RandCoreCommand}, {"tailcall", Jim_TailcallCoreCommand}, {"local", Jim_LocalCoreCommand}, + {"upcall", Jim_UpcallCoreCommand}, {NULL, NULL}, }; @@ -494,6 +494,7 @@ typedef struct Jim_Cmd { int rightArity; /* Required args assigned from the right */ int args; /* True if 'args' specified */ struct Jim_Cmd *prevCmd; /* Previous command defn if proc created 'local' */ + int upcall; /* True if proc is currently in upcall */ } proc; } u; } Jim_Cmd; diff --git a/tclcompat.tcl b/tclcompat.tcl index 262aae8..8559edc 100644 --- a/tclcompat.tcl +++ b/tclcompat.tcl @@ -162,11 +162,9 @@ proc popen {cmd {mode r}} { } # A wrapper around 'pid' which can return the pids for 'popen' -if {[info commands pid] ne ""} { -rename pid .pid -proc pid {{chan {}}} { +local proc pid {{chan {}}} { if {$chan eq ""} { - tailcall .pid + tailcall upcall pid } if {[catch {$chan tell}]} { return -code error "can not find channel named \"$chan\"" @@ -176,7 +174,6 @@ proc pid {{chan {}}} { } return $pids } -} # try/on/finally conceptually similar to Tcl 8.6 # diff --git a/tests/alias.test b/tests/alias.test index bcafe04..abbc2a0 100644 --- a/tests/alias.test +++ b/tests/alias.test @@ -192,4 +192,47 @@ test local-2.3 "local proc over existing proc" { lappend x [a 5] } {6 4 6} +test upcall-1.1 "upcall pushed proc" { + proc a {b} {incr b} + local proc a {b} { + incr b 10 + # invoke the original defn via upcall + return [upcall a $b] + } + # Should call the new defn which will call the original defn + a 3 +} 14 + +test upcall-1.2 "upcall in proc" { + proc a {b} {incr b} + proc t {c} { + local proc a {b} { + incr b 10 + return [upcall a $b] + } + a $c + } + unset -nocomplain x + lappend x [t 5] + lappend x [a 5] + set x +} {16 6} + +test upcall-1.3 "double upcall" { + proc a {} {return 1} + local proc a {} {list 2 {*}[upcall a]} + local proc a {} {list 3 {*}[upcall a]} + a +} {3 2 1} + +test upcall-1.4 "upcall errors" { + proc a {} {return 1} + list [catch {upcall a} msg] $msg +} {1 {no previous proc: "a"}} + +test upcall-1.4 "upcall errors" { + proc a {} {upcall a} + list [catch a msg] $msg +} {1 {no previous proc: "a"}} + testreport |