# 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 1991 Regents of the University of California # Permission to use, copy, modify, and distribute this # software and its documentation for any purpose and without # fee is hereby granted, provided that this copyright notice # appears in all copies. The University of California makes no # representations about the suitability of this software for any # purpose. It is provided "as is" without express or implied # warranty. # # $Header: /sprite/src/lib/tcl/tests/RCS/uplevel.test,v 1.8 91/09/30 16:59:26 ouster Exp $ (Berkeley) 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 {error: non-existent level} { list [catch c1 msg] $msg } {1 {bad level "#2"}} test uplevel-3.2 {error: non-existent level} { proc c2 {} {uplevel 3 {set a b}} list [catch c2 msg] $msg } {1 {bad level "3"}} test uplevel-3.3 {error: already at global level} { list [catch {uplevel gorp} msg] $msg } {1 {already at top level}} test uplevel-3.4 {error: already at global level} { list [catch {uplevel 1 gorp} msg] $msg } {1 {already at top level}} test uplevel-3.5 {error: not enough args} { list [catch uplevel msg] $msg } {1 {wrong # args: should be "uplevel ?level? command ?command ...?"}} proc a2 {} { uplevel a3 } proc a3 {} { global x y set x [info level] set y [info level 1] } a2 test uplevel-4.1 {info level} {set x} 1 test uplevel-4.2 {info level} {set y} a3