1# do.tcl -- 2# 3# Tcl implementation of a "do ... while|until" loop. 4# 5# Originally written for the "Texas Tcl Shootout" programming contest 6# at the 2000 Tcl Conference in Austin/Texas. 7# 8# Copyright (c) 2001 by Reinhard Max <Reinhard.Max@gmx.de> 9# 10# See the file "license.terms" for information on usage and redistribution 11# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12# 13# RCS: @(#) $Id: do.tcl,v 1.6 2004/01/15 06:36:12 andreas_kupries Exp $ 14# 15namespace eval ::control { 16 17 proc do {body args} { 18 19 # 20 # Implements a "do body while|until test" loop 21 # 22 # It is almost as fast as builtin "while" command for loops with 23 # more than just a few iterations. 24 # 25 26 set len [llength $args] 27 if {$len !=2 && $len != 0} { 28 set proc [namespace current]::[lindex [info level 0] 0] 29 return -code error "wrong # args: should be \"$proc body\" or \"$proc body \[until|while\] test\"" 30 } 31 set test 0 32 foreach {whileOrUntil test} $args { 33 switch -exact -- $whileOrUntil { 34 "while" {} 35 "until" { set test !($test) } 36 default { 37 return -code error \ 38 "bad option \"$whileOrUntil\": must be until, or while" 39 } 40 } 41 break 42 } 43 44 # the first invocation of the body 45 set code [catch { uplevel 1 $body } result] 46 47 # decide what to do upon the return code: 48 # 49 # 0 - the body executed successfully 50 # 1 - the body raised an error 51 # 2 - the body invoked [return] 52 # 3 - the body invoked [break] 53 # 4 - the body invoked [continue] 54 # everything else - return and pass on the results 55 # 56 switch -exact -- $code { 57 0 {} 58 1 { 59 return -errorinfo [ErrorInfoAsCaller uplevel do] \ 60 -errorcode $::errorCode -code error $result 61 } 62 3 { 63 # FRINK: nocheck 64 return 65 } 66 4 {} 67 default { 68 return -code $code $result 69 } 70 } 71 # the rest of the loop 72 set code [catch {uplevel 1 [list while $test $body]} result] 73 if {$code == 1} { 74 return -errorinfo [ErrorInfoAsCaller while do] \ 75 -errorcode $::errorCode -code error $result 76 } 77 return -code $code $result 78 79 } 80 81} 82