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