1# Commands covered: while 2# 3# This file contains a collection of tests for one or more of the Tcl built-in 4# commands. Sourcing this file into Tcl runs the tests and generates output 5# for errors. No output means no errors were found. 6# 7# Copyright © 1996 Sun Microsystems, Inc. 8# Copyright © 1998-1999 Scriptics Corporation. 9# 10# See the file "license.terms" for information on usage and redistribution of 11# this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 13if {"::tcltest" ni [namespace children]} { 14 package require tcltest 2.5 15 namespace import -force ::tcltest::* 16} 17 18# Basic "while" operation. 19 20catch {unset i} 21catch {unset a} 22 23test while-1.1 {TclCompileWhileCmd: missing test expression} -body { 24 while 25} -returnCodes error -result {wrong # args: should be "while test command"} 26test while-1.2 {TclCompileWhileCmd: error in test expression} -body { 27 set i 0 28 catch {while {$i<} break} 29 return $::errorInfo 30} -cleanup { 31 unset i 32} -match glob -result {*"while {$i<} break"} 33test while-1.3 {TclCompileWhileCmd: error in test expression} -body { 34 while {"a"+"b"} {error "loop aborted"} 35} -returnCodes error -result {can't use non-numeric string as operand of "+"} 36test while-1.4 {TclCompileWhileCmd: multiline test expr} -body { 37 set value 1 38 while {($tcl_platform(platform) != "foobar1") && \ 39 ($tcl_platform(platform) != "foobar2")} { 40 incr value 41 break 42 } 43 return $value 44} -cleanup { 45 unset value 46} -result {2} 47test while-1.5 {TclCompileWhileCmd: non-numeric boolean test expr} -body { 48 set value 1 49 while {"true"} { 50 incr value; 51 if {$value > 5} { 52 break; 53 } 54 } 55 return $value 56} -cleanup { 57 unset value 58} -result 6 59test while-1.6 {TclCompileWhileCmd: test expr is enclosed in quotes} { 60 set i 0 61 while "$i > 5" {} 62} {} 63test while-1.7 {TclCompileWhileCmd: missing command body} -body { 64 set i 0 65 while {$i < 5} 66} -returnCodes error -result {wrong # args: should be "while test command"} 67test while-1.8 {TclCompileWhileCmd: error compiling command body} -body { 68 set i 0 69 catch {while {$i < 5} {set}} 70 return $::errorInfo 71} -match glob -cleanup { 72 unset i 73} -result {wrong # args: should be "set varName ?newValue?" 74 while *ing 75"set"*} 76test while-1.9 {TclCompileWhileCmd: simple command body} -body { 77 set a {} 78 set i 1 79 while {$i<6} { 80 if {$i==4} break 81 set a [concat $a $i] 82 incr i 83 } 84 return $a 85} -cleanup { 86 unset a i 87} -result {1 2 3} 88test while-1.10 {TclCompileWhileCmd: command body in quotes} -body { 89 set a {} 90 set i 1 91 while {$i<6} "append a x; incr i" 92 return $a 93} -cleanup { 94 unset a i 95} -result {xxxxx} 96test while-1.11 {TclCompileWhileCmd: computed command body} -setup { 97 catch {unset x1} 98 catch {unset bb} 99 catch {unset x2} 100} -body { 101 set x1 {append a x1; } 102 set bb {break} 103 set x2 {; append a x2; incr i} 104 set a {} 105 set i 1 106 while {$i<6} $x1$bb$x2 107 return $a 108} -cleanup { 109 unset x1 bb x2 a i 110} -result {x1} 111test while-1.12 {TclCompileWhileCmd: long command body} -body { 112 set a {} 113 set i 1 114 while {$i<6} { 115 if {$i==4} break 116 if {$i>5} continue 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 if {$i>6 && $tcl_platform(machine)=="xxx"} { 123 catch {set a $a} msg 124 catch {incr i 5} msg 125 catch {incr i -5} msg 126 } 127 if {$i>6 && $tcl_platform(machine)=="xxx"} { 128 catch {set a $a} msg 129 catch {incr i 5} msg 130 catch {incr i -5} msg 131 } 132 if {$i>6 && $tcl_platform(machine)=="xxx"} { 133 catch {set a $a} msg 134 catch {incr i 5} msg 135 catch {incr i -5} msg 136 } 137 if {$i>6 && $tcl_platform(machine)=="xxx"} { 138 catch {set a $a} msg 139 catch {incr i 5} msg 140 catch {incr i -5} msg 141 } 142 set a [concat $a $i] 143 incr i 144 } 145 return $a 146} -cleanup { 147 unset a i 148} -result {1 2 3} 149test while-1.13 {TclCompileWhileCmd: while command result} -body { 150 set i 0 151 set a [while {$i < 5} {incr i}] 152 return $a 153} -cleanup { 154 unset a i 155} -result {} 156test while-1.14 {TclCompileWhileCmd: while command result} -body { 157 set i 0 158 set a [while {$i < 5} {if {$i==3} break; incr i}] 159 return $a 160} -cleanup { 161 unset a i 162} -result {} 163 164# Check "while" and "continue". 165 166test while-2.1 {continue tests} -body { 167 set a {} 168 set i 1 169 while {$i <= 4} { 170 incr i 171 if {$i == 3} continue 172 set a [concat $a $i] 173 } 174 return $a 175} -cleanup { 176 unset a i 177} -result {2 4 5} 178test while-2.2 {continue tests} -body { 179 set a {} 180 set i 1 181 while {$i <= 4} { 182 incr i 183 if {$i != 2} continue 184 set a [concat $a $i] 185 } 186 return $a 187} -cleanup { 188 unset a i 189} -result {2} 190test while-2.3 {continue tests, nested loops} -body { 191 set msg {} 192 set i 1 193 while {$i <= 4} { 194 incr i 195 set a 1 196 while {$a <= 2} { 197 incr a 198 if {$i>=3 && $a>=3} continue 199 set msg [concat $msg "$i.$a"] 200 } 201 } 202 return $msg 203} -cleanup { 204 unset a i msg 205} -result {2.2 2.3 3.2 4.2 5.2} 206test while-2.4 {continue tests, long command body} -body { 207 set a {} 208 set i 1 209 while {$i<6} { 210 if {$i==2} {incr i; continue} 211 if {$i==4} break 212 if {$i>5} continue 213 if {$i>6 && $tcl_platform(machine)=="xxx"} { 214 catch {set a $a} msg 215 catch {incr i 5} msg 216 catch {incr i -5} msg 217 } 218 if {$i>6 && $tcl_platform(machine)=="xxx"} { 219 catch {set a $a} msg 220 catch {incr i 5} msg 221 catch {incr i -5} msg 222 } 223 if {$i>6 && $tcl_platform(machine)=="xxx"} { 224 catch {set a $a} msg 225 catch {incr i 5} msg 226 catch {incr i -5} msg 227 } 228 if {$i>6 && $tcl_platform(machine)=="xxx"} { 229 catch {set a $a} msg 230 catch {incr i 5} msg 231 catch {incr i -5} msg 232 } 233 if {$i>6 && $tcl_platform(machine)=="xxx"} { 234 catch {set a $a} msg 235 catch {incr i 5} msg 236 catch {incr i -5} msg 237 } 238 set a [concat $a $i] 239 incr i 240 } 241 return $a 242} -cleanup { 243 unset a i 244} -result {1 3} 245 246# Check "while" and "break". 247 248test while-3.1 {break tests} -body { 249 set a {} 250 set i 1 251 while {$i <= 4} { 252 if {$i == 3} break 253 set a [concat $a $i] 254 incr i 255 } 256 return $a 257} -cleanup { 258 unset a i 259} -result {1 2} 260test while-3.2 {break tests, nested loops} -body { 261 set msg {} 262 set i 1 263 while {$i <= 4} { 264 set a 1 265 while {$a <= 2} { 266 if {$i>=2 && $a>=2} break 267 set msg [concat $msg "$i.$a"] 268 incr a 269 } 270 incr i 271 } 272 return $msg 273} -cleanup { 274 unset a i msg 275} -result {1.1 1.2 2.1 3.1 4.1} 276test while-3.3 {break tests, long command body} -body { 277 set a {} 278 set i 1 279 while {$i<6} { 280 if {$i==2} {incr i; continue} 281 if {$i==5} break 282 if {$i>5} continue 283 if {$i>6 && $tcl_platform(machine)=="xxx"} { 284 catch {set a $a} msg 285 catch {incr i 5} msg 286 catch {incr i -5} msg 287 } 288 if {$i>6 && $tcl_platform(machine)=="xxx"} { 289 catch {set a $a} msg 290 catch {incr i 5} msg 291 catch {incr i -5} msg 292 } 293 if {$i>6 && $tcl_platform(machine)=="xxx"} { 294 catch {set a $a} msg 295 catch {incr i 5} msg 296 catch {incr i -5} msg 297 } 298 if {$i==4} break 299 if {$i>6 && $tcl_platform(machine)=="xxx"} { 300 catch {set a $a} msg 301 catch {incr i 5} msg 302 catch {incr i -5} msg 303 } 304 if {$i>6 && $tcl_platform(machine)=="xxx"} { 305 catch {set a $a} msg 306 catch {incr i 5} msg 307 catch {incr i -5} msg 308 } 309 set a [concat $a $i] 310 incr i 311 } 312 return $a 313} -cleanup { 314 unset a i 315} -result {1 3} 316 317# Check "while" with computed command names. 318 319test while-4.1 {while and computed command names} -body { 320 set i 0 321 set z while 322 $z {$i < 10} { 323 incr i 324 } 325 return $i 326} -cleanup { 327 unset i z 328} -result 10 329test while-4.2 {while (not compiled): missing test expression} -body { 330 set z while 331 $z 332} -returnCodes error -cleanup { 333 unset z 334} -result {wrong # args: should be "while test command"} 335test while-4.3 {while (not compiled): error in test expression} -body { 336 set i 0 337 set z while 338 catch {$z {$i<} {set x 1}} 339 return $::errorInfo 340} -match glob -cleanup { 341 unset i z 342} -result {*"$z {$i<} {set x 1}"} 343test while-4.4 {while (not compiled): error in test expression} -body { 344 set z while 345 $z {"a"+"b"} {error "loop aborted"} 346} -returnCodes error -result {can't use non-numeric string as operand of "+"} 347test while-4.5 {while (not compiled): multiline test expr} -body { 348 set value 1 349 set z while 350 $z {($tcl_platform(platform) != "foobar1") && \ 351 ($tcl_platform(platform) != "foobar2")} { 352 incr value 353 break 354 } 355 return $value 356} -cleanup { 357 unset value z 358} -result {2} 359test while-4.6 {while (not compiled): non-numeric boolean test expr} -body { 360 set value 1 361 set z while 362 $z {"true"} { 363 incr value; 364 if {$value > 5} { 365 break; 366 } 367 } 368 return $value 369} -cleanup { 370 unset value z 371} -result 6 372test while-4.7 {while (not compiled): test expr is enclosed in quotes} -body { 373 set i 0 374 set z while 375 $z "$i > 5" {} 376} -cleanup { 377 unset i z 378} -result {} 379test while-4.8 {while (not compiled): missing command body} -body { 380 set i 0 381 set z while 382 $z {$i < 5} 383} -returnCodes error -cleanup { 384 unset i z 385} -result {wrong # args: should be "while test command"} 386test while-4.9 {while (not compiled): error compiling command body} -body { 387 set i 0 388 set z while 389 catch {$z {$i < 5} {set}} 390 set ::errorInfo 391} -match glob -cleanup { 392 unset i z 393} -result {wrong # args: should be "set varName ?newValue?" 394 while *ing 395"set" 396 ("while" body line 1) 397 invoked from within 398"$z {$i < 5} {set}"} 399test while-4.10 {while (not compiled): simple command body} -body { 400 set a {} 401 set i 1 402 set z while 403 $z {$i<6} { 404 if {$i==4} break 405 set a [concat $a $i] 406 incr i 407 } 408 return $a 409} -cleanup { 410 unset a i z 411} -result {1 2 3} 412test while-4.11 {while (not compiled): command body in quotes} -body { 413 set a {} 414 set i 1 415 set z while 416 $z {$i<6} "append a x; incr i" 417 return $a 418} -cleanup { 419 unset a i z 420} -result {xxxxx} 421test while-4.12 {while (not compiled): computed command body} -setup { 422 catch {unset x1} 423 catch {unset bb} 424 catch {unset x2} 425} -body { 426 set z while 427 set x1 {append a x1; } 428 set bb {break} 429 set x2 {; append a x2; incr i} 430 set a {} 431 set i 1 432 $z {$i<6} $x1$bb$x2 433 return $a 434} -cleanup { 435 unset z x1 bb x2 a i 436} -result {x1} 437test while-4.13 {while (not compiled): long command body} -body { 438 set a {} 439 set z while 440 set i 1 441 $z {$i<6} { 442 if {$i==4} break 443 if {$i>5} continue 444 if {$i>6 && $tcl_platform(machine)=="xxx"} { 445 catch {set a $a} msg 446 catch {incr i 5} msg 447 catch {incr i -5} msg 448 } 449 if {$i>6 && $tcl_platform(machine)=="xxx"} { 450 catch {set a $a} msg 451 catch {incr i 5} msg 452 catch {incr i -5} msg 453 } 454 if {$i>6 && $tcl_platform(machine)=="xxx"} { 455 catch {set a $a} msg 456 catch {incr i 5} msg 457 catch {incr i -5} msg 458 } 459 if {$i>6 && $tcl_platform(machine)=="xxx"} { 460 catch {set a $a} msg 461 catch {incr i 5} msg 462 catch {incr i -5} msg 463 } 464 if {$i>6 && $tcl_platform(machine)=="xxx"} { 465 catch {set a $a} msg 466 catch {incr i 5} msg 467 catch {incr i -5} msg 468 } 469 set a [concat $a $i] 470 incr i 471 } 472 return $a 473} -cleanup { 474 unset a i z 475} -result {1 2 3} 476test while-4.14 {while (not compiled): while command result} -body { 477 set i 0 478 set z while 479 set a [$z {$i < 5} {incr i}] 480 return $a 481} -cleanup { 482 unset a i z 483} -result {} 484test while-4.15 {while (not compiled): while command result} -body { 485 set i 0 486 set z while 487 set a [$z {$i < 5} {if {$i==3} break; incr i}] 488 return $a 489} -cleanup { 490 unset a i z 491} -result {} 492 493# Check "break" with computed command names. 494 495test while-5.1 {break and computed command names} -body { 496 set i 0 497 set z break 498 while 1 { 499 if {$i > 10} $z 500 incr i 501 } 502 return $i 503} -cleanup { 504 unset i z 505} -result 11 506test while-5.2 {break tests with computed command names} -body { 507 set a {} 508 set i 1 509 set z break 510 while {$i <= 4} { 511 if {$i == 3} $z 512 set a [concat $a $i] 513 incr i 514 } 515 return $a 516} -cleanup { 517 unset a i z 518} -result {1 2} 519test while-5.3 {break tests, nested loops with computed command names} -body { 520 set msg {} 521 set i 1 522 set z break 523 while {$i <= 4} { 524 set a 1 525 while {$a <= 2} { 526 if {$i>=2 && $a>=2} $z 527 set msg [concat $msg "$i.$a"] 528 incr a 529 } 530 incr i 531 } 532 return $msg 533} -cleanup { 534 unset a i z msg 535} -result {1.1 1.2 2.1 3.1 4.1} 536test while-5.4 {break tests, long command body with computed command names} -body { 537 set a {} 538 set i 1 539 set z break 540 while {$i<6} { 541 if {$i==2} {incr i; continue} 542 if {$i==5} $z 543 if {$i>5} continue 544 if {$i>6 && $tcl_platform(machine)=="xxx"} { 545 catch {set a $a} msg 546 catch {incr i 5} msg 547 catch {incr i -5} msg 548 } 549 if {$i>6 && $tcl_platform(machine)=="xxx"} { 550 catch {set a $a} msg 551 catch {incr i 5} msg 552 catch {incr i -5} msg 553 } 554 if {$i>6 && $tcl_platform(machine)=="xxx"} { 555 catch {set a $a} msg 556 catch {incr i 5} msg 557 catch {incr i -5} msg 558 } 559 if {$i==4} $z 560 if {$i>6 && $tcl_platform(machine)=="xxx"} { 561 catch {set a $a} msg 562 catch {incr i 5} msg 563 catch {incr i -5} msg 564 } 565 if {$i>6 && $tcl_platform(machine)=="xxx"} { 566 catch {set a $a} msg 567 catch {incr i 5} msg 568 catch {incr i -5} msg 569 } 570 set a [concat $a $i] 571 incr i 572 } 573 return $a 574} -cleanup { 575 unset a i z 576} -result {1 3} 577 578# Check "continue" with computed command names. 579 580test while-6.1 {continue and computed command names} -body { 581 set i 0 582 set z continue 583 while 1 { 584 incr i 585 if {$i < 10} $z 586 break 587 } 588 return $i 589} -cleanup { 590 unset i z 591} -result 10 592test while-6.2 {continue tests} -body { 593 set a {} 594 set i 1 595 set z continue 596 while {$i <= 4} { 597 incr i 598 if {$i == 3} $z 599 set a [concat $a $i] 600 } 601 return $a 602} -cleanup { 603 unset a i z 604} -result {2 4 5} 605test while-6.3 {continue tests with computed command names} -body { 606 set a {} 607 set i 1 608 set z continue 609 while {$i <= 4} { 610 incr i 611 if {$i != 2} $z 612 set a [concat $a $i] 613 } 614 return $a 615} -cleanup { 616 unset a i z 617} -result {2} 618test while-6.4 {continue tests, nested loops with computed command names} -body { 619 set msg {} 620 set i 1 621 set z continue 622 while {$i <= 4} { 623 incr i 624 set a 1 625 while {$a <= 2} { 626 incr a 627 if {$i>=3 && $a>=3} $z 628 set msg [concat $msg "$i.$a"] 629 } 630 } 631 return $msg 632} -cleanup { 633 unset a i z msg 634} -result {2.2 2.3 3.2 4.2 5.2} 635test while-6.5 {continue tests, long command body with computed command names} -body { 636 set a {} 637 set i 1 638 set z continue 639 while {$i<6} { 640 if {$i==2} {incr i; continue} 641 if {$i==4} break 642 if {$i>5} $z 643 if {$i>6 && $tcl_platform(machine)=="xxx"} { 644 catch {set a $a} msg 645 catch {incr i 5} msg 646 catch {incr i -5} msg 647 } 648 if {$i>6 && $tcl_platform(machine)=="xxx"} { 649 catch {set a $a} msg 650 catch {incr i 5} msg 651 catch {incr i -5} msg 652 } 653 if {$i>6 && $tcl_platform(machine)=="xxx"} { 654 catch {set a $a} msg 655 catch {incr i 5} msg 656 catch {incr i -5} msg 657 } 658 if {$i>6 && $tcl_platform(machine)=="xxx"} { 659 catch {set a $a} msg 660 catch {incr i 5} msg 661 catch {incr i -5} msg 662 } 663 if {$i>6 && $tcl_platform(machine)=="xxx"} { 664 catch {set a $a} msg 665 catch {incr i 5} msg 666 catch {incr i -5} msg 667 } 668 set a [concat $a $i] 669 incr i 670 } 671 return $a 672} -cleanup { 673 unset a i z 674} -result {1 3} 675 676# Test for incorrect "double evaluation" semantics 677 678test while-7.1 {delayed substitution of body} -body { 679 set i 0 680 while {[incr i] < 10} " 681 set result $i 682 " 683 proc p {} { 684 set i 0 685 while {[incr i] < 10} " 686 set result $i 687 " 688 return $result 689 } 690 append result [p] 691} -cleanup { 692 unset result i 693} -result {00} 694 695# cleanup 696::tcltest::cleanupTests 697return 698 699# Local Variables: 700# mode: tcl 701# fill-column: 78 702# End: 703