One very interesting feature of Tcl is that you can write your own control structures, essentially extending the language. The uplevel command, which allows you to write a procedure which executes code in the context of the caller, is the trick.
For example, if we want to augment Tcl's standard for and while looping constructs with
do body while condition
we would simply write a do proc which executes the code in the caller's context. In its simplest form, it would look like this:
proc do {body condition} {
while {1} {
uplevel $body
if {![uplevel "expr $condition"]} {break}
}
}We can make this a little more robust by specifying the exact number of levels to uplevel, which may prevent $body from being misinterpreted. We should also use list to construct the conditional command.
proc do {body condition} {
while {1} {
uplevel 1 $body
if {![uplevel 1 [list expr $condition]]} {break}
}
}Just to make things look prettier, we can add an exra argument to do that expects the word while. You could probably get fancy and make the while optional (like the else is optional for the if command), but this should be good enough for our purposes.
proc do {body whileword condition} {
if {![string equal $whileword while]} {
error "should be \"do body while condition\""
}
while {1} {
uplevel 1 $body
if {![uplevel 1 [list expr $condition]]} {break}
}
}This procedure does not handle errors well, though. For a good discussion of the issues involved, take a look at the exception handling chapter in John Ousterhout's book BOOK Tcl and the Tk Toolkit. But the primary issue is that we want to catch exceptional conditions when executing the $body code, and correctly throw errors upwards. This error handling makes our new procedure really appear to be part of the language.
Recall that the error codes are
proc do {body whileword condition} {
global errorInfor errorCode
if {![string equal $whileword while]} {
error "should be \"do body while condition\""
}
while {1} {
set code [catch {uplevel 1 $body} message]
switch -- $code {
1 { return -code error \
-errorinfo $errorInfo \
-errorcode $errorCode $message }
2 { return -code return $message }
3 { return {} }
4 { }
default { return -code $code $message }
}
if {![uplevel 1 [list expr $condition]]} {break}
}
}To make this really really really robust, you should consider adding the same error handling to the uplevel condition, but that is left as an exercise for the reader.
RWT (with a lot of help from comp.lang.tcl) Feb 4, 2000