1# Commands covered: tailcall 2# 3# This file contains a collection of tests for experimental commands that are 4# found in ::tcl::unsupported. The tests will migrate to normal test files 5# if/when the commands find their way into the core. 6# 7# Copyright © 2008 Miguel Sofer. 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 12if {"::tcltest" ni [namespace children]} { 13 package require tcltest 2.5 14 namespace import -force ::tcltest::* 15} 16 17::tcltest::loadTestedCommands 18catch [list package require -exact tcl::test [info patchlevel]] 19 20testConstraint testnrelevels [llength [info commands testnrelevels]] 21 22# 23# The tests that risked blowing the C stack on failure have been removed: we 24# can now actually measure using testnrelevels. 25# 26 27if {[testConstraint testnrelevels]} { 28 namespace eval testnre { 29 # 30 # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, 31 # cmdFrame level, callFrame level, tosPtr and callback depth 32 # 33 variable last [testnrelevels] 34 proc depthDiff {} { 35 variable last 36 set depth [testnrelevels] 37 set res {} 38 foreach t $depth l $last { 39 lappend res [expr {$t-$l}] 40 } 41 set last $depth 42 return $res 43 } 44 namespace export * 45 } 46 namespace import testnre::* 47} 48 49proc errorcode options { 50 dict get [dict merge {-errorcode NONE} $options] -errorcode 51} 52 53test tailcall-0.1 {tailcall is constant space} -constraints testnrelevels -setup { 54 proc a i { 55 # 56 # NOTE: there may be a diff in callback depth with the first call 57 # ($i==0) due to the fact that the first is from an eval. Successive 58 # calls should add nothing to any stack depths. 59 # 60 if {$i == 1} { 61 depthDiff 62 } 63 if {[incr i] > 10} { 64 return [depthDiff] 65 } 66 tailcall a $i 67 } 68} -body { 69 a 0 70} -cleanup { 71 rename a {} 72} -result {0 0 0 0 0 0} 73 74test tailcall-0.2 {tailcall is constant space} -constraints testnrelevels -setup { 75 set a { i { 76 if {$i == 1} { 77 depthDiff 78 } 79 if {[incr i] > 10} { 80 return [depthDiff] 81 } 82 upvar 1 a a 83 tailcall apply $a $i 84 }} 85} -body { 86 apply $a 0 87} -cleanup { 88 unset a 89} -result {0 0 0 0 0 0} 90 91test tailcall-0.3 {tailcall is constant space} -constraints testnrelevels -setup { 92 proc a i { 93 if {$i == 1} { 94 depthDiff 95 } 96 if {[incr i] > 10} { 97 return [depthDiff] 98 } 99 tailcall b $i 100 } 101 interp alias {} b {} a 102} -body { 103 b 0 104} -cleanup { 105 rename a {} 106 rename b {} 107} -result {0 0 0 0 0 0} 108 109test tailcall-0.4 {tailcall is constant space} -constraints testnrelevels -setup { 110 namespace eval ::ns { 111 namespace export * 112 } 113 proc ::ns::a i { 114 if {$i == 1} { 115 depthDiff 116 } 117 if {[incr i] > 10} { 118 return [depthDiff] 119 } 120 set b [uplevel 1 [list namespace which b]] 121 tailcall $b $i 122 } 123 namespace import ::ns::a 124 rename a b 125} -body { 126 b 0 127} -cleanup { 128 rename b {} 129 namespace delete ::ns 130} -result {0 0 0 0 0 0} 131 132test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup { 133 proc b i { 134 if {$i == 1} { 135 depthDiff 136 } 137 if {[incr i] > 10} { 138 return [depthDiff] 139 } 140 tailcall a b $i 141 } 142 namespace ensemble create -command a -map {b b} 143} -body { 144 a b 0 145} -cleanup { 146 rename a {} 147 rename b {} 148} -result {0 0 0 0 0 0} 149 150test tailcall-0.5.1 {tailcall is constant space} -constraints testnrelevels -setup { 151 # 152 # This test is related to [bug d87cb182053fd79b3]: the fix to that bug was 153 # to remove a call to TclSkipTailcall, which caused a violation of the 154 # constant-space property of tailcall in that particular 155 # configuration. This test was added to detect that, and insure that the 156 # problem is fixed. 157 # 158 159 proc b i { 160 if {$i == 1} { 161 depthDiff 162 } 163 if {[incr i] > 10} { 164 return [depthDiff] 165 } 166 tailcall dict b $i 167 } 168 set map0 [namespace ensemble configure dict -map] 169 set map $map0 170 dict set map b b 171 namespace ensemble configure dict -map $map 172} -body { 173 dict b 0 174} -cleanup { 175 rename b {} 176 namespace ensemble configure dict -map $map0 177 unset map map0 178} -result {0 0 0 0 0 0} 179 180test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels knownBug} -setup { 181 # 182 # This test fails because ns-unknown is not NR-enabled 183 # 184 proc c i { 185 if {$i == 1} { 186 depthDiff 187 } 188 if {[incr i] > 10} { 189 return [depthDiff] 190 } 191 tailcall a b $i 192 } 193 proc d {ens sub args} { 194 return [list $ens c] 195 } 196 namespace ensemble create -command a -unknown d 197} -body { 198 a b 0 199} -cleanup { 200 rename a {} 201 rename c {} 202 rename d {} 203} -result {0 0 0 0 0 0} 204 205test tailcall-0.7 {tailcall is constant space} -constraints testnrelevels -setup { 206 catch {rename foo {}} 207 oo::class create foo { 208 method b i { 209 if {$i == 1} { 210 depthDiff 211 } 212 if {[incr i] > 10} { 213 return [depthDiff] 214 } 215 tailcall [self] b $i 216 } 217 } 218} -body { 219 foo create a 220 a b 0 221} -cleanup { 222 rename a {} 223 rename foo {} 224} -result {0 0 0 0 0 0} 225 226test tailcall-1 {tailcall} -body { 227 namespace eval a { 228 variable x *::a 229 proc xset {} { 230 set tmp {} 231 set ns {[namespace current]} 232 set level [info level] 233 for {set i 0} {$i <= [info level]} {incr i} { 234 uplevel #$i "set x $i$ns" 235 lappend tmp "$i [info level $i]" 236 } 237 lrange $tmp 1 end 238 } 239 proc foo {} {tailcall xset; set x noreach} 240 } 241 namespace eval b { 242 variable x *::b 243 proc xset args {error b::xset} 244 proc moo {} {set x 0; variable y [::a::foo]; set x} 245 } 246 variable x *:: 247 proc xset args {error ::xset} 248 list [::b::moo] | $x $a::x $b::x | $::b::y 249} -cleanup { 250 unset x 251 rename xset {} 252 namespace delete a b 253} -result {1::b | 0:: *::a *::b | {{1 ::b::moo} {2 xset}}} 254 255 256test tailcall-2 {tailcall in non-proc} -body { 257 namespace eval a [list tailcall set x 1] 258} -match glob -result *tailcall* -returnCodes error 259 260test tailcall-3 {tailcall falls off tebc} -body { 261 unset -nocomplain x 262 proc foo {} {tailcall set x 1} 263 list [catch foo msg] $msg [set x] 264} -cleanup { 265 rename foo {} 266 unset x 267} -result {0 1 1} 268 269test tailcall-4 {tailcall falls off tebc} -body { 270 set x 2 271 proc foo {} {tailcall set x 1} 272 foo 273 set x 274} -cleanup { 275 rename foo {} 276 unset x 277} -result 1 278 279test tailcall-5 {tailcall falls off tebc} -body { 280 set x 2 281 namespace eval bar { 282 variable x 3 283 proc foo {} {tailcall set x 1} 284 } 285 bar::foo 286 list $x $bar::x 287} -cleanup { 288 unset x 289 namespace delete bar 290} -result {1 3} 291 292test tailcall-6 {tailcall does remove callframes} -body { 293 proc foo {} {info level} 294 proc moo {} {tailcall foo} 295 proc boo {} {expr {[moo] - [info level]}} 296 boo 297} -cleanup { 298 rename foo {} 299 rename moo {} 300 rename boo {} 301} -result 1 302 303test tailcall-7 {tailcall does return} -setup { 304 namespace eval ::foo { 305 variable res {} 306 proc a {} { 307 variable res 308 append res a 309 tailcall set x 1 310 append res a 311 } 312 proc b {} { 313 variable res 314 append res b 315 a 316 append res b 317 } 318 proc c {} { 319 variable res 320 append res c 321 b 322 append res c 323 } 324 } 325} -body { 326 namespace eval ::foo c 327} -cleanup { 328 namespace delete ::foo 329} -result cbabc 330 331test tailcall-8 {tailcall tailcall} -setup { 332 namespace eval ::foo { 333 variable res {} 334 proc a {} { 335 variable res 336 append res a 337 tailcall tailcall set x 1 338 append res a 339 } 340 proc b {} { 341 variable res 342 append res b 343 a 344 append res b 345 } 346 proc c {} { 347 variable res 348 append res c 349 b 350 append res c 351 } 352 } 353} -body { 354 namespace eval ::foo c 355} -cleanup { 356 namespace delete ::foo 357} -result cbac 358 359test tailcall-9 {tailcall factorial} -setup { 360 proc fact {n {b 1}} { 361 if {$n == 1} { 362 return $b 363 } 364 tailcall fact [expr {$n-1}] [expr {$n*$b}] 365 } 366} -body { 367 list [fact 1] [fact 5] [fact 10] [fact 15] 368} -cleanup { 369 rename fact {} 370} -result {1 120 3628800 1307674368000} 371 372test tailcall-10a {tailcall and eval} -setup { 373 set ::x 0 374 proc a {} { 375 eval [list tailcall lappend ::x 2] 376 set ::x 1 377 } 378} -body { 379 list [a] $::x 380} -cleanup { 381 unset -nocomplain ::x 382} -result {{0 2} {0 2}} 383 384test tailcall-10b {tailcall and eval} -setup { 385 set ::x 0 386 proc a {} { 387 eval {tailcall lappend ::x 2} 388 set ::x 1 389 } 390} -body { 391 list [a] $::x 392} -cleanup { 393 unset -nocomplain ::x 394} -result {{0 2} {0 2}} 395 396test tailcall-11a {tailcall and uplevel} -setup { 397 proc a {} { 398 uplevel 1 [list tailcall set ::x 2] 399 set ::x 1 400 } 401} -body { 402 list [a] $::x 403} -cleanup { 404 unset -nocomplain ::x 405} -match glob -result *tailcall* -returnCodes error 406 407test tailcall-11b {tailcall and uplevel} -setup { 408 proc a {} { 409 uplevel 1 {tailcall set ::x 2} 410 set ::x 1 411 } 412} -body { 413 list [a] $::x 414} -cleanup { 415 unset -nocomplain ::x 416} -match glob -result *tailcall* -returnCodes error 417 418test tailcall-11c {tailcall and uplevel} -setup { 419 proc a {} { 420 uplevel 1 {tailcall lappend ::x 2} 421 set ::x 1 422 } 423 proc b {} {set ::x 0; a; lappend ::x 3} 424} -body { 425 list [b] $::x 426} -cleanup { 427 rename a {} 428 rename b {} 429 unset -nocomplain ::x 430} -result {{0 3 2} {0 3 2}} 431 432test tailcall-12.1 {[Bug 2649975]} -setup { 433 proc dump {{text {}}} { 434 set text [uplevel 1 [list subst $text]] 435 set l [expr {[info level] -1}] 436 if {$text eq {}} { 437 set text [info level $l] 438 } 439 puts "$l: $text" 440 } 441 # proc dump args {} 442 proc bravo {} { 443 upvar 1 v w 444 dump {inside bravo, v -> $w} 445 set v "procedure bravo" 446 #uplevel 1 [list delta ::betty] 447 uplevel 1 {delta ::betty} 448 return $::resolution 449 } 450 proc delta name { 451 upvar 1 v w 452 dump {inside delta, v -> $w} 453 set v "procedure delta" 454 tailcall foxtrot 455 } 456 proc foxtrot {} { 457 upvar 1 v w 458 dump {inside foxtrot, v -> $w} 459 global resolution 460 set ::resolution $w 461 } 462 set v "global level" 463} -body { 464 set result [bravo] 465 if {$result ne $v} { 466 puts "v should have been found at $v but was found in $result" 467 } 468} -cleanup { 469 unset v 470 rename dump {} 471 rename bravo {} 472 rename delta {} 473 rename foxtrot {} 474} -output {1: inside bravo, v -> global level 4751: inside delta, v -> global level 4761: inside foxtrot, v -> global level 477} 478 479test tailcall-12.2 {[Bug 2649975]} -setup { 480 proc dump {{text {}}} { 481 set text [uplevel 1 [list subst $text]] 482 set l [expr {[info level] -1}] 483 if {$text eq {}} { 484 set text [info level $l] 485 } 486 puts "$l: $text" 487 } 488 # proc dump args {} 489 set v "global level" 490 oo::class create foo { # like connection 491 method alpha {} { # like connections 'tables' method 492 dump 493 upvar 1 v w 494 dump {inside foo's alpha, v resolves to $w} 495 set v "foo's method alpha" 496 dump {foo's alpha is calling [self] bravo - v should resolve at global level} 497 set result [uplevel 1 [list [self] bravo]] 498 dump {exiting from foo's alpha} 499 return $result 500 } 501 method bravo {} { # like connections 'foreach' method 502 dump 503 upvar 1 v w 504 dump {inside foo's bravo, v resolves to $w} 505 set v "foo's method bravo" 506 dump {foo's bravo is calling charlie to create barney} 507 set barney [my charlie ::barney] 508 dump {foo's bravo is calling bravo on $barney} 509 dump {v should resolve at global scope there} 510 set result [uplevel 1 [list $barney bravo]] 511 dump {exiting from foo's bravo} 512 return $result 513 } 514 method charlie {name} { # like tdbc prepare 515 dump 516 set v "foo's method charlie" 517 dump {tailcalling bar's constructor} 518 tailcall ::bar create $name 519 } 520 } 521 oo::class create bar { # like statement 522 method bravo {} { # like statement foreach method 523 dump 524 upvar 1 v w 525 dump {inside bar's bravo, v is resolving to $w} 526 set v "bar's method bravo" 527 dump {calling delta to construct betty - v should resolve global there} 528 uplevel 1 [list [self] delta ::betty] 529 dump {exiting from bar's bravo} 530 return [::betty whathappened] 531 } 532 method delta {name} { # like statement execute method 533 dump 534 upvar 1 v w 535 dump {inside bar's delta, v is resolving to $w} 536 set v "bar's method delta" 537 dump {tailcalling to construct $name as instance of grill} 538 dump {v should resolve at global level in grill's constructor} 539 dump {grill's constructor should run at level [info level]} 540 tailcall grill create $name 541 } 542 } 543 oo::class create grill { 544 variable resolution 545 constructor {} { 546 dump 547 upvar 1 v w 548 dump "in grill's constructor, v resolves to $w" 549 set resolution $w 550 } 551 method whathappened {} { 552 return $resolution 553 } 554 } 555 foo create fred 556} -body { 557 set result [fred alpha] 558 if {$result ne "global level"} { 559 puts "v should have been found at global level but was found in $result" 560 } 561} -cleanup { 562 unset result 563 rename fred {} 564 rename dump {} 565 rename foo {} 566 rename bar {} 567 rename grill {} 568} -output {1: fred alpha 5691: inside foo's alpha, v resolves to global level 5701: foo's alpha is calling ::fred bravo - v should resolve at global level 5711: ::fred bravo 5721: inside foo's bravo, v resolves to global level 5731: foo's bravo is calling charlie to create barney 5742: my charlie ::barney 5752: tailcalling bar's constructor 5761: foo's bravo is calling bravo on ::barney 5771: v should resolve at global scope there 5781: ::barney bravo 5791: inside bar's bravo, v is resolving to global level 5801: calling delta to construct betty - v should resolve global there 5811: ::barney delta ::betty 5821: inside bar's delta, v is resolving to global level 5831: tailcalling to construct ::betty as instance of grill 5841: v should resolve at global level in grill's constructor 5851: grill's constructor should run at level 1 5861: grill create ::betty 5871: in grill's constructor, v resolves to global level 5881: exiting from bar's bravo 5891: exiting from foo's bravo 5901: exiting from foo's alpha 591} 592 593test tailcall-12.3a0 {[Bug 2695587]} -body { 594 apply {{} { 595 catch [list tailcall foo] 596 }} 597} -returnCodes 1 -result {invalid command name "foo"} 598 599test tailcall-12.3a1 {[Bug 2695587]} -body { 600 apply {{} { 601 catch [list tailcall foo] 602 tailcall 603 }} 604} -result {} 605 606test tailcall-12.3a2 {[Bug 2695587]} -body { 607 apply {{} { 608 catch [list tailcall foo] 609 tailcall moo 610 }} 611} -returnCodes 1 -result {invalid command name "moo"} 612 613test tailcall-12.3a3 {[Bug 2695587]} -body { 614 set x 0 615 apply {{} { 616 catch [list tailcall foo] 617 tailcall lappend x 1 618 }} 619 set x 620} -cleanup { 621 unset x 622} -result {0 1} 623 624test tailcall-12.3b0 {[Bug 2695587]} -body { 625 apply {{} { 626 set catch catch 627 $catch [list tailcall foo] 628 }} 629} -returnCodes 1 -result {invalid command name "foo"} 630 631test tailcall-12.3b1 {[Bug 2695587]} -body { 632 apply {{} { 633 set catch catch 634 $catch [list tailcall foo] 635 tailcall 636 }} 637} -result {} 638 639test tailcall-12.3b2 {[Bug 2695587]} -body { 640 apply {{} { 641 set catch catch 642 $catch [list tailcall foo] 643 tailcall moo 644 }} 645} -returnCodes 1 -result {invalid command name "moo"} 646 647test tailcall-12.3b3 {[Bug 2695587]} -body { 648 set x 0 649 apply {{} { 650 set catch catch 651 $catch [list tailcall foo] 652 tailcall lappend x 1 653 }} 654 set x 655} -cleanup { 656 unset x 657} -result {0 1} 658 659# MORE VARIANTS MISSING: bc'ed caught script vs (bc'ed, not-bc'ed) 660# catch. Actually superfluous now, as tailcall just returns TCL_RETURN so that 661# standard catch behaviour is required. 662 663test tailcall-13.1 {directly tailcalling the tailcall command is ok} { 664 list [catch { 665 apply {{} { 666 apply {{} { 667 tailcall tailcall subst ok 668 subst b 669 }} 670 subst c 671 }} 672 } msg opt] $msg [errorcode $opt] 673} {0 ok NONE} 674test tailcall-13.2 {indirectly tailcalling the tailcall command is ok} { 675 list [catch { 676 apply {{} { 677 apply {{} { 678 tailcall eval tailcall subst ok 679 subst b 680 }} 681 subst c 682 }} 683 } msg opt] $msg [errorcode $opt] 684} {0 ok NONE} 685 686if {[testConstraint testnrelevels]} { 687 namespace forget testnre::* 688 namespace delete testnre 689} 690 691test tailcall-14.1 {in a deleted namespace} -body { 692 namespace eval ns { 693 proc p args { 694 tailcall [namespace current] $args 695 } 696 namespace delete [namespace current] 697 p 698 } 699} -returnCodes 1 -result {namespace "::ns" not found} 700 701test tailcall-14.1-bc {{in a deleted namespace} {byte compiled}} -body { 702 namespace eval ns { 703 proc p args { 704 tailcall [namespace current] {*}$args 705 } 706 namespace delete [namespace current] 707 p 708 } 709} -returnCodes 1 -result {namespace "::ns" not found} 710 711# cleanup 712::tcltest::cleanupTests 713 714# Local Variables: 715# mode: tcl 716# End: 717