155 lines
4.5 KiB
Plaintext
155 lines
4.5 KiB
Plaintext
# 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 [lsort [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
|
||
} {{args 2} {x 1}}
|
||
test apply-8.3 {args treatment} {
|
||
apply [list {x args} $applyBody] 1 2 3
|
||
} {{args {2 3}} {x 1}}
|
||
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
|
||
} {{args {}} {x 1} {y 2}}
|
||
test apply-8.10 {default values} {
|
||
apply [list {x {y 2} args} $applyBody] 1 3
|
||
} {{args {}} {x 1} {y 3}}
|
||
|
||
test apply-9.1 {tailcall within apply} {
|
||
proc p {y frame} {
|
||
list [expr {$y * 2}] [expr {$frame - [info frame]}]
|
||
}
|
||
apply {{x} {
|
||
tailcall p $x [info frame]
|
||
notreached
|
||
}} {4}
|
||
} {8 0}
|
||
test apply-9.2 {return from apply} {
|
||
apply {{x} {
|
||
return [expr {$x + 1}]
|
||
}} {4}
|
||
} {5}
|
||
|
||
|
||
rename p {}
|
||
|
||
::tcltest::cleanupTests
|
||
return
|
||
|
||
# Local Variables:
|
||
# mode: tcl
|
||
# fill-column: 78
|
||
# End:
|