#121 Enhanced do...while|until [prefix] [suffix] Control Structur

[Anonymous]

This one came out of my customer demand! Pat Thoyts
and Donal K. Fellows suggested me to submit it here.

The submission is in form of a TIP. Please search
for "sample implementation" to get to the code.

Please also see at the end of it, untried version of tests.
Please search for "tests for do" to get to the code

TIP
Title
Enhanced do...while|until [prefix] [suffix] Control
Structure
Version
$Revision: 1.4
Author
Bhushit Joshipura
State
Draft
Type
Project
Vote
Pending
Created
20-Jan-2004
Keywords
control structure, do, while, until, prefix, suffix
~ Abstract
This TIP proposes the introduction of an enhancement
on do...while|until control structure already present in
TCLLib. It proposes to add prefix statement list and
suffix statement list to prepend and append to
statement body of do...while|until for the "while" part
(second loop onwards) of the loop.
~ Rationale
Theoretically only two controls - if and goto - are
sufficient to implement all algorithms. However,
languages provide more control structures for better
representation of algorithms.
do...while|until is a useful structure in itself for parsing,
file reading etc. With little pain, a while loop does the
job too. However, when it comes to nesting,
do...while|until into another, equivalent while loop starts
becoming clumsier.
In situations where do...while|until is used in testing, if
the statement body of do...while|until changes state of
entity being tested, next iteration is bound to have side
effects. At that time, proposed prefix and suffix
statements come handy.
While it is still possible to handle all of these in a while
loop, nesting becomes a nightmare.
Proposed solution is more elegant, in spirit of
do...while|until's spirit of treating first pass specially.
~ Implementation in Other Languages
C, C++, Java, Pascal have do...while. Perl has
do...while|until. Python does not have any equivalent.
~ Grammar and Behavior
|do {
|
|} while|until { } [ prefix { }] [suffix { statements2>}]
1. are executed
2. while|until is evaluated
3. while associated are true ( or until are false )
3.1 are executed
It is necessary to specify one and only one of "while"
or "until" with proper condition block following it.
~Sample Invocations
set x 1
|do {
| puts "Hello world!"
| incr x
|} until { $x > 3 } prefix {
| puts "prefix begin"
| puts $x
| puts "prefix end"
|} suffix {
| puts "suffix begin"
| puts $x
| puts "suffix end"
|}
~Contrast
Contrast above code with its while loop equivalent
|set x 1
|set firsttime "yes"
|while { $x <= 3 } {
| if { $firsttime == "no" } {
| puts "prefix begin"
| puts $x
| puts "prefix end"
| }
| puts "Hello world!"
| incr x
| if { $firsttime == "no" } {
| puts "suffix begin"
| puts $x
| puts "suffix end"
| }
| set firsttime "no"
|}
~Sample Implementation
|# do.tcl --
|#
|# Tcl implementation of a "do ... while|until" loop.
|# Once first iteration gets over, body can be
augmented using prefix or suffix
|#
|# Originally written for the "Texas Tcl Shootout"
programming contest
|# at the 2000 Tcl Conference in Austin/Texas.
|#
|# Copyright for TCLLib implementation was
|# Copyright (c) 2001 by Reinhard Max
|#
|# Added prefix and suffix by Bhushit Joshipura,
December 15, 2003
|# Bhushit does not know what happens to copyrights
|#
|# See the file "license.terms" for information on usage
and redistribution
|# of this file, and for a DISCLAIMER OF ALL
WARRANTIES.
|#
|#
|namespace eval ::control {
|
| proc do {body args} {
|
| #
| # Implements a "do body while|until test [ [prefix |
suffix] bodyparts ]" loop
| #
| # It is almost as fast as builtin "while" command for
loops with
| # more than just a few iterations.
| #
|
| set len [llength $args]
| if {$len != 6 && $len != 4 && $len !=2 && $len != 0} {
| set proc [namespace current]::[lindex [info level 0]
0]
| return -code error "wrong # args: should be \"$proc
body\" or \"$proc body \[until|while\] test\" or \"$proc
body \[until|while\] test \[ \[ prefix | suffix \] bodyparts
\]"
| }
| set test 0
| set bodyprefix ""
| set bodysuffix ""
| set whileOrUntil ""
|
| foreach { argument value } $args {
| switch -exact -- $argument {
| "while" {
| if { $whileOrUntil == "" } {
| set whileOrUntil $argument
| set test $value
| } else {
| return -code error \
| "\"$argument\" found after \"$whileOrUntil\""
| }
| }
| "until" {
| if { $whileOrUntil == "" } {
| set whileOrUntil $argument
| set test !($value)
| } else {
| return -code error \
| "\"$argument\" found after \"$whileOrUntil\""
| }
| }
| "prefix" {
| # last of prefix will be considered
| set bodyprefix $value
| }
| "suffix" {
| # last of suffix will be considered
| set bodysuffix $value
| }
| default {
| return -code error \
| "bad option \"$whileOrUntil\": must be until, while,
prefix or suffix"
| }
| }
| }
|
| # the first invocation of the body
| set code [catch { uplevel 1 $body } result]
|
| # decide what to do upon the return code:
| #
| # 0 - the body executed successfully
| # 1 - the body raised an error
| # 2 - the body invoked [return]
| # 3 - the body invoked [break]
| # 4 - the body invoked [continue]
| # everything else - return and pass on the results
| #
| switch -exact -- $code {
| 0 {}
| 1 {
| return -errorinfo [ErrorInfoAsCaller uplevel do] \
| -errorcode $::errorCode -code error $result
| }
| 3 {
| # FRINK: nocheck
| return
| }
| 4 {}
| default {
| return -code $code $result
| }
| }
|
| set body [ format "%s\n%s\n%s" $bodyprefix $body
$bodysuffix ]
|
| # the rest of the loop
| set code [catch {uplevel 1 [list while $test $body]}
result]
| if {$code == 1} {
| return -errorinfo [ErrorInfoAsCaller while do] \
| -errorcode $::errorCode -code error $result
| }
| return -code $code $result
|
| }
|}
~Copyright
This document is placed in public domain.

