diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2016-10-18 17:31:11 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2016-10-18 17:31:11 (GMT) |
commit | 066971b1e6e77991d9161bb0216a63ba94ea04f9 (patch) | |
tree | 6de02f79b7a4bb08a329581aa67b444fb9001bfd /tcl8.6/tests/apply.test | |
parent | ba065c2de121da1c1dfddd0aa587d10e7e150f05 (diff) | |
parent | 9966985d896629eede849a84f18e406d1164a16c (diff) | |
download | blt-066971b1e6e77991d9161bb0216a63ba94ea04f9.zip blt-066971b1e6e77991d9161bb0216a63ba94ea04f9.tar.gz blt-066971b1e6e77991d9161bb0216a63ba94ea04f9.tar.bz2 |
Merge commit '9966985d896629eede849a84f18e406d1164a16c' as 'tcl8.6'
Diffstat (limited to 'tcl8.6/tests/apply.test')
-rw-r--r-- | tcl8.6/tests/apply.test | 321 |
1 files changed, 321 insertions, 0 deletions
diff --git a/tcl8.6/tests/apply.test b/tcl8.6/tests/apply.test new file mode 100644 index 0000000..ba19b81 --- /dev/null +++ b/tcl8.6/tests/apply.test @@ -0,0 +1,321 @@ +# 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. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2.2 + namespace import -force ::tcltest::* +} + +if {[info commands ::apply] eq {}} { + return +} + +testConstraint memory [llength [info commands memory]] + +# 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} { + set lambda [list {{}} boo] + list [catch {apply $lambda} msg] $msg $::errorInfo +} {1 {argument with no name} {argument with no name + (parsing lambda expression "{{}} boo") + invoked from within +"apply $lambda"}} +test apply-2.3 {malformed lambda} { + set lambda [list {{a b c}} boo] + list [catch {apply $lambda} msg] $msg $::errorInfo +} {1 {too many fields in argument specifier "a b c"} {too many fields in argument specifier "a b c" + (parsing lambda expression "{{a b c}} boo") + invoked from within +"apply $lambda"}} +test apply-2.4 {malformed lambda} { + set lambda [list a(1) boo] + list [catch {apply $lambda} msg] $msg $::errorInfo +} {1 {formal parameter "a(1)" is an array element} {formal parameter "a(1)" is an array element + (parsing lambda expression "a(1) boo") + invoked from within +"apply $lambda"}} +test apply-2.5 {malformed lambda} { + set lambda [list a::b boo] + list [catch {apply $lambda} msg] $msg $::errorInfo +} {1 {formal parameter "a::b" is not a simple name} {formal parameter "a::b" is not a simple name + (parsing lambda expression "a::b boo") + invoked from within +"apply $lambda"}} + +# Tests for runtime errors in the lambda expression + +test apply-3.1 {non-existing namespace} -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} -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} -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} -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-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-4.3 {error in arguments to lambda expression} -body { + interp alias {} foo {} ::apply [list x {set x 1}] + foo a b +} -cleanup { + rename foo {} +} -returnCodes error -result {wrong # args: should be "foo x"} +test apply-4.4 {error in arguments to lambda expression} -body { + interp alias {} foo {} ::apply [list x {set x 1}] a + foo b +} -cleanup { + rename foo {} +} -returnCodes error -result {wrong # args: should be "foo"} +test apply-4.5 {error in arguments to lambda expression} -body { + set lambda [list x {set x 1}] + namespace eval a { + namespace ensemble create -command ::bar -map {id {::a::const foo}} + proc const val { return $val } + proc alias {object slot = command args} { + set map [namespace ensemble configure $object -map] + dict set map $slot [linsert $args 0 $command] + namespace ensemble configure $object -map $map + } + proc method {object name params body} { + set params [linsert $params 0 self] + alias $object $name = ::apply [list $params $body] $object + } + method ::bar boo x {return "[expr {$x*$x}] - $self"} + } + bar boo +} -cleanup { + namespace delete ::a +} -returnCodes error -result {wrong # args: should be "bar boo x"} + +test apply-5.1 {runtime error in lambda expression} { + set lambda [list {} {error foo}] + set res [catch {apply $lambda}] + list $res $::errorInfo +} {1 {foo + while executing +"error foo" + (lambda term "{} {error foo}" line 1) + invoked from within +"apply $lambda"}} + +# 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} { + set lambda [list {} {info level 0}] + apply $lambda +} {apply {{} {info level 0}}} +test apply-6.3 {info level} { + set lambda [list args {info level 0}] + apply $lambda x y +} {apply {args {info level 0}} x y} + +# 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 + +# 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 {}}} + +# Tests for leaks + +test apply-9.1 {leaking internal rep} -setup { + proc getbytes {} { + set lines [split [memory info] "\n"] + lindex $lines 3 3 + } + set lam [list {} {set a 1}] +} -constraints memory -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + ::apply [lrange $lam 0 end] + set tmp $end + set end [getbytes] + } + set leakedBytes [expr {$end - $tmp}] +} -cleanup { + rename getbytes {} + unset -nocomplain lam end i tmp leakedBytes +} -result 0 +test apply-9.2 {leaking internal rep} -setup { + proc getbytes {} { + set lines [split [memory info] "\n"] + lindex $lines 3 3 + } +} -constraints memory -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + ::apply [list {} {set a 1}] + set tmp $end + set end [getbytes] + } + set leakedBytes [expr {$end - $tmp}] +} -cleanup { + rename getbytes {} + unset -nocomplain end i tmp leakedBytes +} -result 0 +test apply-9.3 {leaking internal rep} -setup { + proc getbytes {} { + set lines [split [memory info] "\n"] + lindex $lines 3 3 + } +} -constraints memory -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + set x [list {} {set a 1} ::NS::THAT::DOES::NOT::EXIST] + catch {::apply $x} + set x {} + set tmp $end + set end [getbytes] + } + set leakedBytes [expr {$end - $tmp}] +} -cleanup { + rename getbytes {} + unset -nocomplain end i x tmp leakedBytes +} -result 0 + +# Tests for the avoidance of recompilation + +# cleanup + +namespace delete testApply + +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: |