for.test
上传用户:rrhhcc
上传日期:2015-12-11
资源大小:54129k
文件大小:23k
源码类别:

通讯编程

开发平台:

Visual C++

  1. # Commands covered:  for, continue, break
  2. #
  3. # This file contains a collection of tests for one or more of the Tcl
  4. # built-in commands.  Sourcing this file into Tcl runs the tests and
  5. # generates output for errors.  No output means no errors were found.
  6. #
  7. # Copyright (c) 1996 Sun Microsystems, Inc.
  8. #
  9. # See the file "license.terms" for information on usage and redistribution
  10. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11. #
  12. # RCS: @(#) $Id: for.test,v 1.9 2001/12/06 10:59:18 dkf Exp $
  13. if {[lsearch [namespace children] ::tcltest] == -1} {
  14.     package require tcltest
  15.     namespace import -force ::tcltest::*
  16. }
  17. # Basic "for" operation.
  18. test for-1.1 {TclCompileForCmd: missing initial command} {
  19.     list [catch {for} msg] $msg
  20. } {1 {wrong # args: should be "for start test next command"}}
  21. test for-1.2 {TclCompileForCmd: error in initial command} {
  22.     list [catch {for {set}} msg] $msg $errorInfo
  23. } {1 {wrong # args: should be "for start test next command"} {wrong # args: should be "for start test next command"
  24.     while compiling
  25. "for {set}"}}
  26. catch {unset i}
  27. test for-1.3 {TclCompileForCmd: missing test expression} {
  28.     catch {for {set i 0}} msg
  29.     set msg
  30. } {wrong # args: should be "for start test next command"}
  31. test for-1.4 {TclCompileForCmd: error in test expression} {
  32.     catch {for {set i 0} {$i<}} msg
  33.     set errorInfo
  34. } {wrong # args: should be "for start test next command"
  35.     while compiling
  36. "for {set i 0} {$i<}"}
  37. test for-1.5 {TclCompileForCmd: test expression is enclosed in quotes} {
  38.     set i 0
  39.     for {} "$i > 5" {incr i} {}
  40. } {}
  41. test for-1.6 {TclCompileForCmd: missing "next" command} {
  42.     catch {for {set i 0} {$i < 5}} msg
  43.     set msg
  44. } {wrong # args: should be "for start test next command"}
  45. test for-1.7 {TclCompileForCmd: missing command body} {
  46.     catch {for {set i 0} {$i < 5} {incr i}} msg
  47.     set msg
  48. } {wrong # args: should be "for start test next command"}
  49. test for-1.8 {TclCompileForCmd: error compiling command body} {
  50.     catch {for {set i 0} {$i < 5} {incr i} {set}} msg
  51.     set errorInfo
  52. } {wrong # args: should be "set varName ?newValue?"
  53.     while compiling
  54. "set"
  55.     ("for" body line 1)
  56.     while compiling
  57. "for {set i 0} {$i < 5} {incr i} {set}"}
  58. catch {unset a}
  59. test for-1.9 {TclCompileForCmd: simple command body} {
  60.     set a {}
  61.     for {set i 1} {$i<6} {set i [expr $i+1]} {
  62. if $i==4 break
  63. set a [concat $a $i]
  64.     }
  65.     set a
  66. } {1 2 3}
  67. test for-1.10 {TclCompileForCmd: command body in quotes} {
  68.     set a {}
  69.     for {set i 1} {$i<6} {set i [expr $i+1]} "append a x"
  70.     set a
  71. } {xxxxx}
  72. test for-1.11 {TclCompileForCmd: computed command body} {
  73.     catch {unset x1}
  74.     catch {unset bb}
  75.     catch {unset x2}
  76.     set x1 {append a x1; }
  77.     set bb {break}
  78.     set x2 {; append a x2}
  79.     set a {}
  80.     for {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2
  81.     set a
  82. } {x1}
  83. test for-1.12 {TclCompileForCmd: error in "next" command} {
  84.     catch {for {set i 0} {$i < 5} {set} {puts $i}} msg
  85.     set errorInfo
  86. } {wrong # args: should be "set varName ?newValue?"
  87.     while compiling
  88. "set"
  89.     ("for" loop-end command)
  90.     while compiling
  91. "for {set i 0} {$i < 5} {set} {puts $i}"}
  92. test for-1.13 {TclCompileForCmd: long command body} {
  93.     set a {}
  94.     for {set i 1} {$i<6} {set i [expr $i+1]} {
  95. if $i==4 break
  96. if $i>5 continue
  97. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  98.     catch {set a $a} msg
  99.     catch {incr i 5} msg
  100.     catch {incr i -5} msg
  101. }
  102. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  103.     catch {set a $a} msg
  104.     catch {incr i 5} msg
  105.     catch {incr i -5} msg
  106. }
  107. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  108.     catch {set a $a} msg
  109.     catch {incr i 5} msg
  110.     catch {incr i -5} msg
  111. }
  112. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  113.     catch {set a $a} msg
  114.     catch {incr i 5} msg
  115.     catch {incr i -5} msg
  116. }
  117. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  118.     catch {set a $a} msg
  119.     catch {incr i 5} msg
  120.     catch {incr i -5} msg
  121. }
  122. set a [concat $a $i]
  123.     }
  124.     set a
  125. } {1 2 3}
  126. test for-1.14 {TclCompileForCmd: for command result} {
  127.     set a [for {set i 0} {$i < 5} {incr i} {}]
  128.     set a
  129. } {}
  130. test for-1.15 {TclCompileForCmd: for command result} {
  131.     set a [for {set i 0} {$i < 5} {incr i} {if $i==3 break}]
  132.     set a
  133. } {}
  134. # Check "for" and "continue".
  135. test for-2.1 {TclCompileContinueCmd: arguments after "continue"} {
  136.     catch {continue foo} msg
  137.     set msg
  138. } {wrong # args: should be "continue"}
  139. test for-2.2 {TclCompileContinueCmd: continue result} {
  140.     catch continue
  141. } 4
  142. test for-2.3 {continue tests} {
  143.     set a {}
  144.     for {set i 1} {$i <= 4} {set i [expr $i+1]} {
  145. if {$i == 2} continue
  146. set a [concat $a $i]
  147.     }
  148.     set a
  149. } {1 3 4}
  150. test for-2.4 {continue tests} {
  151.     set a {}
  152.     for {set i 1} {$i <= 4} {set i [expr $i+1]} {
  153. if {$i != 2} continue
  154. set a [concat $a $i]
  155.     }
  156.     set a
  157. } {2}
  158. test for-2.5 {continue tests, nested loops} {
  159.     set msg {}
  160.     for {set i 1} {$i <= 4} {incr i} {
  161. for {set a 1} {$a <= 2} {incr a} {
  162.             if {$i>=2 && $a>=2} continue
  163.             set msg [concat $msg "$i.$a"]
  164.         }
  165.     }
  166.     set msg
  167. } {1.1 1.2 2.1 3.1 4.1}
  168. test for-2.6 {continue tests, long command body} {
  169.     set a {}
  170.     for {set i 1} {$i<6} {set i [expr $i+1]} {
  171. if $i==2 continue
  172. if $i==4 break
  173. if $i>5 continue
  174. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  175.     catch {set a $a} msg
  176.     catch {incr i 5} msg
  177.     catch {incr i -5} msg
  178. }
  179. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  180.     catch {set a $a} msg
  181.     catch {incr i 5} msg
  182.     catch {incr i -5} msg
  183. }
  184. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  185.     catch {set a $a} msg
  186.     catch {incr i 5} msg
  187.     catch {incr i -5} msg
  188. }
  189. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  190.     catch {set a $a} msg
  191.     catch {incr i 5} msg
  192.     catch {incr i -5} msg
  193. }
  194. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  195.     catch {set a $a} msg
  196.     catch {incr i 5} msg
  197.     catch {incr i -5} msg
  198. }
  199. set a [concat $a $i]
  200.     }
  201.     set a
  202. } {1 3}
  203. # Check "for" and "break".
  204. test for-3.1 {TclCompileBreakCmd: arguments after "break"} {
  205.     catch {break foo} msg
  206.     set msg
  207. } {wrong # args: should be "break"}
  208. test for-3.2 {TclCompileBreakCmd: break result} {
  209.     catch break
  210. } 3
  211. test for-3.3 {break tests} {
  212.     set a {}
  213.     for {set i 1} {$i <= 4} {incr i} {
  214. if {$i == 3} break
  215. set a [concat $a $i]
  216.     }
  217.     set a
  218. } {1 2}
  219. test for-3.4 {break tests, nested loops} {
  220.     set msg {}
  221.     for {set i 1} {$i <= 4} {incr i} {
  222. for {set a 1} {$a <= 2} {incr a} {
  223.             if {$i>=2 && $a>=2} break
  224.             set msg [concat $msg "$i.$a"]
  225.         }
  226.     }
  227.     set msg
  228. } {1.1 1.2 2.1 3.1 4.1}
  229. test for-3.5 {break tests, long command body} {
  230.     set a {}
  231.     for {set i 1} {$i<6} {set i [expr $i+1]} {
  232. if $i==2 continue
  233. if $i==5 break
  234. if $i>5 continue
  235. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  236.     catch {set a $a} msg
  237.     catch {incr i 5} msg
  238.     catch {incr i -5} msg
  239. }
  240. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  241.     catch {set a $a} msg
  242.     catch {incr i 5} msg
  243.     catch {incr i -5} msg
  244. }
  245. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  246.     catch {set a $a} msg
  247.     catch {incr i 5} msg
  248.     catch {incr i -5} msg
  249. }
  250. if $i==4 break
  251. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  252.     catch {set a $a} msg
  253.     catch {incr i 5} msg
  254.     catch {incr i -5} msg
  255. }
  256. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  257.     catch {set a $a} msg
  258.     catch {incr i 5} msg
  259.     catch {incr i -5} msg
  260. }
  261. set a [concat $a $i]
  262.     }
  263.     set a
  264. } {1 3}
  265. # A simplified version of exmh's mail formatting routine to stress "for",
  266. # "break", "while", and "if".
  267. proc formatMail {} {
  268.     array set lines {
  269.         0 {Return-path: george@tcl} 
  270.         1 {Return-path: <george@tcl>} 
  271.         2 {Received: from tcl by tcl.Somewhere.COM (SMI-8.6/SMI-SVR4)} 
  272.         3 { id LAA10027; Wed, 11 Sep 1996 11:14:53 -0700} 
  273.         4 {Message-id: <199609111814.LAA10027@tcl.Somewhere.COM>} 
  274.         5 {X-mailer: exmh version 1.6.9 8/22/96} 
  275.         6 {Mime-version: 1.0} 
  276.         7 {Content-type: text/plain; charset=iso-8859-1} 
  277.         8 {Content-transfer-encoding: quoted-printable} 
  278.         9 {Content-length: 2162} 
  279.         10 {To: fred} 
  280.         11 {Subject: tcl7.6} 
  281.         12 {Date: Wed, 11 Sep 1996 11:14:53 -0700} 
  282.         13 {From: George <george@tcl>} 
  283.         14 {The Tcl 7.6 and Tk 4.2 releases} 
  284.         15 {} 
  285.         16 {This page contains information about Tcl 7.6 and Tk4.2, which are the most recent} 
  286.         17 {releases of the Tcl scripting language and the Tk toolkit. The first beta versions of these} 
  287.         18 {releases were released on August 30, 1996. These releases contain only minor changes,} 
  288.         19 {so we hope to have only a single beta release and to go final in early October, 1996. } 
  289.         20 {} 
  290.         21 {} 
  291.         22 {What's new } 
  292.         23 {} 
  293.         24 {The most important changes in the releases are summarized below. See the README} 
  294.         25 {and changes files in the distributions for more complete information on what has} 
  295.         26 {changed, including both feature changes and bug fixes. } 
  296.         27 {} 
  297.         28 {     There are new options to the file command for copying files (file copy),} 
  298.         29 {     deleting files and directories (file delete), creating directories (file} 
  299.         30 {     mkdir), and renaming files (file rename). } 
  300.         31 {     The implementation of exec has been improved greatly for Windows 95 and} 
  301.         32 {     Windows NT. } 
  302.         33 {     There is a new memory allocator for the Macintosh version, which should be} 
  303.         34 {     more efficient than the old one. } 
  304.         35 {     Tk's grid geometry manager has been completely rewritten. The layout} 
  305.         36 {     algorithm produces much better layouts than before, especially where rows or} 
  306.         37 {     columns were stretchable. } 
  307.         38 {     There are new commands for creating common dialog boxes:} 
  308.         39 {     tk_chooseColor, tk_getOpenFile, tk_getSaveFile and} 
  309.         40 {     tk_messageBox. These use native dialog boxes if they are available. } 
  310.         41 {     There is a new virtual event mechanism for handling events in a more portable} 
  311.         42 {     way. See the new command event. It also allows events (both physical and} 
  312.         43 {     virtual) to be generated dynamically. } 
  313.         44 {} 
  314.         45 {Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl 7.5 and Tk 4.1 except for} 
  315.         46 {changes in the C APIs for custom channel drivers. Scripts written for earlier releases} 
  316.         47 {should work on these new releases as well. } 
  317.         48 {} 
  318.         49 {Obtaining The Releases} 
  319.         50 {} 
  320.         51 {Binary Releases} 
  321.         52 {} 
  322.         53 {Pre-compiled releases are available for the following platforms: } 
  323.         54 {} 
  324.         55 {     Windows 3.1, Windows 95, and Windows NT: Fetch} 
  325.         56 {     ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then execute it. The file is a} 
  326.         57 {     self-extracting executable. It will install the Tcl and Tk libraries, the wish and} 
  327.         58 {     tclsh programs, and documentation. } 
  328.         59 {     Macintosh (both 68K and PowerPC): Fetch} 
  329.         60 {     ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. The file is in binhex format,} 
  330.         61 {     which is understood by Fetch, StuffIt, and many other Mac utilities. The} 
  331.         62 {     unpacked file is a self-installing executable: double-click on it and it will create a} 
  332.         63 {     folder containing all that you need to run Tcl and Tk. } 
  333.         64 {        UNIX (Solaris 2.* and SunOS, other systems soon to follow). Easy to install} 
  334.         65 {     binary packages are now for sale at the Sun Labs Tcl/Tk Shop. Check it out!} 
  335.     }
  336.     set result ""
  337.     set NL "
  338. "
  339.     set tag {level= type=text/plain part=0 sel Charset}
  340.     set ix [lsearch -regexp $tag text/enriched]
  341.     if {$ix < 0} {
  342. set ranges {}
  343. set quote 0
  344.     }
  345.     set breakrange {6.42 78.0}
  346.     set F1 [lindex $breakrange 0]
  347.     set F2 [lindex $breakrange 1]
  348.     set breakrange [lrange $breakrange 2 end]
  349.     if {[string length $F1] == 0} {
  350. set F1 -1
  351. set break 0
  352.     } else {
  353. set break 1
  354.     }
  355.     set xmailer 0
  356.     set inheaders 1
  357.     set last [array size lines]
  358.     set plen 2
  359.     for {set L 1} {$L < $last} {incr L} {
  360. set line $lines($L)
  361. if {$inheaders} {
  362.     # Blank or empty line terminates headers
  363.     # Leading --- terminates headers
  364.     if {[regexp {^[  ]*$} $line] || [regexp {^--+} $line]} {
  365. set inheaders 0
  366.     }
  367.     if {[regexp -nocase {^x-mailer:} $line]} {
  368. continue
  369.     }
  370. }
  371. if $inheaders {
  372.     set limit 55
  373. } else {
  374.     set limit 55
  375.     # Decide whether or not to break the body line
  376.     if {$plen > 0} {
  377. if {[string first {> } $line] == 0} {
  378.     # This is quoted text from previous message, don't reformat
  379.     append result $line $NL
  380.     if {$quote && !$inheaders} {
  381. # Fix from <sarr@umich.edu> to handle text/enriched
  382. if {$L > $L1 && $L < $L2 && $line != {}} {
  383.     # enriched requires two newlines for each one.
  384.     append result $NL
  385. } elseif {$L > $L2} {
  386.     set L1 [lindex $ranges 0]
  387.     set L2 [lindex $ranges 1]
  388.     set ranges [lrange $ranges 2 end]
  389.     set quote [llength $L1]
  390. }
  391.     }
  392.     continue
  393. }
  394.     }
  395.     if {$F1 < 0} {
  396. # Nothing left to format
  397. append result $line $NL
  398. continue
  399.     } elseif {$L < $F1} {
  400. # Not yet to formatted block
  401. append result $line $NL
  402. continue
  403.     } elseif {$L > $F2} {
  404. # Past formatted block
  405. set F1 [lindex $breakrange 0]
  406. set F2 [lindex $breakrange 1]
  407. set breakrange [lrange $breakrange 2 end]
  408. append result $line $NL
  409. if {[string length $F1] == 0} {
  410.     set F1 -1
  411. }
  412. continue
  413.     }
  414. }
  415. set climit [expr $limit-1]
  416. set cutoff 50
  417. set continuation 0
  418. while {[string length $line] > $limit} {
  419.     for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} {
  420. set char [string index $line $c]
  421. if {$char == " " || $char == "t"} {
  422.     break
  423. }
  424. if {$char == ">"} { ;# Hack for enriched formatting
  425.     break
  426. }
  427.     }
  428.     if {$c < $cutoff} {
  429. if {! $inheaders} {
  430.     set c [expr $limit-1]
  431. } else {
  432.     set c [string length $line]
  433. }
  434.     }
  435.     set newline [string range $line 0 $c]
  436.     if {! $continuation} {
  437. append result $newline $NL
  438.     } else {
  439. append result  $newline $NL
  440.     }
  441.     incr c
  442.     set line [string trimright [string range $line $c end]]
  443.     if {$inheaders} {
  444. set continuation 1
  445. set limit $climit
  446.     }
  447. }
  448. if {$continuation} {
  449.     if {[string length $line] != 0} {
  450. append result  $line $NL
  451.     }
  452. } else {
  453.     append result $line $NL
  454.     if {$quote && !$inheaders} {
  455. if {$L > $L1 && $L < $L2 && $line != {}} {
  456.     # enriched requires two newlines for each one.
  457.     append result "" $NL
  458. } elseif {$L > $L2} {
  459.     set L1 [lindex $ranges 0]
  460.     set L2 [lindex $ranges 1]
  461.     set ranges [lrange $ranges 2 end]
  462.     set quote [llength $L1]
  463. }
  464.     }
  465. }
  466.     }
  467.     return $result
  468. }
  469. test for-3.6 {break tests} {
  470.     formatMail
  471. } {Return-path: <george@tcl>
  472. Received: from tcl by tcl.Somewhere.COM (SMI-8.6/SMI-SVR4)
  473. id LAA10027; Wed, 11 Sep 1996 11:14:53 -0700
  474. Message-id: <199609111814.LAA10027@tcl.Somewhere.COM>
  475. Mime-version: 1.0
  476. Content-type: text/plain; charset=iso-8859-1
  477. Content-transfer-encoding: quoted-printable
  478. Content-length: 2162
  479. To: fred
  480. Subject: tcl7.6
  481. Date: Wed, 11 Sep 1996 11:14:53 -0700
  482. From: George <george@tcl>
  483. The Tcl 7.6 and Tk 4.2 releases
  484. This page contains information about Tcl 7.6 and Tk4.2,
  485.  which are the most recent
  486. releases of the Tcl scripting language and the Tk toolk
  487. it. The first beta versions of these
  488. releases were released on August 30, 1996. These releas
  489. es contain only minor changes,
  490. so we hope to have only a single beta release and to 
  491. go final in early October, 1996.
  492. What's new 
  493. The most important changes in the releases are summariz
  494. ed below. See the README
  495. and changes files in the distributions for more complet
  496. e information on what has
  497. changed, including both feature changes and bug fixes. 
  498.      There are new options to the file command for 
  499. copying files (file copy),
  500.      deleting files and directories (file delete), 
  501. creating directories (file
  502.      mkdir), and renaming files (file rename). 
  503.      The implementation of exec has been improved great
  504. ly for Windows 95 and
  505.      Windows NT. 
  506.      There is a new memory allocator for the Macintosh 
  507. version, which should be
  508.      more efficient than the old one. 
  509.      Tk's grid geometry manager has been completely 
  510. rewritten. The layout
  511.      algorithm produces much better layouts than before
  512. , especially where rows or
  513.      columns were stretchable. 
  514.      There are new commands for creating common dialog 
  515. boxes:
  516.      tk_chooseColor, tk_getOpenFile, tk_getSaveFile and
  517.      tk_messageBox. These use native dialog boxes if 
  518. they are available.
  519.      There is a new virtual event mechanism for handlin
  520. g events in a more portable
  521.      way. See the new command event. It also allows 
  522. events (both physical and
  523.      virtual) to be generated dynamically. 
  524. Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl 
  525. 7.5 and Tk 4.1 except for
  526. changes in the C APIs for custom channel drivers. Scrip
  527. ts written for earlier releases
  528. should work on these new releases as well. 
  529. Obtaining The Releases
  530. Binary Releases
  531. Pre-compiled releases are available for the following 
  532. platforms:
  533.      Windows 3.1, Windows 95, and Windows NT: Fetch
  534.      ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then 
  535. execute it. The file is a
  536.      self-extracting executable. It will install the 
  537. Tcl and Tk libraries, the wish and
  538.      tclsh programs, and documentation. 
  539.      Macintosh (both 68K and PowerPC): Fetch
  540.      ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. 
  541. The file is in binhex format,
  542.      which is understood by Fetch, StuffIt, and many 
  543. other Mac utilities. The
  544.      unpacked file is a self-installing executable: 
  545. double-click on it and it will create a
  546.      folder containing all that you need to run Tcl 
  547. and Tk.
  548.         UNIX (Solaris 2.* and SunOS, other systems 
  549. soon to follow). Easy to install
  550.      binary packages are now for sale at the Sun Labs 
  551. Tcl/Tk Shop. Check it out!
  552. }
  553. # Check that "break" resets the interpreter's result
  554. test for-4.1 {break must reset the interp result} {
  555.     catch {
  556.         set z GLOBTESTDIR/dir2/file2.c
  557.         if [string match GLOBTESTDIR/dir2/* $z] {
  558.             break
  559.         }
  560.     } j
  561.     set j
  562. } {}
  563. # Test for incorrect "double evaluation" semantics
  564. test for-5.1 {possible delayed substitution of increment command} {
  565.     # Increment should be 5, and lappend should always append $a
  566.     catch {unset a}
  567.     catch {unset i}
  568.     set a 5
  569.     set i {}
  570.     for {set a 1} {$a < 12} "incr a $a" {lappend i $a}
  571.     set i
  572. } {1 6 11}
  573. test for-5.2 {possible delayed substitution of increment command} {
  574.     # Increment should be 5, and lappend should always append $a
  575.     catch {rename p ""}
  576.     proc p {} {
  577. set a 5
  578. set i {}
  579. for {set a 1} {$a < 12} "incr a $a" {lappend i $a}
  580. set i
  581.     }
  582.     p
  583. } {1 6 11}
  584. test for-5.3 {possible delayed substitution of body command} {
  585.     # Increment should be $a, and lappend should always append 5
  586.     set a 5
  587.     set i {}
  588.     for {set a 1} {$a < 12} {incr a $a} "lappend i $a"
  589.     set i
  590. } {5 5 5 5}
  591. test for-5.4 {possible delayed substitution of body command} {
  592.     # Increment should be $a, and lappend should always append 5
  593.     catch {rename p ""}
  594.     proc p {} {
  595. set a 5
  596. set i {}
  597. for {set a 1} {$a < 12} {incr a $a} "lappend i $a"
  598. set i
  599.     }
  600.     p
  601. } {5 5 5 5}
  602. # In the following tests we need to bypass the bytecode compiler by
  603. # substituting the command from a variable.  This ensures that command
  604. # procedure is invoked directly.
  605. test for-6.1 {Tcl_ForObjCmd: number of args} {
  606.     set z for
  607.     catch {$z} msg
  608.     set msg
  609. } {wrong # args: should be "for start test next command"}
  610. test for-6.2 {Tcl_ForObjCmd: number of args} {
  611.     set z for
  612.     catch {$z {set i 0}} msg
  613.     set msg
  614. } {wrong # args: should be "for start test next command"}
  615. test for-6.3 {Tcl_ForObjCmd: number of args} {
  616.     set z for
  617.     catch {$z {set i 0} {$i < 5}} msg
  618.     set msg
  619. } {wrong # args: should be "for start test next command"}
  620. test for-6.4 {Tcl_ForObjCmd: number of args} {
  621.     set z for
  622.     catch {$z {set i 0} {$i < 5} {incr i}} msg
  623.     set msg
  624. } {wrong # args: should be "for start test next command"}
  625. test for-6.5 {Tcl_ForObjCmd: number of args} {
  626.     set z for
  627.     catch {$z {set i 0} {$i < 5} {incr i} {body} extra} msg
  628.     set msg
  629. } {wrong # args: should be "for start test next command"}
  630. test for-6.6 {Tcl_ForObjCmd: error in initial command} {
  631.     set z for
  632.     list [catch {$z {set} {$i < 5} {incr i} {body}} msg] $msg $errorInfo
  633. } {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
  634.     while compiling
  635. "set"
  636.     ("for" initial command)
  637.     invoked from within
  638. "$z {set} {$i < 5} {incr i} {body}"}}
  639. test for-6.7 {Tcl_ForObjCmd: error in test expression} {
  640.     set z for
  641.     list [catch {$z {set i 0} {i < 5} {incr i} {body}} msg] $msg $errorInfo
  642. } {1 {syntax error in expression "i < 5": variable references require preceding $} {syntax error in expression "i < 5": variable references require preceding $
  643.     while executing
  644. "$z {set i 0} {i < 5} {incr i} {body}"}}
  645. test for-6.8 {Tcl_ForObjCmd: test expression is enclosed in quotes} {
  646.     set z for
  647.     set i 0
  648.     $z {set i 6} "$i > 5" {incr i} {set y $i}
  649.     set i
  650. } 6
  651. test for-6.9 {Tcl_ForObjCmd: error executing command body} {
  652.     set z for
  653.     catch {$z {set i 0} {$i < 5} {incr i} {set}} msg
  654.     set errorInfo
  655. } {wrong # args: should be "set varName ?newValue?"
  656.     while compiling
  657. "set"
  658.     ("for" body line 1)
  659.     invoked from within
  660. "$z {set i 0} {$i < 5} {incr i} {set}"}
  661. test for-6.10 {Tcl_ForObjCmd: simple command body} {
  662.     set z for
  663.     set a {}
  664.     $z {set i 1} {$i<6} {set i [expr $i+1]} {
  665. if $i==4 break
  666. set a [concat $a $i]
  667.     }
  668.     set a
  669. } {1 2 3}
  670. test for-6.11 {Tcl_ForObjCmd: command body in quotes} {
  671.     set z for
  672.     set a {}
  673.     $z {set i 1} {$i<6} {set i [expr $i+1]} "append a x"
  674.     set a
  675. } {xxxxx}
  676. test for-6.12 {Tcl_ForObjCmd: computed command body} {
  677.     set z for
  678.     catch {unset x1}
  679.     catch {unset bb}
  680.     catch {unset x2}
  681.     set x1 {append a x1; }
  682.     set bb {break}
  683.     set x2 {; append a x2}
  684.     set a {}
  685.     $z {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2
  686.     set a
  687. } {x1}
  688. test for-6.13 {Tcl_ForObjCmd: error in "next" command} {
  689.     set z for
  690.     catch {$z {set i 0} {$i < 5} {set} {set j 4}} msg
  691.     set errorInfo
  692. } {wrong # args: should be "set varName ?newValue?"
  693.     while compiling
  694. "set"
  695.     ("for" loop-end command)
  696.     invoked from within
  697. "$z {set i 0} {$i < 5} {set} {set j 4}"}
  698. test for-6.14 {Tcl_ForObjCmd: long command body} {
  699.     set z for
  700.     set a {}
  701.     $z {set i 1} {$i<6} {set i [expr $i+1]} {
  702. if $i==4 break
  703. if $i>5 continue
  704. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  705.     catch {set a $a} msg
  706.     catch {incr i 5} msg
  707.     catch {incr i -5} msg
  708. }
  709. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  710.     catch {set a $a} msg
  711.     catch {incr i 5} msg
  712.     catch {incr i -5} msg
  713. }
  714. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  715.     catch {set a $a} msg
  716.     catch {incr i 5} msg
  717.     catch {incr i -5} msg
  718. }
  719. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  720.     catch {set a $a} msg
  721.     catch {incr i 5} msg
  722.     catch {incr i -5} msg
  723. }
  724. if {$i>6 && $tcl_platform(machine)=="xxx"} {
  725.     catch {set a $a} msg
  726.     catch {incr i 5} msg
  727.     catch {incr i -5} msg
  728. }
  729. set a [concat $a $i]
  730.     }
  731.     set a
  732. } {1 2 3}
  733. test for-6.15 {Tcl_ForObjCmd: for command result} {
  734.     set z for
  735.     set a [$z {set i 0} {$i < 5} {incr i} {}]
  736.     set a
  737. } {}
  738. test for-6.16 {Tcl_ForObjCmd: for command result} {
  739.     set z for
  740.     set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}]
  741.     set a
  742. } {}
  743. # cleanup
  744. ::tcltest::cleanupTests
  745. return