Tests for do

# do.test --
#
# Tests for [control::do]
#
# RCS: @(#) $Id: do.test,v 1.6 2003/05/01 22:40:13
patthoyts Exp $
#

package forget control
catch {namespace delete control}

# Direct loading of provide script -- support testing even
# when not installed. And be sure we test the local copy
# and not some later version that may be installed.
source [file join [file dirname [info script]] control.tcl]
namespace import ::control::do

package require tcltest
namespace import -force
tcltest::test ::tcltest::cleanupTests

# This constraint restricts certain tests to run on tcl
8.3+
if {[package vsatisfies [package provide tcltest] 2.0]} {
# tcltest2.0+ has an API to specify a test constraint
::tcltest::testConstraint tcl8.3plus \
[expr {[package vsatisfies [package provide Tcl]
8.3]}]
} else {
# In tcltest1.0, a global variable needs to be set
directly.
set ::tcltest::testConstraints(tcl8.3plus) \
[expr {[package vsatisfies [package provide Tcl]
8.3]}]
}

# ----------------------------------------
test {do-1.0} {do ... while} {
set x 0
do {incr x} while {$x < 10}
set x
} 10

# ----------------------------------------
test {do-1.1} {do ... until} {
set x 0
do {incr x} until {$x > 10}
set x
} 11

# ----------------------------------------
test {do-1.2} {break} {
set x 0
do {
incr x
if {$x == 5} {break}
} until {$x == 10}
set x
} 5

# ----------------------------------------
test {do-1.3} {continue} {

set x 0
set xx [list]
do {
incr x
if {$x == 5} {continue}
lappend xx $x
} until {$x == 10}
set xx
} {1 2 3 4 6 7 8 9 10}

# ----------------------------------------
test {do-1.4} {error} {
catch {
set x 0
do {
incr x
if {$x == 5} {foo}
} while {$x < 10}
} result
list $x $result
} {5 {invalid command name "foo"}}

# ----------------------------------------
test {do-1.5} {return} {
proc foo {} {
set x 0
do {
incr x
if {$x == 5} { return $x }
} while {$x < 10}
}
set result [foo]
rename foo ""
set result
} 5

# ----------------------------------------
test {do-1.6} {break in the first loop} {
set x 0
do {
break
incr x
} while {$x < 10}
set x
} 0

