1# Commands covered: proc, apply, [interp alias], [namespce import] 2# 3# This file contains a collection of tests for the non-recursive executor that 4# avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the 5# actual command functionality is tested in the specific test file. 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 namespace path ::tcl::mathop 30 # 31 # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, 32 # cmdFrame level, callFrame level, tosPtr and callback depth 33 # 34 variable last [testnrelevels] 35 proc depthDiff {} { 36 variable last 37 set depth [testnrelevels] 38 set res {} 39 foreach t $depth l $last { 40 lappend res [expr {$t-$l}] 41 } 42 set last $depth 43 return $res 44 } 45 proc setabs {} { 46 variable abs [- [lindex [testnrelevels] 0]] 47 } 48 49 variable body0 { 50 set x [depthDiff] 51 if {[incr i] > 10} { 52 namespace upvar [namespace qualifiers \ 53 [namespace origin depthDiff]] abs abs 54 incr abs [lindex [testnrelevels] 0] 55 return [list [lrange $x 0 3] $abs] 56 } 57 } 58 proc makebody txt { 59 variable body0 60 return "$body0; $txt" 61 } 62 namespace export * 63 } 64 namespace import testnre::* 65} 66 67test nre-0.1 {levels while unwinding} -body { 68 testnreunwind 69} -constraints { 70 testnrelevels 71} -result {0 0 0} 72 73test nre-1.1 {self-recursive procs} -setup { 74 proc a i [makebody {a $i}] 75} -body { 76 setabs 77 a 0 78} -cleanup { 79 rename a {} 80} -constraints { 81 testnrelevels 82} -result {{0 1 1 1} 0} 83test nre-1.2 {self-recursive lambdas} -setup { 84 set a [list i [makebody {apply $::a $i}]] 85} -body { 86 setabs 87 apply $a 0 88} -cleanup { 89 unset a 90} -constraints { 91 testnrelevels 92} -result {{0 1 1 1} 0} 93test nre-1.3 {mutually recursive procs and lambdas} -setup { 94 proc a i { 95 apply $::b [incr i] 96 } 97 set b [list i [makebody {a $i}]] 98} -body { 99 setabs 100 a 0 101} -cleanup { 102 rename a {} 103 unset b 104} -constraints { 105 testnrelevels 106} -result {{0 2 2 2} 0} 107 108# 109# Test that aliases are non-recursive 110# 111 112test nre-2.1 {alias is not recursive} -setup { 113 proc a i [makebody {b $i}] 114 interp alias {} b {} a 115} -body { 116 setabs 117 a 0 118} -cleanup { 119 rename a {} 120 rename b {} 121} -constraints { 122 testnrelevels 123} -result {{0 2 1 1} 0} 124 125# 126# Test that imports are non-recursive 127# 128 129test nre-3.1 {imports are not recursive} -setup { 130 namespace eval foo { 131 setabs 132 namespace export a 133 } 134 proc foo::a i [makebody {::a $i}] 135 namespace import foo::a 136} -body { 137 a 0 138} -cleanup { 139 rename a {} 140 namespace delete ::foo 141} -constraints { 142 testnrelevels 143} -result {{0 2 1 1} 0} 144 145test nre-4.1 {ensembles are not recursive} -setup { 146 proc a i [makebody {b foo $i}] 147 namespace ensemble create \ 148 -command b \ 149 -map [list foo a] 150} -body { 151 setabs 152 a 0 153} -cleanup { 154 rename a {} 155 rename b {} 156} -constraints { 157 testnrelevels 158} -result {{0 2 1 1} 0} 159 160test nre-4.2 {(compiled) ensembles do not break tailcall} -setup { 161 # Fix Bug d87cb18205 162 proc b {} { 163 tailcall append result first 164 } 165 set map [namespace ensemble configure ::dict -map] 166 dict set map a b 167 namespace ensemble configure ::dict -map $map 168 proc demo {} { 169 dict a 170 append result second 171 } 172} -body { 173 demo 174} -cleanup { 175 rename demo {} 176 namespace ensemble configure ::dict -map [dict remove $map a] 177 unset map 178 rename b {} 179} -result firstsecond 180 181test nre-5.1 {[namespace eval] is not recursive} -setup { 182 namespace eval ::foo { 183 setabs 184 } 185 proc foo::a i [makebody {namespace eval ::foo [list a $i]}] 186} -body { 187 ::foo::a 0 188} -cleanup { 189 namespace delete ::foo 190} -constraints { 191 testnrelevels 192} -result {{0 2 2 2} 0} 193test nre-5.2 {[namespace eval] is not recursive} -setup { 194 namespace eval ::foo { 195 setabs 196 } 197 proc foo::a i [makebody {namespace eval ::foo "set x $i; a $i"}] 198} -body { 199 foo::a 0 200} -cleanup { 201 namespace delete ::foo 202} -constraints { 203 testnrelevels 204} -result {{0 2 2 2} 0} 205 206test nre-6.1 {[uplevel] is not recursive} -setup { 207 proc a i [makebody {uplevel 1 [list a $i]}] 208} -body { 209 setabs 210 a 0 211} -cleanup { 212 rename a {} 213} -constraints { 214 testnrelevels 215} -result {{0 2 2 0} 0} 216test nre-6.2 {[uplevel] is not recursive} -setup { 217 setabs 218 proc a i [makebody {uplevel 1 "set x $i; a $i"}] 219} -body { 220 a 0 221} -cleanup { 222 rename a {} 223} -constraints { 224 testnrelevels 225} -result {{0 2 2 0} 0} 226 227test nre-7.1 {[catch] is not recursive} -setup { 228 setabs 229 proc a i [makebody {uplevel 1 "catch {a $i} msg; set msg"}] 230} -body { 231 a 0 232} -cleanup { 233 rename a {} 234} -constraints { 235 testnrelevels 236} -result {{0 3 3 0} 0} 237test nre-7.2 {[if] is not recursive} -setup { 238 setabs 239 proc a i [makebody {uplevel 1 "if 1 {a $i}"}] 240} -body { 241 a 0 242} -cleanup { 243 rename a {} 244} -constraints { 245 testnrelevels 246} -result {{0 2 2 0} 0} 247test nre-7.3 {[while] is not recursive} -setup { 248 setabs 249 proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}] 250} -body { 251 a 0 252} -cleanup { 253 rename a {} 254} -constraints { 255 testnrelevels 256} -result {{0 2 2 0} 0} 257test nre-7.4 {[for] is not recursive} -setup { 258 setabs 259 proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}] 260} -body { 261 a 0 262} -cleanup { 263 rename a {} 264} -constraints { 265 testnrelevels 266} -result {{0 2 2 0} 0} 267test nre-7.5 {[foreach] is not recursive} -setup { 268 # 269 # Enable once [foreach] is NR-enabled 270 # 271 setabs 272 proc a i [makebody {uplevel 1 "foreach j {1 2 3 4 5 6} {set res \[a $i\]; break}; set res"}] 273} -body { 274 a 0 275} -cleanup { 276 rename a {} 277} -constraints { 278 testnrelevels 279} -result {{0 3 3 0} 0} 280test nre-7.6 {[eval] is not recursive} -setup { 281 proc a i [makebody {eval [list a $i]}] 282} -body { 283 setabs 284 a 0 285} -cleanup { 286 rename a {} 287} -constraints { 288 testnrelevels 289} -result {{0 2 2 1} 0} 290test nre-7.7 {[eval] is not recursive} -setup { 291 proc a i [makebody {eval "a $i"}] 292} -body { 293 setabs 294 a 0 295} -cleanup { 296 rename a {} 297} -constraints { 298 testnrelevels 299} -result {{0 2 2 1} 0} 300test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup { 301 proc foo args {} 302 foo 303 coroutine bar apply {{} { 304 yield 305 proc foo args {return ok} 306 while 1 { 307 yield [incr i] 308 foo 309 } 310 }} 311} -body { 312 # if switching to plain eval is not nre aware, this will cause a "cannot 313 # yield" error 314 list [bar] [bar] [bar] 315} -cleanup { 316 rename bar {} 317 rename foo {} 318} -result {1 2 3} 319 320test nre-8.1 {nre and {*}} -body { 321 # force an expansion that grows the evaluation stack, check that nre 322 # adapts the TEBCdataPtr. This crashes on failure. 323 proc inner {} { 324 set long [lrepeat 1000000 1] 325 list {*}$long 326 } 327 proc outer {} inner 328 lrange [outer] 0 2 329} -cleanup { 330 rename inner {} 331 rename outer {} 332} -result {1 1 1} 333test nre-8.2 {nre and {*}, [Bug 2415422]} -body { 334 # force an expansion that grows the evaluation stack, check that nre 335 # adapts the bcFramePtr. This causes an NRE assertion to fail if it is not 336 # done properly. 337 proc nop {} {} 338 proc crash {} { 339 foreach val [list {*}[lrepeat 100000 x]] { 340 nop 341 } 342 } 343 crash 344} -cleanup { 345 rename nop {} 346 rename crash {} 347} 348 349# 350# Basic TclOO tests 351# 352 353test nre-oo.1 {really deep calls in oo - direct} -setup { 354 oo::object create foo 355 oo::objdefine foo method bar i [makebody {foo bar $i}] 356} -body { 357 setabs 358 foo bar 0 359} -cleanup { 360 foo destroy 361} -constraints { 362 testnrelevels 363} -result {{0 1 1 1} 0} 364test nre-oo.2 {really deep calls in oo - call via [self]} -setup { 365 oo::object create foo 366 oo::objdefine foo method bar i [makebody {[self] bar $i}] 367} -body { 368 setabs 369 foo bar 0 370} -cleanup { 371 foo destroy 372} -constraints { 373 testnrelevels 374} -result {{0 1 1 1} 0} 375test nre-oo.3 {really deep calls in oo - private calls} -setup { 376 oo::object create foo 377 oo::objdefine foo method bar i [makebody {my bar $i}] 378} -body { 379 setabs 380 foo bar 0 381} -cleanup { 382 foo destroy 383} -constraints { 384 testnrelevels 385} -result {{0 1 1 1} 0} 386test nre-oo.4 {really deep calls in oo - overriding} -setup { 387 oo::class create foo { 388 method bar i [makebody {my bar $i}] 389 } 390 oo::class create boo { 391 superclass foo 392 method bar i [makebody {next $i}] 393 } 394} -body { 395 setabs 396 [boo new] bar 0 397} -cleanup { 398 foo destroy 399} -constraints { 400 testnrelevels 401} -result {{0 1 1 1} 0} 402test nre-oo.5 {really deep calls in oo - forwards} -setup { 403 oo::object create foo 404 set body [makebody {my boo $i}] 405 oo::objdefine foo " 406 method bar i {$body} 407 forward boo ::foo bar 408 " 409} -body { 410 setabs 411 foo bar 0 412} -cleanup { 413 foo destroy 414} -constraints { 415 testnrelevels 416} -result {{0 2 1 1} 0} 417 418# 419# NASTY BUG found by tcllib's interp package 420# 421 422test nre-X.1 {eval in wrong interp} -setup { 423 set i [interp create] 424 $i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}} 425} -body { 426 $i eval { 427 set x {namespace children ::} 428 set y [list namespace children ::] 429 namespace delete {*}[filter [{*}$y]] 430 set j [interp create] 431 $j alias filter filter 432 $j eval {namespace delete {*}[filter [namespace children ::]]} 433 namespace eval foo {} 434 list [filter [eval $x]] [filter [eval $y]] [filter [$j eval $x]] [filter [$j eval $y]] 435 } 436} -cleanup { 437 interp delete $i 438} -result {::foo ::foo {} {}} 439 440# cleanup 441::tcltest::cleanupTests 442 443if {[testConstraint testnrelevels]} { 444 namespace forget testnre::* 445 namespace delete testnre 446} 447 448return 449 450# Local Variables: 451# mode: tcl 452# fill-column: 78 453# End: 454