summaryrefslogtreecommitdiffstats
path: root/tests/uplevel.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/uplevel.test')
-rw-r--r--tests/uplevel.test109
1 files changed, 109 insertions, 0 deletions
diff --git a/tests/uplevel.test b/tests/uplevel.test
new file mode 100644
index 0000000..84daa03
--- /dev/null
+++ b/tests/uplevel.test
@@ -0,0 +1,109 @@
+# Commands covered: uplevel
+#
+# 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 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# SCCS: @(#) uplevel.test 1.13 96/02/16 08:56:35
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+proc a {x y} {
+ newset z [expr $x+$y]
+ return $z
+}
+proc newset {name value} {
+ uplevel set $name $value
+ uplevel 1 {uplevel 1 {set xyz 22}}
+}
+
+test uplevel-1.1 {simple operation} {
+ set xyz 0
+ a 22 33
+} 55
+test uplevel-1.2 {command is another uplevel command} {
+ set xyz 0
+ a 22 33
+ set xyz
+} 22
+
+proc a1 {} {
+ b1
+ global a a1
+ set a $x
+ set a1 $y
+}
+proc b1 {} {
+ c1
+ global b b1
+ set b $x
+ set b1 $y
+}
+proc c1 {} {
+ uplevel 1 set x 111
+ uplevel #2 set y 222
+ uplevel 2 set x 333
+ uplevel #1 set y 444
+ uplevel 3 set x 555
+ uplevel #0 set y 666
+}
+a1
+test uplevel-2.1 {relative and absolute uplevel} {set a} 333
+test uplevel-2.2 {relative and absolute uplevel} {set a1} 444
+test uplevel-2.3 {relative and absolute uplevel} {set b} 111
+test uplevel-2.4 {relative and absolute uplevel} {set b1} 222
+test uplevel-2.5 {relative and absolute uplevel} {set x} 555
+test uplevel-2.6 {relative and absolute uplevel} {set y} 666
+
+test uplevel-3.1 {uplevel to same level} {
+ set x 33
+ uplevel #0 set x 44
+ set x
+} 44
+test uplevel-3.2 {uplevel to same level} {
+ set x 33
+ uplevel 0 set x
+} 33
+test uplevel-3.3 {uplevel to same level} {
+ set y xxx
+ proc a1 {} {set y 55; uplevel 0 set y 66; return $y}
+ a1
+} 66
+test uplevel-3.4 {uplevel to same level} {
+ set y zzz
+ proc a1 {} {set y 55; uplevel #1 set y}
+ a1
+} 55
+
+test uplevel-4.1 {error: non-existent level} {
+ list [catch c1 msg] $msg
+} {1 {bad level "#2"}}
+test uplevel-4.2 {error: non-existent level} {
+ proc c2 {} {uplevel 3 {set a b}}
+ list [catch c2 msg] $msg
+} {1 {bad level "3"}}
+test uplevel-4.3 {error: not enough args} {
+ list [catch uplevel msg] $msg
+} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
+test uplevel-4.4 {error: not enough args} {
+ proc upBug {} {uplevel 1}
+ list [catch upBug msg] $msg
+} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
+
+proc a2 {} {
+ uplevel a3
+}
+proc a3 {} {
+ global x y
+ set x [info level]
+ set y [info level 1]
+}
+a2
+test uplevel-5.1 {info level} {set x} 1
+test uplevel-5.2 {info level} {set y} a3