do...until in Tcl

From a news:comp.lang.tcl posting by Jeffrey Hobbs on Aug 15, 2000:

Brandon Hoppe wrote: I need a loop equivalent to the do-while loop. Is there one built in?

A do-until construct was one of the Tcl2K expert questions, with the undisputed winner being:

# Done by Reinhard Max
# at the Texas Tcl Shoot-Out 2000
# in Austin, Texas,
# with subsequent updates

proc do {script arg2 {arg3 {}}} {
    # Implements a "do <script> until <expression>" loop
    # The "until" keyword ist optional
    # 
    # It is as fast as builtin "while" command for loops with
    # more than just a few iterations.

    if {$arg3 eq {}} {
        # copy the expression to arg3 if only
        # two arguments are supplied
        set arg3 $arg2
    } else {
        if {$arg2 ne {until}}
            return -code 1 {Error: do script ?until? expression}
        }
    }

    set ret [catch {uplevel $script} result copts] 
    switch $ret {
        0 -
        4 {}
        3 return
        default {
            return -options [dict replace $copts -level 2] $result
        }
    }
    
    set ret [catch {uplevel [list while !($arg3) $script]} result copts]
    return -options $copts $result
}

You can alter this from do-until to do-while by removing the !() from the uplevel'ed while .

I'll leave the analysis up to the reader, because this is an excellent example of control construct creation.

DGP: An update of this proc for Tcl 8.5 (TIP 90 ) would be a good idea. If no one else does it, I'll get to it eventually.

PYK 2014-06-19: updated as suggested by DGP.

RS: If you change the proc line to

proc do {script {arg2 {}} {arg3 {}}} {
    if {![string length $arg2$arg3]} {set arg2 0}

you win the added functionality of calling do $body which works like the not too unfrequent while 1 $body. Switching between while and until can of course also be built in...

if {$arg3 ne {}} {
    switch -- $arg2 {
    until   {set bool !}
    while   {set bool {}}
        default {return -code 1 {usage: do script ??until|while? expr?}}
    }
}

# ...

set ret [catch {uplevel [list while ${bool}($arg3) $script]} result]

rmax: This "do while|until" loop is now a part of tcllib's control package.

PYK 2014-06-19

Here is another do ... until that uses tailcall, the primary advantage of which is that do gets out of the business of handling all the possible return and error conditions, making it more straight-forward to implement new control structures.

proc do {script until args} {
    if {[llength $args]} {
        if {$until ne {until}} {
            set errorcode [
                list {until missing} {
                    with 3 arguments, argument 2 should be {until}}]
            return -code error -errorcode $errorcode $errorcode
        }
        set until [lindex $args 0]
    }
    set script [string map [
        list @script@ [list $script] @until@ [list !($until)]] {
        while 1 {
            switch [catch @script@ ::errorCode ::errorInfo] {
                4 {}
                default {
                    return -options $::errorInfo $::errorCode
                }
            }
            while @until@ @script@
            break
        }
    }]
    tailcall if 1 $script
}

To avoid polluting the caller's namespace, $::errorInfo and $::errorCode are used to capture the necessary catch information. It's a little hacky, but so far it's the best strategy I've found.

DKF: Another version, this time that uses try. That allows for much simpler handling of errors to get a higher-quality implementation:

proc do {script while expression} {
    if {$while ne "while"} {
        return -code error {error: do script ?while? expression}
    }
    append body [list try $script on continue {} {} on error {a b} {
        return -options [dict replace $b -inside $b] $a
    }] ";" [list if "!\[[list expr $expression]\]" break]
    try {return [uplevel 1 [list while true $body]]} on error {a b} {
        catch {set b [dict get $b -inside]}
        dict incr b -level
        dict set b -errorinfo [
                regsub {\("try"( body line \d+)\)$} [dict get $b -errorinfo] \
                    {("do"\1)}]
        return -options $b $a
    }
}

What marks this as high quality? The error handling. Consider this code:

do {
    puts [incr y [incr x]],$x
    seek foo bar
} while {[incr i]<5}

OK, that's going to get an error from the seek, and indeed it does, while concealing how the do works internally…

can not find channel named "foo"
    while executing
"seek foo bar"
    ("do" body line 3)
    invoked from within
"do {
    puts [incr y [incr x]],$x
    seek foo bar
} while {[incr i]<5}"
    (file "/tmp/do_example.tcl" line 18)

Not as good as a nice bit of bytecoding (which would also be much faster), but a lot easier to write!

(Exercise for the reader; handle errors in the expression nicely.)

Category Control Structure