diff options
| -rw-r--r-- | jim-namespace.c | 2 | ||||
| -rw-r--r-- | jim.c | 141 | ||||
| -rw-r--r-- | tests/apply.test | 136 | ||||
| -rw-r--r-- | tests/applyns.test | 99 |
4 files changed, 350 insertions, 28 deletions
diff --git a/jim-namespace.c b/jim-namespace.c index 9b606c7..3413705 100644 --- a/jim-namespace.c +++ b/jim-namespace.c @@ -96,11 +96,13 @@ int Jim_CreateNamespaceVariable(Jim_Interp *interp, Jim_Obj *varNameObj, Jim_Obj { int rc; Jim_IncrRefCount(varNameObj); + Jim_IncrRefCount(targetNameObj); /* push non-namespace vars if in namespace eval? */ rc = Jim_SetVariableLink(interp, varNameObj, targetNameObj, interp->topFramePtr); Jim_DecrRefCount(interp, varNameObj); + Jim_DecrRefCount(interp, targetNameObj); return rc; } @@ -3588,9 +3588,32 @@ static const Jim_HashTableType JimCommandsHashTableType = { #ifdef jim_ext_namespace /** - * Qualifies 'name' with the current namespace if necessary and - * returns the "unscoped" name (that is, without the leading ::). - * The object stored in *objPtrPtr should be decremented after use. + * Returns the "unscoped" version of the given namespace. + * That is, the fully qualfied name without the leading :: + * The returned value is either nsObj, or an object with a zero ref count. + */ +static Jim_Obj *JimQualifyNameObj(Jim_Interp *interp, Jim_Obj *nsObj) +{ + const char *name = Jim_String(nsObj); + if (name[0] == ':' && name[1] == ':') { + /* This command is being defined in the global namespace */ + while (*++name == ':') { + } + nsObj = Jim_NewStringObj(interp, name, -1); + } + else if (Jim_Length(interp->framePtr->nsObj)) { + /* This command is being defined in a non-global namespace */ + nsObj = Jim_DuplicateObj(interp, interp->framePtr->nsObj); + Jim_AppendStrings(interp, nsObj, "::", name, NULL); + } + return nsObj; +} + +/** + * An efficient version of JimQualifyNameObj() where the name is + * available (and needed) as a 'const char *'. + * Avoids creating an object if not necessary. + * The object stored in *objPtrPtr should be disposed of with JimFreeQualifiedName() after use. */ static const char *JimQualifyName(Jim_Interp *interp, const char *name, Jim_Obj **objPtrPtr) { @@ -3611,7 +3634,9 @@ static const char *JimQualifyName(Jim_Interp *interp, const char *name, Jim_Obj *objPtrPtr = objPtr; return name; } + #define JimFreeQualifiedName(INTERP, OBJ) Jim_DecrRefCount((INTERP), (OBJ)) + #else /* We can be more efficient in the no-namespace case */ #define JimQualifyName(INTERP, NAME, DUMMY) (((NAME)[0] == ':' && (NAME)[1] == ':') ? (NAME) + 2 : (NAME)) @@ -3754,18 +3779,12 @@ static void JimUpdateProcNamespace(Jim_Interp *interp, Jim_Cmd *cmdPtr, const ch #endif } -static int JimCreateProcedure(Jim_Interp *interp, Jim_Obj *cmdNameObj, - Jim_Obj *argListObjPtr, Jim_Obj *staticsListObjPtr, Jim_Obj *bodyObjPtr) +static Jim_Cmd *JimCreateProcedureCmd(Jim_Interp *interp, Jim_Obj *argListObjPtr, + Jim_Obj *staticsListObjPtr, Jim_Obj *bodyObjPtr, Jim_Obj *nsObj) { Jim_Cmd *cmdPtr; int argListLen; int i; - Jim_Obj *qualifiedCmdNameObj; - const char *cmdname; - - if (JimValidName(interp, "procedure", cmdNameObj) != JIM_OK) { - return JIM_ERR; - } argListLen = Jim_ListLength(interp, argListObjPtr); @@ -3779,7 +3798,7 @@ static int JimCreateProcedure(Jim_Interp *interp, Jim_Obj *cmdNameObj, cmdPtr->u.proc.bodyObjPtr = bodyObjPtr; cmdPtr->u.proc.argsPos = -1; cmdPtr->u.proc.arglist = (struct Jim_ProcArg *)(cmdPtr + 1); - cmdPtr->u.proc.nsObj = interp->emptyObj; + cmdPtr->u.proc.nsObj = nsObj ? nsObj : interp->emptyObj; Jim_IncrRefCount(argListObjPtr); Jim_IncrRefCount(bodyObjPtr); Jim_IncrRefCount(cmdPtr->u.proc.nsObj); @@ -3805,7 +3824,7 @@ static int JimCreateProcedure(Jim_Interp *interp, Jim_Obj *cmdNameObj, Jim_SetResultString(interp, "argument with no name", -1); err: JimDecrCmdRefCount(interp, cmdPtr); - return JIM_ERR; + return NULL; } if (len > 2) { Jim_SetResultFormatted(interp, "too many fields in argument specifier \"%#s\"", argPtr); @@ -3844,19 +3863,7 @@ err: cmdPtr->u.proc.arglist[i].defaultObjPtr = defaultObjPtr; } - /* Add the new command */ - cmdname = JimQualifyName(interp, Jim_String(cmdNameObj), &qualifiedCmdNameObj); - - JimCreateCommand(interp, cmdname, cmdPtr); - - /* Calculate and set the namespace for this proc */ - JimUpdateProcNamespace(interp, cmdPtr, cmdname); - - JimFreeQualifiedName(interp, qualifiedCmdNameObj); - - /* Unlike Tcl, set the name of the proc as the result */ - Jim_SetResult(interp, cmdNameObj); - return JIM_OK; + return cmdPtr; } int Jim_DeleteCommand(Jim_Interp *interp, const char *name) @@ -12839,17 +12846,41 @@ static int Jim_AliasCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *ar /* [proc] */ static int Jim_ProcCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv) { + Jim_Cmd *cmd; + if (argc != 4 && argc != 5) { Jim_WrongNumArgs(interp, 1, argv, "name arglist ?statics? body"); return JIM_ERR; } + if (JimValidName(interp, "procedure", argv[1]) != JIM_OK) { + return JIM_ERR; + } + if (argc == 4) { - return JimCreateProcedure(interp, argv[1], argv[2], NULL, argv[3]); + cmd = JimCreateProcedureCmd(interp, argv[2], NULL, argv[3], NULL); } else { - return JimCreateProcedure(interp, argv[1], argv[2], argv[3], argv[4]); + cmd = JimCreateProcedureCmd(interp, argv[2], argv[3], argv[4], NULL); } + + if (cmd) { + /* Add the new command */ + Jim_Obj *qualifiedCmdNameObj; + const char *cmdname = JimQualifyName(interp, Jim_String(argv[1]), &qualifiedCmdNameObj); + + JimCreateCommand(interp, cmdname, cmd); + + /* Calculate and set the namespace for this proc */ + JimUpdateProcNamespace(interp, cmd, cmdname); + + JimFreeQualifiedName(interp, qualifiedCmdNameObj); + + /* Unlike Tcl, set the name of the proc as the result */ + Jim_SetResult(interp, argv[1]); + return JIM_OK; + } + return JIM_ERR; } /* [local] */ @@ -12911,6 +12942,59 @@ static int Jim_UpcallCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *a } } +/* [apply] */ +static int Jim_ApplyCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv) +{ + if (argc < 2) { + Jim_WrongNumArgs(interp, 1, argv, "lambdaExpr ?arg ...?"); + return JIM_ERR; + } + else { + int ret; + Jim_Cmd *cmd; + Jim_Obj *argListObjPtr; + Jim_Obj *bodyObjPtr; + Jim_Obj *nsObj = NULL; + Jim_Obj **nargv; + + int len = Jim_ListLength(interp, argv[1]); + if (len != 2 && len != 3) { + Jim_SetResultFormatted(interp, "can't interpret \"%#s\" as a lambda expression", argv[1]); + return JIM_ERR; + } + + if (len == 3) { +#ifdef jim_ext_namespace + /* Need to canonicalise the given namespace. */ + nsObj = JimQualifyNameObj(interp, Jim_ListGetIndex(interp, argv[1], 2)); +#else + Jim_SetResultString(interp, "namespaces not enabled", -1); + return JIM_ERR; +#endif + } + argListObjPtr = Jim_ListGetIndex(interp, argv[1], 0); + bodyObjPtr = Jim_ListGetIndex(interp, argv[1], 1); + + cmd = JimCreateProcedureCmd(interp, argListObjPtr, NULL, bodyObjPtr, nsObj); + + if (cmd) { + /* Create a new argv array with a dummy argv[0], for error messages */ + nargv = Jim_Alloc((argc - 2 + 1) * sizeof(*nargv)); + nargv[0] = Jim_NewStringObj(interp, "apply lambdaExpr", -1); + Jim_IncrRefCount(nargv[0]); + memcpy(&nargv[1], argv + 2, (argc - 2) * sizeof(*nargv)); + ret = JimCallProcedure(interp, cmd, argc - 2 + 1, nargv); + Jim_DecrRefCount(interp, nargv[0]); + Jim_Free(nargv); + + JimDecrCmdRefCount(interp, cmd); + return ret; + } + return JIM_ERR; + } +} + + /* [concat] */ static int Jim_ConcatCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv) { @@ -14744,6 +14828,7 @@ static const struct { {"tailcall", Jim_TailcallCoreCommand}, {"local", Jim_LocalCoreCommand}, {"upcall", Jim_UpcallCoreCommand}, + {"apply", Jim_ApplyCoreCommand}, {NULL, NULL}, }; diff --git a/tests/apply.test b/tests/apply.test new file mode 100644 index 0000000..1087fec --- /dev/null +++ b/tests/apply.test @@ -0,0 +1,136 @@ +# Commands covered: apply +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2005-2006 Miguel Sofer +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +source [file dirname [info script]]/testing.tcl + +needs cmd apply + + +# Tests for wrong number of arguments + +test apply-1.1 {too few arguments} -returnCodes error -body { + apply +} -result {wrong # args: should be "apply lambdaExpr ?arg ...?"} + +# Tests for malformed lambda + +test apply-2.0 {malformed lambda} -returnCodes error -body { + set lambda a + apply $lambda +} -result {can't interpret "a" as a lambda expression} +test apply-2.1 {malformed lambda} -returnCodes error -body { + set lambda [list a b c d] + apply $lambda +} -result {can't interpret "a b c d" as a lambda expression} +test apply-2.2 {malformed lambda} -body { + set lambda [list {{}} boo] + apply $lambda +} -returnCodes error -match glob -result {*argument with no name} +test apply-2.3 {malformed lambda} { + set lambda [list {{a b c}} boo] + list [catch {apply $lambda} msg] $msg +} {1 {too many fields in argument specifier "a b c"}} + +# Note that Jim allow both of these +test apply-2.4 {malformed lambda} tcl { + set lambda [list a(1) {return $a(1)}] + list [catch {apply $lambda x} msg] $msg +} {1 {formal parameter "a(1)" is an array element}} +test apply-2.5 {malformed lambda} tcl { + set lambda [list a::b {return $a::b}] + list [catch {apply $lambda x} msg] $msg +} {1 {formal parameter "a::b" is not a simple name}} + +# Tests for runtime errors in the lambda expression + +test apply-4.1 {error in arguments to lambda expression} -body { + set lambda [list x {set x 1}] + apply $lambda +} -returnCodes error -result {wrong # args: should be "apply lambdaExpr x"} +test apply-4.2 {error in arguments to lambda expression} -body { + set lambda [list x {set x 1}] + apply $lambda a b +} -returnCodes error -result {wrong # args: should be "apply lambdaExpr x"} + +test apply-5.1 {runtime error in lambda expression} { + set lambda [list {} {error foo}] + list [catch {apply $lambda} msg] $msg +} {1 foo} + +# Tests for correct execution; as the implementation is the same as that for +# procs, the general functionality is mostly tested elsewhere + +test apply-6.1 {info level} { + set lev [info level] + set lambda [list {} {info level}] + expr {[apply $lambda] - $lev} +} 1 +test apply-6.2 {info level} tcl { + set lambda [list {} {info level 0}] + apply $lambda +} {apply {{} {info level 0}}} +test apply-6.3 {info level} tcl { + set lambda [list args {info level 0}] + apply $lambda x y +} {apply {args {info level 0}} x y} + +# Tests for correct argument treatment + +set applyBody { + set res {} + foreach v [info locals] { + if {$v eq "res"} continue + lappend res [list $v [set $v]] + } + set res +} + +test apply-8.1 {args treatment} { + apply [list args $applyBody] 1 2 3 +} {{args {1 2 3}}} +test apply-8.2 {args treatment} { + apply [list {x args} $applyBody] 1 2 +} {{x 1} {args 2}} +test apply-8.3 {args treatment} { + apply [list {x args} $applyBody] 1 2 3 +} {{x 1} {args {2 3}}} +test apply-8.4 {default values} { + apply [list {{x 1} {y 2}} $applyBody] +} {{x 1} {y 2}} +test apply-8.5 {default values} { + apply [list {{x 1} {y 2}} $applyBody] 3 4 +} {{x 3} {y 4}} +test apply-8.6 {default values} { + apply [list {{x 1} {y 2}} $applyBody] 3 +} {{x 3} {y 2}} +test apply-8.7 {default values} { + apply [list {x {y 2}} $applyBody] 1 +} {{x 1} {y 2}} +test apply-8.8 {default values} { + apply [list {x {y 2}} $applyBody] 1 3 +} {{x 1} {y 3}} +test apply-8.9 {default values} { + apply [list {x {y 2} args} $applyBody] 1 +} {{x 1} {y 2} {args {}}} +test apply-8.10 {default values} { + apply [list {x {y 2} args} $applyBody] 1 3 +} {{x 1} {y 3} {args {}}} + +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/applyns.test b/tests/applyns.test new file mode 100644 index 0000000..0483692 --- /dev/null +++ b/tests/applyns.test @@ -0,0 +1,99 @@ +# Commands covered: apply +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2005-2006 Miguel Sofer +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +source [file dirname [info script]]/testing.tcl + +needs cmd apply +needs cmd namespace + +# Tests for runtime errors in the lambda expression + +# Note: Jim doesn't have the concept of non-existent namespaces + +test apply-3.1 {non-existing namespace} -constraints tcl -body { + apply [list x {set x 1} ::NONEXIST::FOR::SURE] x +} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found} +test apply-3.2 {non-existing namespace} -constraints tcl -body { + namespace eval ::NONEXIST::FOR::SURE {} + set lambda [list x {set x 1} ::NONEXIST::FOR::SURE] + apply $lambda x + namespace delete ::NONEXIST + apply $lambda x +} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found} +test apply-3.3 {non-existing namespace} -constraints tcl -body { + apply [list x {set x 1} NONEXIST::FOR::SURE] x +} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found} +test apply-3.4 {non-existing namespace} -constraints tcl -body { + namespace eval ::NONEXIST::FOR::SURE {} + set lambda [list x {set x 1} NONEXIST::FOR::SURE] + apply $lambda x + namespace delete ::NONEXIST + apply $lambda x +} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found} + +# Tests for correct namespace scope + +namespace eval ::testApply { + proc testApply args {return testApply} +} + +test apply-7.1 {namespace access} { + set ::testApply::x 0 + set body {set x 1; set x} + list [apply [list args $body ::testApply]] $::testApply::x +} {1 0} +test apply-7.2 {namespace access} { + set ::testApply::x 0 + set body {variable x; set x} + list [apply [list args $body ::testApply]] $::testApply::x +} {0 0} +test apply-7.3 {namespace access} { + set ::testApply::x 0 + set body {variable x; set x 1} + list [apply [list args $body ::testApply]] $::testApply::x +} {1 1} +test apply-7.4 {namespace access} { + set ::testApply::x 0 + set body {testApply} + apply [list args $body ::testApply] +} testApply +test apply-7.5 {namespace access} { + set ::testApply::x 0 + set body {set x 1; set x} + list [apply [list args $body testApply]] $::testApply::x +} {1 0} +test apply-7.6 {namespace access} { + set ::testApply::x 0 + set body {variable x; set x} + list [apply [list args $body testApply]] $::testApply::x +} {0 0} +test apply-7.7 {namespace access} { + set ::testApply::x 0 + set body {variable x; set x 1} + list [apply [list args $body testApply]] $::testApply::x +} {1 1} +test apply-7.8 {namespace access} { + set ::testApply::x 0 + set body {testApply} + apply [list args $body testApply] +} testApply + +namespace delete testApply + +testreport + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: |