diff options
| -rw-r--r-- | jim.c | 88 | ||||
| -rw-r--r-- | stdlib.tcl | 10 | ||||
| -rw-r--r-- | tests/alias.test | 7 | ||||
| -rw-r--r-- | tests/tailcall.test | 8 |
4 files changed, 80 insertions, 33 deletions
@@ -10217,6 +10217,10 @@ static void JimSetProcWrongArgs(Jim_Interp *interp, Jim_Obj *procNameObj, Jim_Cm Jim_Obj *argmsg = Jim_NewStringObj(interp, "", 0); int i; + if (interp->rewriteNameObj) { + procNameObj = interp->rewriteNameObj; + } + for (i = 0; i < cmd->u.proc.argListLen; i++) { Jim_AppendString(interp, argmsg, " ", 1); @@ -10695,18 +10699,28 @@ int Jim_SubstObj(Jim_Interp *interp, Jim_Obj *substObjPtr, Jim_Obj **resObjPtrPt * ---------------------------------------------------------------------------*/ void Jim_WrongNumArgs(Jim_Interp *interp, int argc, Jim_Obj *const *argv, const char *msg) { - int i; - Jim_Obj *objPtr = Jim_NewEmptyStringObj(interp); + Jim_Obj *objPtr; + Jim_Obj *listObjPtr; - Jim_AppendString(interp, objPtr, "wrong # args: should be \"", -1); - for (i = 0; i < argc; i++) { - Jim_AppendObj(interp, objPtr, argv[i]); - if (!(i + 1 == argc && msg[0] == '\0')) - Jim_AppendString(interp, objPtr, " ", 1); + if (interp->rewriteNameObj) { + argc -= interp->rewriteNameCount; + argv += interp->rewriteNameCount; + listObjPtr = Jim_NewListObj(interp, &interp->rewriteNameObj, 1); + ListInsertElements(listObjPtr, -1, argc, argv); } - Jim_AppendString(interp, objPtr, msg, -1); - Jim_AppendString(interp, objPtr, "\"", 1); - Jim_SetResult(interp, objPtr); + else { + listObjPtr = Jim_NewListObj(interp, argv, argc); + } + if (*msg) { + Jim_ListAppendElement(interp, listObjPtr, Jim_NewStringObj(interp, msg, -1)); + } + Jim_IncrRefCount(listObjPtr); + objPtr = Jim_ListJoin(interp, listObjPtr, " ", 1); + Jim_DecrRefCount(interp, listObjPtr); + + Jim_IncrRefCount(objPtr); + Jim_SetResultFormatted(interp, "wrong # args: should be \"%#s\"", objPtr); + Jim_DecrRefCount(interp, objPtr); } /** @@ -12504,13 +12518,58 @@ static int Jim_ReturnCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *a /* [tailcall] */ static int Jim_TailcallCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv) { - Jim_Obj *objPtr; - - objPtr = Jim_NewListObj(interp, argv + 1, argc - 1); - Jim_SetResult(interp, objPtr); + Jim_SetResult(interp, Jim_NewListObj(interp, argv + 1, argc - 1)); return JIM_EVAL; } +static int JimAliasCmd(Jim_Interp *interp, int argc, Jim_Obj *const *argv) +{ + int retcode; + Jim_Obj *prefixObj = Jim_CmdPrivData(interp); + Jim_Obj *saveRewriteNameObj = interp->rewriteNameObj; + interp->rewriteNameObj = argv[0]; + interp->rewriteNameCount = Jim_ListLength(interp, prefixObj); + + Jim_Obj *cmdList = Jim_DuplicateObj(interp, prefixObj); + ListInsertElements(cmdList, -1, argc - 1, argv + 1); + Jim_IncrRefCount(cmdList); + + retcode = JimEvalObjList(interp, cmdList, interp->emptyObj, 1); + + Jim_DecrRefCount(interp, cmdList); + interp->rewriteNameObj = saveRewriteNameObj; + + return retcode; +} + +static void JimAliasCmdDelete(Jim_Interp *interp, void *privData) +{ + Jim_Obj *prefixObj = privData; + Jim_DecrRefCount(interp, prefixObj); +} + +static int Jim_AliasCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv) +{ + Jim_Obj *prefixObj; + const char *newname; + + if (argc < 3) { + Jim_WrongNumArgs(interp, 1, argv, "newname command ?args ...?"); + return JIM_ERR; + } + + prefixObj = Jim_NewListObj(interp, argv + 2, argc - 2); + Jim_IncrRefCount(prefixObj); + newname = Jim_String(argv[1]); + if (newname[0] == ':' && newname[1] == ':') { + newname += 2; + } + + Jim_SetResult(interp, argv[1]); + + return Jim_CreateCommand(interp, newname, JimAliasCmd, prefixObj, JimAliasCmdDelete); +} + /* [proc] */ static int Jim_ProcCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv) { @@ -14307,6 +14366,7 @@ static const struct { const char *name; Jim_CmdProc cmdProc; } Jim_CoreCommandsTable[] = { + {"alias", Jim_AliasCoreCommand}, {"set", Jim_SetCoreCommand}, {"unset", Jim_UnsetCoreCommand}, {"puts", Jim_PutsCoreCommand}, @@ -1,13 +1,3 @@ -# Create a single word alias (proc) for one or more words -# e.g. alias x info exists -# if {[x var]} ... -proc alias {name args} { - set prefix $args - proc $name args prefix { - tailcall {*}$prefix {*}$args - } -} - # Creates an anonymous procedure proc lambda {arglist args} { set name [ref {} function lambda.finalizer] diff --git a/tests/alias.test b/tests/alias.test index c193a42..8b4d857 100644 --- a/tests/alias.test +++ b/tests/alias.test @@ -37,6 +37,11 @@ test alias-1.8 "Replace proc with alias" { infoexists any } {0} +test alias-1.9 "error message from alias" -body { + alias newstring string + newstring match +} -returnCodes error -result {wrong # args: should be "newstring match ?-nocase? pattern string"} + test curry-1.1 "One word curry" { set x 2 set one [curry incr] @@ -80,7 +85,7 @@ test local-1.3 "local alias in proc" { list [p x] [p y] } lassign [a] exists_x exists_y - list [info procs p] $exists_x $exists_y + list [info commands p] $exists_x $exists_y } {{} 1 0} test local-1.5 "local proc in proc" { diff --git a/tests/tailcall.test b/tests/tailcall.test index 027dfe8..35ae91c 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -31,14 +31,6 @@ test tailcall-1.3 {Tailcall does return} { set x } {5} -# Note that Tcl can't do tailcall in uplevel -test tailcall-1.4 {uplevel tailcall} jim { - proc a {} { set ::y [info level] } - proc b {} { set ::x [info level]; uplevel 1 tailcall a} - b - list $x $y -} {1 1} - test tailcall-1.5 {interaction of uplevel and tailcall} { proc a {cmd} { tailcall $cmd |