# ----------------------------------------
test {do-1.7} {continue in the first loop} {
set x 0
set xx [list]
do {
incr x
if {$x == 1} {continue}
lappend xx $x
} until {$x == 10}
set xx
} {2 3 4 5 6 7 8 9 10}

# ----------------------------------------
test {do-1.8} {error in the first loop} {
set x 0
catch {
do {
foo
incr x
} until {$x == 10}
} result
list $x $result
} {0 {invalid command name "foo"}}

# ----------------------------------------
test {do-1.9} {[do ... while] with false condition} {
set x 0
do {
incr x
} while 0
set x
} 1

# ----------------------------------------
test do-1.10 {[do ... until] with true condition} {
set x 0
do {
incr x
} until 1
set x
} 1

# ----------------------------------------
test do-1.11 {third arg is neither while nor until} {
set x 0
catch {
do {
incr x
} foo 1
set x
} result
list $x $result
} {0 {bad option "foo": must be until, or while}}

# ----------------------------------------
test do-1.12 {stack traces for errors in the first
iteration} {
proc a {} b
proc b {} {do c while 1}
proc c {} d
catch a
set ::errorInfo
} {invalid command name "d"
while executing
"d"
(procedure "c" line 1)
invoked from within
"c"
("do" body line 1)
invoked from within
"do c while 1"
(procedure "b" line 1)
invoked from within
"b"
(procedure "a" line 1)
invoked from within
"a"}

# ----------------------------------------
test do-1.14 {stack traces for errors in subsequent
iterations} tcl8.3plus {
proc a {} b
proc b {} {
set i 10
do {
incr i -1
c $i
} while {$i}
}
proc c {i} {if {$i==5} e}
catch a
set ::errorInfo
} {invalid command name "e"
while executing
"e"
(procedure "c" line 1)
invoked from within
"c $i"
("do" body line 3)
invoked from within
"do {
incr i -1
c $i
} while {$i}"
(procedure "b" line 3)
invoked from within
"b"
(procedure "a" line 1)
invoked from within
"a"}

# ----------------------------------------
test do-2.0 {one-shot do} {
set x 0
do {incr x}
set x
} 1

# ----------------------------------------
test do-2.1 {one-shot do with break} {
set x 0
do {incr x; break; incr x}
set x
} 1

# ----------------------------------------
test do-2.2 {wrong no of arguments} {
set x 0
set res [catch {do {incr x} foo} ret]
list $x $res $errorInfo
} {0 1 {wrong # args: should be "::control::do body"
or "::control::do body [until|while] test"
while executing
"do {incr x} foo"}}

# ----------------------------------------
test do-2.3 {wrong no of arguments} {} {
set res [catch do]
if {[string match \
{no value given for parameter "body"
to "do"*} \
$::errorInfo]
} then {
set ::errorInfo {wrong # args: should be "do
body args"
while executing
"do"}
}
list $res $::errorInfo
} {1 {wrong # args: should be "do body args"
while executing
"do"}}

# ----------------------------------------
test do-2.4 {one-shot do with error} {
set x 0
set res [catch {do {
incr x
foo
incr x
}}]
list $x $res $::errorInfo
} {1 1 {invalid command name "foo"
while executing
"foo"
("do" body line 3)
invoked from within
"do {
incr x
foo
incr x
}"}}

cleanupTests

if {[info exists ::argv0] && $::argv0 == [info script]} {
# a proc that wastes some time
proc something {n} {
for {set i 0} {$i < $n} {incr i} {}
}

proc main {} {
# run it for the first time to get it byte compiled
something 1

set payload {
something 10
incr x
}
puts "\nComparing performance of do-while, do-
until and builtin while..."
set format "%-8s : %20s for %4d iteration(s)."
foreach c {1 10 5000} {
puts ""
foreach {descr script} {
{do while} {do $payload while {$x <
$c}}
{do until} {do $payload until {$x ==
$c}}
{while} {while {$x < $c} $payload}
} {
set x 0
puts [format $format $descr [lrange
[time $script 1] 0 1] $x]
}
}
}
main
}

# Local variables:
# mode: tcl
# End: