1# This file contains tests for the files tclCompile.c, tclCompCmds.c and 2# tclLiteral.c 3# 4# This file contains a collection of tests for one or more of the Tcl built-in 5# commands. Sourcing this file into Tcl runs the tests and generates output 6# for errors. No output means no errors were found. 7# 8# Copyright © 1997 Sun Microsystems, Inc. 9# Copyright © 1998-1999 Scriptics Corporation. 10# 11# See the file "license.terms" for information on usage and redistribution of 12# this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 14if {"::tcltest" ni [namespace children]} { 15 package require tcltest 2.5 16 namespace import -force ::tcltest::* 17} 18 19 20::tcltest::loadTestedCommands 21catch [list package require -exact tcl::test [info patchlevel]] 22 23testConstraint exec [llength [info commands exec]] 24testConstraint memory [llength [info commands memory]] 25testConstraint testevalex [llength [info commands testevalex]] 26 27# The following tests are very incomplete, although the rest of the 28# test suite covers this file fairly well. 29 30catch {rename p ""} 31catch {namespace delete test_ns_compile} 32catch {unset x} 33catch {unset y} 34catch {unset a} 35 36test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} -setup { 37 catch {namespace delete test_ns_compile} 38 catch {unset x} 39} -body { 40 set x 123 41 namespace eval test_ns_compile { 42 proc set {args} { 43 global x 44 lappend x test_ns_compile::set 45 } 46 proc p {} { 47 set 0 48 } 49 } 50 list [test_ns_compile::p] [set x] 51} -result {{123 test_ns_compile::set} {123 test_ns_compile::set}} 52test compile-1.2 {TclCompileString, error result is reset if TclGetLong determines word isn't an integer} { 53 proc p {x} {info commands 3m} 54 list [catch {p} msg] $msg 55} {1 {wrong # args: should be "p x"}} 56 57test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} -setup { 58 catch {unset x} 59} -body { 60 set x 123 61 list $::x [expr {"x" in [info globals]}] 62} -result {123 1} 63test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} -setup { 64 catch {unset y} 65} -body { 66 proc p {} { 67 set ::y 789 68 return $::y 69 } 70 list [p] $::y [expr {"y" in [info globals]}] 71} -result {789 789 1} 72test compile-2.3 {TclCompileDollarVar: global array name with ::s} -setup { 73 catch {unset a} 74} -body { 75 set ::a(1) 2 76 list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {"a" in [info globals]}] 77} -result {2 3 3 1} 78test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} -setup { 79 catch {unset a} 80} -body { 81 proc p {} { 82 set ::a(1) 1 83 return $::a($::a(1)) 84 } 85 list [p] $::a(1) [expr {"a" in [info globals]}] 86} -result {1 1 1} 87test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} -setup { 88 catch {unset a} 89} -body { 90 proc p {} { 91 global a 92 set a(1) 1 93 return ${a(1)}$::a(1)$a(1) 94 } 95 list [p] $::a(1) [expr {"a" in [info globals]}] 96} -result {111 1 1} 97 98test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} -setup { 99 catch {unset a} 100} -body { 101 set a(1) xyzzyx 102 proc p {} { 103 global a 104 catch {set x 123} a(1) 105 } 106 list [p] $a(1) 107} -result {0 123} 108test compile-3.2 {TclCompileCatchCmd: non-local variables} { 109 set ::foo 1 110 proc catch-test {} { 111 catch {set x 3} ::foo 112 } 113 catch-test 114 return $::foo 115} 3 116test compile-3.3 {TclCompileCatchCmd: overagressive compiling [bug 219184]} { 117 proc catch-test {str} { 118 catch [eval $str GOOD] 119 error BAD 120 } 121 catch {catch-test error} ::foo 122 return $::foo 123} {GOOD} 124test compile-3.4 {TclCompileCatchCmd: bcc'ed [return] is caught} { 125 proc foo {} { 126 set fail [catch { 127 return 1 128 }] ; # {} 129 return 2 130 } 131 foo 132} {2} 133test compile-3.5 {TclCompileCatchCmd: recover from error, [Bug 705406]} { 134 proc foo {} { 135 catch { 136 if {[a]} { 137 if b {} 138 } 139 } 140 } 141 list [catch foo msg] $msg 142} {0 1} 143test compile-3.6 {TclCompileCatchCmd: error in storing result [Bug 3098302]} {*}{ 144 -setup { 145 namespace eval catchtest { 146 variable result1 {} 147 } 148 trace add variable catchtest::result1 write catchtest::failtrace 149 proc catchtest::failtrace {n1 n2 op} { 150 return -code error "trace on $n1 fails by request" 151 } 152 } 153 -body { 154 proc catchtest::x {} { 155 variable result1 156 set count 0 157 for {set i 0} {$i < 10} {incr i} { 158 set status2 [catch { 159 set status1 [catch { 160 return -code error -level 0 "original failure" 161 } result1 options1] 162 } result2 options2] 163 incr count 164 } 165 list $count $result2 166 } 167 catchtest::x 168 } 169 -result {10 {can't set "result1": trace on result1 fails by request}} 170 -cleanup {namespace delete catchtest} 171} 172 173test compile-3.7 {TclCompileCatchCmd: error in storing options [Bug 3098302]} {*}{ 174 -setup { 175 namespace eval catchtest { 176 variable options1 {} 177 } 178 trace add variable catchtest::options1 write catchtest::failtrace 179 proc catchtest::failtrace {n1 n2 op} { 180 return -code error "trace on $n1 fails by request" 181 } 182 } 183 -body { 184 proc catchtest::x {} { 185 variable options1 186 set count 0 187 for {set i 0} {$i < 10} {incr i} { 188 set status2 [catch { 189 set status1 [catch { 190 return -code error -level 0 "original failure" 191 } result1 options1] 192 } result2 options2] 193 incr count 194 } 195 list $count $result2 196 } 197 catchtest::x 198 } 199 -result {10 {can't set "options1": trace on options1 fails by request}} 200 -cleanup {namespace delete catchtest} 201} 202 203test compile-4.1 {TclCompileForCmd: command substituted test expression} { 204 set i 0 205 set j 0 206 # Should be "forever" 207 for {} [expr {$i < 3}] {} { 208 set j [incr i] 209 if {$j > 3} break 210 } 211 set j 212} {4} 213 214test compile-5.1 {TclCompileForeachCmd: exception stack} { 215 proc foreach-exception-test {} { 216 foreach array(index) [list 1 2 3] break 217 foreach array(index) [list 1 2 3] break 218 foreach scalar [list 1 2 3] break 219 } 220 list [catch foreach-exception-test result] $result 221} {0 {}} 222test compile-5.2 {TclCompileForeachCmd: non-local variables} { 223 set ::foo 1 224 proc foreach-test {} { 225 foreach ::foo {1 2 3} {} 226 } 227 foreach-test 228 set ::foo 229} 3 230test compile-5.3 {TclCompileForeachCmd: [Bug b9b2079e6d]} -setup { 231 proc demo {} { 232 foreach x y { 233 if 1 break else 234 } 235 } 236} -body { 237 demo 238} -cleanup { 239 rename demo {} 240} -returnCodes error -result {wrong # args: no script following "else" argument} 241 242test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} -setup { 243 catch {unset x} 244 catch {unset y} 245} -body { 246 set x 123 247 proc p {} { 248 set ::y 789 249 return $::y 250 } 251 list $::x [expr {"x" in [info globals]}] \ 252 [p] $::y [expr {"y" in [info globals]}] 253} -result {123 1 789 789 1} 254test compile-6.2 {TclCompileSetCmd: global array names with ::s} -setup { 255 catch {unset a} 256} -body { 257 set ::a(1) 2 258 proc p {} { 259 set ::a(1) 1 260 return $::a($::a(1)) 261 } 262 list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {"a" in [info globals]}] 263} -result {2 1 3 3 1} 264test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} -setup { 265 catch {namespace delete test_ns_compile} 266 catch {unset x} 267} -body { 268 namespace eval test_ns_compile { 269 variable v hello 270 variable arr 271 set ::x $::test_ns_compile::v 272 set ::test_ns_compile::arr(1) 123 273 } 274 list $::x $::test_ns_compile::arr(1) 275} -result {hello 123} 276 277test compile-7.1 {TclCompileWhileCmd: command substituted test expression} { 278 set i 0 279 set j 0 280 # Should be "forever" 281 while [expr {$i < 3}] { 282 set j [incr i] 283 if {$j > 3} break 284 } 285 set j 286} {4} 287 288test compile-8.1 {CollectArgInfo: binary data} { 289 list [catch "string length \x00foo" msg] $msg 290} {0 4} 291test compile-8.2 {CollectArgInfo: binary data} { 292 list [catch "string length foo\x00" msg] $msg 293} {0 4} 294test compile-8.3 {CollectArgInfo: handle "]" at end of command properly} { 295 set x ] 296} {]} 297 298test compile-9.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} { 299 proc p {} { 300 set x {} 301 eval $x 302 append x { } 303 eval $x 304 } 305 p 306} {} 307 308test compile-10.1 {BLACKBOX: exception stack overflow} { 309 set x {{0}} 310 set y 0 311 while {$y < 100} { 312 if !$x {incr y} 313 } 314} {} 315 316test compile-11.1 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { 317 apply {{} { 318 # shared object - Interp result && Var 'r' 319 set r [list foobar] 320 # command that will add error to result 321 lindex a bogus 322 }} 323} -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?} 324test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { 325 apply {{} { set r [list foobar] ; string index a bogus }} 326} -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?} 327test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { 328 apply {{} { set r [list foobar] ; string index a 0o9 }} 329} -returnCodes error -match glob -result {*invalid octal number*} 330test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { 331 apply {{} { set r [list foobar] ; array set var {one two many} }} 332} -returnCodes error -result {list must have an even number of elements} 333test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { 334 apply {{} { set r [list foobar] ; incr foo bar baz}} 335} -returnCodes error -result {wrong # args: should be "incr varName ?increment?"} 336test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { 337 apply {{} { set r [list foobar] ; incr}} 338} -returnCodes error -result {wrong # args: should be "incr varName ?increment?"} 339test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { 340 apply {{} { set r [list foobar] ; expr [concat !a] }} 341} -returnCodes error -match glob -result * 342test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { 343 apply {{} { set r [list foobar] ; expr {!a} }} 344} -returnCodes error -match glob -result * 345test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { 346 apply {{} { set r [list foobar] ; llength "\{" }} 347 list [catch {p} msg] $msg 348} -returnCodes error -result {unmatched open brace in list} 349 350# 351# Special section for tests of tclLiteral.c 352# The following tests check for incorrect memory handling in 353# TclReleaseLiteral. They are only effective when tcl is compiled with 354# TCL_MEM_DEBUG 355# 356# Special test for leak on interp delete [Bug 467523]. 357test compile-12.1 {testing literal leak on interp delete} -setup { 358 proc getbytes {} { 359 set lines [split [memory info] "\n"] 360 lindex $lines 3 3 361 } 362} -constraints memory -body { 363 set end [getbytes] 364 for {set i 0} {$i < 5} {incr i} { 365 interp create foo 366 foo eval { 367 namespace eval bar {} 368 } 369 interp delete foo 370 set tmp $end 371 set end [getbytes] 372 } 373 set leakedBytes [expr {$end - $tmp}] 374} -cleanup { 375 rename getbytes {} 376 unset -nocomplain end i tmp leakedBytes 377} -result 0 378# Special test for a memory error in a preliminary fix of [Bug 467523]. It 379# requires executing a helpfile. Presumably the child process is used because 380# when this test fails, it crashes. 381test compile-12.2 {testing error on literal deletion} -constraints {memory exec} -body { 382 set sourceFile [makeFile { 383 for {set i 0} {$i < 5} {incr i} { 384 namespace eval bar {} 385 namespace delete bar 386 } 387 puts 0 388 } source.file] 389 exec [interpreter] $sourceFile 390} -cleanup { 391 catch {removeFile $sourceFile} 392} -result 0 393# Test to catch buffer overrun in TclCompileTokens from buf 530320 394test compile-12.3 {check for a buffer overrun} -body { 395 proc crash {} { 396 puts $array([expr {a+2}]) 397 } 398 crash 399} -returnCodes error -cleanup { 400 rename crash {} 401} -match glob -result * 402test compile-12.4 {TclCleanupLiteralTable segfault} -body { 403 # Tcl Bug 1001997 404 # Here, we're trying to test a case that causes a crash in 405 # TclCleanupLiteralTable. The conditions that we're trying to establish 406 # are: 407 # - TclCleanupLiteralTable is attempting to clean up a bytecode object in 408 # the literal table. 409 # - The bytecode object in question contains the only reference to another 410 # literal. 411 # - The literal in question is in the same hash bucket as the bytecode 412 # object, and immediately follows it in the chain. 413 # Since newly registered literals are added at the FRONT of the bucket 414 # chains, and since the bytecode object is registered before its literals, 415 # this is difficult to achieve. What we do is: 416 # (a) do a [namespace eval] of a string that's calculated to hash into 417 # the same bucket as a literal that it contains. In this case, the 418 # script and the variable 'bugbug' land in the same bucket. 419 # (b) do a [namespace eval] of a string that contains enough literals to 420 # force TclRegisterLiteral to rebuild the global literal table. The 421 # newly created hash buckets will contain the literals, IN REVERSE 422 # ORDER, thus putting the bytecode immediately ahead of 'bugbug' and 423 # 'bug4345bug'. The bytecode object will contain the only references 424 # to those two literals. 425 # (c) Delete the interpreter to invoke TclCleanupLiteralTable and tickle 426 # the bug. 427 proc foo {} { 428 set i [interp create] 429 $i eval { 430 namespace eval ::w {concat 4649; variable bugbug} 431 namespace eval ::w { 432 concat x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 \ 433 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 \ 434 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 \ 435 x31 x32 X33 X34 X35 X36 X37 X38 X39 X40 \ 436 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 \ 437 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 \ 438 x61 x62 x63 x64 439 concat y1 y2 y3 y4 y5 y6 y7 y8 y9 y10 \ 440 y11 y12 y13 y14 y15 y16 y17 y18 y19 y20 \ 441 y21 y22 y23 y24 y25 y26 y27 y28 y29 y30 \ 442 y31 y32 Y33 Y34 Y35 Y36 Y37 Y38 Y39 Y40 \ 443 y41 y42 y43 y44 y45 y46 y47 y48 y49 y50 \ 444 y51 y52 y53 y54 y55 y56 y57 y58 y59 y60 \ 445 y61 y62 y63 y64 446 concat z1 z2 z3 z4 z5 z6 z7 z8 z9 z10 \ 447 z11 z12 z13 z14 z15 z16 z17 z18 z19 z20 \ 448 z21 z22 z23 z24 z25 z26 z27 z28 z29 z30 \ 449 z31 z32 450 } 451 } 452 interp delete $i; # must not crash 453 return ok 454 } 455 foo 456} -cleanup { 457 rename foo {} 458} -result ok 459 460# Special test for underestimating the maxStackSize required for a compiled 461# command. A failure will cause a segfault in the child process. 462test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} { 463 set body {set x [list} 464 for {set i 0} {$i < 3000} {incr i} { 465 append body " $i" 466 } 467 append body {]; puts OK} 468 regsub BODY {proc crash {} {BODY}; crash} $body script 469 list [catch {exec [interpreter] << $script} msg] $msg 470} {0 OK} 471 472# Tests of nested compile (body in body compilation), should not generate stack overflow 473# (with abnormal program termination), bug [fec0c17d39]: 474proc _ti_gencode {} { 475 # creates test interpreter on demand with [gencode] generator: 476 if {[interp exists ti]} { 477 return 478 } 479 interp create ti 480 ti eval {proc gencode {nr {cmd eval} {nl 0}} { 481 set code "" 482 set e ""; if {$nl} {set e "\n"} 483 for {set i 0} {$i < $nr} {incr i} { 484 append code "$cmd \{$e" 485 } 486 append code "lappend result 1$e" 487 for {set i 0} {$i < $nr} {incr i} { 488 append code "\}$e" 489 } 490 #puts [format "%% %.40s ... %d bytes" $code [string length $code]] 491 return $code 492 }} 493} 494test compile-13.2 {TclCompileScript: testing expected nested scripts compilation} -setup { 495 _ti_gencode 496 interp recursionlimit ti [expr {10000+50}] 497 ti eval {set result {}} 498} -body { 499 # Test different compilation variants (instructions evalStk, invokeStk, etc), 500 # with 1500 (1000 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack 501 # boxes or systems, please don't decrease it (either provide a constraint) 502 ti eval {foreach cmd {eval "if 1" try catch} { 503 set c [gencode [expr {![::tcl::pkgconfig get debug] ? 1500 : 1000}] $cmd] 504 if 1 $c 505 }} 506 ti eval {set result} 507} -result {1 1 1 1} 508test compile-13.3 {TclCompileScript: testing check of max depth by nested scripts compilation} -setup { 509 _ti_gencode 510 interp recursionlimit ti 100 511 ti eval {set result {}} 512} -body { 513 # Test different compilation variants (instructions evalStk, invokeStk, etc), 514 # with 500 nested scripts (bodies). It must generate "too many nested compilations" 515 # error for any variant we're testing here: 516 ti eval {foreach cmd {eval "if 1" try catch} { 517 set c [gencode 500 $cmd] 518 lappend errors [catch $c e] $e 519 }} 520 #puts $errors 521 # all of nested calls exceed the limit, so must end with "too many nested compilations" 522 # (or evaluations, depending on compile method/instruction and "mixed" compile within 523 # evaliation), so no one succeeds, the result must be empty: 524 ti eval {set result} 525} -result {} 526# 527# clean up: 528if {[interp exists ti]} { 529 interp delete ti 530} 531rename _ti_gencode {} 532 533# Tests compile-14.* for [Bug 599788] [Bug 0c043a175a47da8c2342] 534test compile-14.1 {testing errors in element name; segfault?} {} { 535 catch {set a([error])} msg1 536 catch {set bubba([join $abba $jubba]) $vol} msg2 537 list $msg1 $msg2 538} {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}} 539 540test compile-14.2 {testing element name "$"} -body { 541 unset -nocomplain a 542 set a() 1 543 set a(1) 2 544 set a($) 3 545 list [set a()] [set a(1)] [set a($)] [unset a() a(1); lindex [array names a] 0] 546} -cleanup {unset a} -result [list 1 2 3 {$}] 547 548 549# Tests compile-15.* cover Tcl Bug 633204 550test compile-15.1 {proper TCL_RETURN code from [return]} { 551 apply {{} {catch return}} 552} 2 553test compile-15.2 {proper TCL_RETURN code from [return]} { 554 apply {{} {catch {return foo}}} 555} 2 556test compile-15.3 {proper TCL_RETURN code from [return]} { 557 apply {{} {catch {return $::tcl_library}}} 558} 2 559test compile-15.4 {proper TCL_RETURN code from [return]} { 560 apply {{} {catch {return [info library]}}} 561} 2 562test compile-15.5 {proper TCL_RETURN code from [return]} { 563 apply {{} {catch {set a 1}; return}} 564} "" 565 566# Do all tests once byte compiled and once with direct string evaluation 567foreach noComp {0 1} { 568 569if {$noComp} { 570 interp alias {} run {} testevalex 571 set constraints testevalex 572} else { 573 interp alias {} run {} if 1 574 set constraints {} 575} 576 577test compile-16.1.$noComp {TclCompileScript: word expansion} $constraints { 578 run "list [string repeat {{*}a } 255]" 579} [lrepeat 255 a] 580test compile-16.2.$noComp {TclCompileScript: word expansion} $constraints { 581 run "list [string repeat {{*}a } 256]" 582} [lrepeat 256 a] 583test compile-16.3.$noComp {TclCompileScript: word expansion} $constraints { 584 run "list [string repeat {{*}a } 257]" 585} [lrepeat 257 a] 586test compile-16.4.$noComp {TclCompileScript: word expansion} $constraints { 587 run {{*}list} 588} {} 589test compile-16.5.$noComp {TclCompileScript: word expansion} $constraints { 590 run {{*}list {*}{x y z}} 591} {x y z} 592test compile-16.6.$noComp {TclCompileScript: word expansion} $constraints { 593 run {{*}list {*}[list x y z]} 594} {x y z} 595test compile-16.7.$noComp {TclCompileScript: word expansion} $constraints { 596 run {{*}list {*}[list x y z][list x y z]} 597} {x y zx y z} 598test compile-16.8.$noComp {TclCompileScript: word expansion} -body { 599 set l {x y z} 600 run {{*}list {*}$l} 601} -constraints $constraints -cleanup { 602 unset l 603} -result {x y z} 604test compile-16.9.$noComp {TclCompileScript: word expansion} -body { 605 set l {x y z} 606 run {{*}list {*}$l$l} 607} -constraints $constraints -cleanup { 608 unset l 609} -result {x y zx y z} 610test compile-16.10.$noComp {TclCompileScript: word expansion} -body { 611 run {{*}\{} 612} -constraints $constraints -returnCodes error \ 613-result {unmatched open brace in list} 614test compile-16.11.$noComp {TclCompileScript: word expansion} -body { 615 proc badList {} {return \{} 616 run {{*}[badList]} 617} -constraints $constraints -cleanup { 618 rename badList {} 619} -returnCodes error -result {unmatched open brace in list} 620test compile-16.12.$noComp {TclCompileScript: word expansion} $constraints { 621 run {{*}list x y z} 622} {x y z} 623test compile-16.13.$noComp {TclCompileScript: word expansion} $constraints { 624 run {{*}list x y {*}z} 625} {x y z} 626test compile-16.14.$noComp {TclCompileScript: word expansion} $constraints { 627 run {{*}list x {*}y z} 628} {x y z} 629test compile-16.15.$noComp {TclCompileScript: word expansion} $constraints { 630 run {list x y {*}z} 631} {x y z} 632test compile-16.16.$noComp {TclCompileScript: word expansion} $constraints { 633 run {list x {*}y z} 634} {x y z} 635test compile-16.17.$noComp {TclCompileScript: word expansion} $constraints { 636 run {list {*}x y z} 637} {x y z} 638 639# These tests note that expansion can in theory cause the number of arguments 640# to a command to exceed INT_MAX, which is as big as objc is allowed to get. 641# 642# In practice, it seems we will run out of memory before we confront this 643# issue. Note that compiled operations run out of memory at smaller objc 644# values than direct string evaluation. 645# 646# These tests are constrained as knownBug because they are likely to cause 647# memory allocation panics somewhere, and we don't want panics in the test 648# suite. 649# 650test compile-16.18.$noComp {TclCompileScript: word expansion} -body { 651 proc LongList {} {return [lrepeat [expr {1<<10}] x]} 652 llength [run "list [string repeat {{*}[LongList] } [expr {1<<10}]]"] 653} -constraints [linsert $constraints 0 knownBug] -cleanup { 654 rename LongList {} 655} -returnCodes ok -result [expr {1<<20}] 656test compile-16.19.$noComp {TclCompileScript: word expansion} -body { 657 proc LongList {} {return [lrepeat [expr {1<<11}] x]} 658 llength [run "list [string repeat {{*}[LongList] } [expr {1<<11}]]"] 659} -constraints [linsert $constraints 0 knownBug] -cleanup { 660 rename LongList {} 661} -returnCodes ok -result [expr {1<<22}] 662test compile-16.20.$noComp {TclCompileScript: word expansion} -body { 663 proc LongList {} {return [lrepeat [expr {1<<12}] x]} 664 llength [run "list [string repeat {{*}[LongList] } [expr {1<<12}]]"] 665} -constraints [linsert $constraints 0 knownBug] -cleanup { 666 rename LongList {} 667} -returnCodes ok -result [expr {1<<24}] 668# This is the one that should cause overflow 669test compile-16.21.$noComp {TclCompileScript: word expansion} -body { 670 proc LongList {} {return [lrepeat [expr {1<<16}] x]} 671 llength [run "list [string repeat {{*}[LongList] } [expr {1<<16}]]"] 672} -constraints [linsert $constraints 0 knownBug] -cleanup { 673 rename LongList {} 674} -returnCodes ok -result [expr {wide(1)<<32}] 675test compile-16.22.$noComp { 676 Bug 845412: TclCompileScript: word expansion not mandatory 677} -body { 678 # This test may crash and will fail unless Bug 845412 is fixed. 679 proc ReturnResults args {return $args} 680 run "ReturnResults [string repeat {x } 260]" 681} -constraints $constraints -cleanup { 682 rename ReturnResults {} 683} -returnCodes ok -result [string trim [string repeat {x } 260]] 684test compile-16.23.$noComp { 685 Bug 1032805: defer parse error until run time 686} -constraints $constraints -body { 687 namespace eval x { 688 run { 689 proc if {a b} {uplevel 1 [list set $a $b]} 690 if 1 {syntax {}{}} 691 } 692 } 693} -cleanup { 694 namespace delete x 695} -returnCodes ok -result {syntax {}{}} 696test compile-16.24.$noComp { 697 Bug 1638414: bad list constant as first expanded term 698} -constraints $constraints -body { 699 run "{*}\"\{foo bar\"" 700} -returnCodes error -result {unmatched open brace in list} 701test compile-16.25.$noComp {TclCompileScript: word expansion, naked backslashes} $constraints { 702 run {list {*}{a \n b}} 703} {a { 704} b} 705test compile-16.26.$noComp {TclCompileScript: word expansion, protected backslashes} $constraints { 706 run {list {*}{a {\n} b}} 707} {a {\n} b} 708} ;# End of noComp loop 709 710# These tests are messy because it wrecks the interpreter it runs in! They 711# demonstrate issues arising from [FRQ 1101710] 712test compile-17.1 {Command interpretation binding for compiled code} -constraints knownBug -setup { 713 set i [interp create] 714} -body { 715 $i eval { 716 if 1 { 717 expr [ 718 proc expr args {return substituted} 719 format {[subst compiled]} 720 ] 721 } 722 } 723} -cleanup { 724 interp delete $i 725} -result substituted 726test compile-17.2 {Command interpretation binding for non-compiled code} -setup { 727 set i [interp create] 728} -body { 729 $i eval { 730 if 1 { 731 [subst expr] [ 732 proc expr args {return substituted} 733 format {[subst compiled]} 734 ] 735 } 736 } 737} -cleanup { 738 interp delete $i 739} -result substituted 740 741# This tests the supported parts of the unsupported [disassemble] command. It 742# does not check the format of disassembled bytecode though; that's liable to 743# change without warning. 744 745set disassemblables [linsert [join { 746 constructor destructor lambda method objmethod proc script 747} ", "] end-1 or] 748test compile-18.1 {disassembler - basics} -returnCodes error -body { 749 tcl::unsupported::disassemble 750} -match glob -result {wrong # args: should be "*"} 751test compile-18.2 {disassembler - basics} -returnCodes error -body { 752 tcl::unsupported::disassemble ? 753} -result "bad type \"?\": must be $disassemblables" 754test compile-18.3 {disassembler - basics} -returnCodes error -body { 755 tcl::unsupported::disassemble lambda 756} -match glob -result {wrong # args: should be "* lambda lambdaTerm"} 757test compile-18.4 {disassembler - basics} -returnCodes error -body { 758 tcl::unsupported::disassemble lambda \{ 759} -result "can't interpret \"\{\" as a lambda expression" 760test compile-18.5 {disassembler - basics} -body { 761 # Allow any string: the result format is not defined anywhere! 762 tcl::unsupported::disassemble lambda {{} {}} 763} -match glob -result * 764test compile-18.6 {disassembler - basics} -returnCodes error -body { 765 tcl::unsupported::disassemble proc 766} -match glob -result {wrong # args: should be "* proc procName"} 767test compile-18.7 {disassembler - basics} -returnCodes error -body { 768 tcl::unsupported::disassemble proc nosuchproc 769} -result {"nosuchproc" isn't a procedure} 770test compile-18.8 {disassembler - basics} -setup { 771 proc chewonthis {} {} 772} -body { 773 # Allow any string: the result format is not defined anywhere! 774 tcl::unsupported::disassemble proc chewonthis 775} -cleanup { 776 rename chewonthis {} 777} -match glob -result * 778test compile-18.9 {disassembler - basics} -returnCodes error -body { 779 tcl::unsupported::disassemble script 780} -match glob -result {wrong # args: should be "* script script"} 781test compile-18.10 {disassembler - basics} -body { 782 # Allow any string: the result format is not defined anywhere! 783 tcl::unsupported::disassemble script {} 784} -match glob -result * 785test compile-18.11 {disassembler - basics} -returnCodes error -body { 786 tcl::unsupported::disassemble method 787} -match glob -result {wrong # args: should be "* method className methodName"} 788test compile-18.12 {disassembler - basics} -returnCodes error -body { 789 tcl::unsupported::disassemble method nosuchclass foo 790} -result {nosuchclass does not refer to an object} 791test compile-18.13 {disassembler - basics} -returnCodes error -setup { 792 oo::object create justanobject 793} -body { 794 tcl::unsupported::disassemble method justanobject foo 795} -cleanup { 796 justanobject destroy 797} -result {"justanobject" is not a class} 798test compile-18.14 {disassembler - basics} -returnCodes error -body { 799 tcl::unsupported::disassemble method oo::object nosuchmethod 800} -result {unknown method "nosuchmethod"} 801test compile-18.15 {disassembler - basics} -setup { 802 oo::class create foo {method bar {} {}} 803} -body { 804 # Allow any string: the result format is not defined anywhere! 805 tcl::unsupported::disassemble method foo bar 806} -cleanup { 807 foo destroy 808} -match glob -result * 809test compile-18.16 {disassembler - basics} -returnCodes error -body { 810 tcl::unsupported::disassemble objmethod 811} -match glob -result {wrong # args: should be "* objmethod objectName methodName"} 812test compile-18.17 {disassembler - basics} -returnCodes error -body { 813 tcl::unsupported::disassemble objmethod nosuchobject foo 814} -result {nosuchobject does not refer to an object} 815test compile-18.18 {disassembler - basics} -returnCodes error -body { 816 tcl::unsupported::disassemble objmethod oo::object nosuchmethod 817} -result {unknown method "nosuchmethod"} 818test compile-18.19 {disassembler - basics} -setup { 819 oo::object create foo 820 oo::objdefine foo {method bar {} {}} 821} -body { 822 # Allow any string: the result format is not defined anywhere! 823 tcl::unsupported::disassemble objmethod foo bar 824} -cleanup { 825 foo destroy 826} -match glob -result * 827# There never was a compile-18.20. 828# The keys of the dictionary produced by [getbytecode] are defined. 829set bytecodekeys {literals variables exception instructions auxiliary commands script namespace stackdepth exceptdepth} 830test compile-18.21 {disassembler - basics} -returnCodes error -body { 831 tcl::unsupported::getbytecode 832} -match glob -result {wrong # args: should be "*"} 833test compile-18.22 {disassembler - basics} -returnCodes error -body { 834 tcl::unsupported::getbytecode ? 835} -result "bad type \"?\": must be $disassemblables" 836test compile-18.23 {disassembler - basics} -returnCodes error -body { 837 tcl::unsupported::getbytecode lambda 838} -match glob -result {wrong # args: should be "* lambda lambdaTerm"} 839test compile-18.24 {disassembler - basics} -returnCodes error -body { 840 tcl::unsupported::getbytecode lambda \{ 841} -result "can't interpret \"\{\" as a lambda expression" 842test compile-18.25 {disassembler - basics} -body { 843 dict keys [tcl::unsupported::getbytecode lambda {{} {}}] 844} -result "$bytecodekeys initiallinenumber sourcefile" 845test compile-18.26 {disassembler - basics} -returnCodes error -body { 846 tcl::unsupported::getbytecode proc 847} -match glob -result {wrong # args: should be "* proc procName"} 848test compile-18.27 {disassembler - basics} -returnCodes error -body { 849 tcl::unsupported::getbytecode proc nosuchproc 850} -result {"nosuchproc" isn't a procedure} 851test compile-18.28 {disassembler - basics} -setup { 852 proc chewonthis {} {} 853} -body { 854 dict keys [tcl::unsupported::getbytecode proc chewonthis] 855} -cleanup { 856 rename chewonthis {} 857} -result "$bytecodekeys initiallinenumber sourcefile" 858test compile-18.28.1 {disassembler - tricky bit} -setup { 859 eval [list proc chewonthis {} {}] 860} -body { 861 dict keys [tcl::unsupported::getbytecode proc chewonthis] 862} -cleanup { 863 rename chewonthis {} 864} -result $bytecodekeys 865test compile-18.28.2 {disassembler - tricky bit} -setup { 866 eval {proc chewonthis {} {}} 867} -body { 868 dict keys [tcl::unsupported::getbytecode proc chewonthis] 869} -cleanup { 870 rename chewonthis {} 871} -result "$bytecodekeys initiallinenumber sourcefile" 872test compile-18.28.3 {disassembler - tricky bit} -setup { 873 proc Proc {n a b} { 874 proc $n $a $b 875 } 876 Proc chewonthis {} {} 877} -body { 878 dict keys [tcl::unsupported::getbytecode proc chewonthis] 879} -cleanup { 880 rename Proc {} 881 rename chewonthis {} 882} -result $bytecodekeys 883test compile-18.28.4 {disassembler - tricky bit} -setup { 884 proc Proc {n a b} { 885 tailcall proc $n $a $b 886 } 887 Proc chewonthis {} {} 888} -body { 889 dict keys [tcl::unsupported::getbytecode proc chewonthis] 890} -cleanup { 891 rename Proc {} 892 rename chewonthis {} 893} -result "$bytecodekeys initiallinenumber sourcefile" 894test compile-18.29 {disassembler - basics} -returnCodes error -body { 895 tcl::unsupported::getbytecode script 896} -match glob -result {wrong # args: should be "* script script"} 897test compile-18.30 {disassembler - basics} -body { 898 dict keys [tcl::unsupported::getbytecode script {}] 899} -result $bytecodekeys 900test compile-18.31 {disassembler - basics} -returnCodes error -body { 901 tcl::unsupported::getbytecode method 902} -match glob -result {wrong # args: should be "* method className methodName"} 903test compile-18.32 {disassembler - basics} -returnCodes error -body { 904 tcl::unsupported::getbytecode method nosuchclass foo 905} -result {nosuchclass does not refer to an object} 906test compile-18.33 {disassembler - basics} -returnCodes error -setup { 907 oo::object create justanobject 908} -body { 909 tcl::unsupported::getbytecode method justanobject foo 910} -cleanup { 911 justanobject destroy 912} -result {"justanobject" is not a class} 913test compile-18.34 {disassembler - basics} -returnCodes error -body { 914 tcl::unsupported::getbytecode method oo::object nosuchmethod 915} -result {unknown method "nosuchmethod"} 916test compile-18.35 {disassembler - basics} -setup { 917 oo::class create foo {method bar {} {}} 918} -body { 919 dict keys [tcl::unsupported::getbytecode method foo bar] 920} -cleanup { 921 foo destroy 922} -result "$bytecodekeys initiallinenumber sourcefile" 923test compile-18.36 {disassembler - basics} -returnCodes error -body { 924 tcl::unsupported::getbytecode objmethod 925} -match glob -result {wrong # args: should be "* objmethod objectName methodName"} 926test compile-18.37 {disassembler - basics} -returnCodes error -body { 927 tcl::unsupported::getbytecode objmethod nosuchobject foo 928} -result {nosuchobject does not refer to an object} 929test compile-18.38 {disassembler - basics} -returnCodes error -body { 930 tcl::unsupported::getbytecode objmethod oo::object nosuchmethod 931} -result {unknown method "nosuchmethod"} 932test compile-18.39 {disassembler - basics} -setup { 933 oo::object create foo 934 oo::objdefine foo {method bar {} {}} 935} -body { 936 dict keys [tcl::unsupported::getbytecode objmethod foo bar] 937} -cleanup { 938 foo destroy 939} -result "$bytecodekeys initiallinenumber sourcefile" 940test compile-18.40 {disassembler - basics} -returnCodes error -body { 941 tcl::unsupported::disassemble constructor 942} -match glob -result {wrong # args: should be "* constructor className"} 943test compile-18.41 {disassembler - basics} -returnCodes error -body { 944 tcl::unsupported::disassemble constructor nosuchclass 945} -result {nosuchclass does not refer to an object} 946test compile-18.42 {disassembler - basics} -returnCodes error -setup { 947 oo::object create justanobject 948} -body { 949 tcl::unsupported::disassemble constructor justanobject 950} -cleanup { 951 justanobject destroy 952} -result {"justanobject" is not a class} 953test compile-18.43 {disassembler - basics} -returnCodes error -setup { 954 oo::class create constructorless 955} -body { 956 tcl::unsupported::disassemble constructor constructorless 957} -cleanup { 958 constructorless destroy 959} -result {"constructorless" has no defined constructor} 960test compile-18.44 {disassembler - basics} -setup { 961 oo::class create foo {constructor {} {set x 1}} 962} -body { 963 # Allow any string: the result format is not defined anywhere! 964 tcl::unsupported::disassemble constructor foo 965} -cleanup { 966 foo destroy 967} -match glob -result * 968test compile-18.45 {disassembler - basics} -returnCodes error -body { 969 tcl::unsupported::getbytecode constructor 970} -match glob -result {wrong # args: should be "* constructor className"} 971test compile-18.46 {disassembler - basics} -returnCodes error -body { 972 tcl::unsupported::getbytecode constructor nosuchobject 973} -result {nosuchobject does not refer to an object} 974test compile-18.47 {disassembler - basics} -returnCodes error -setup { 975 oo::class create constructorless 976} -body { 977 tcl::unsupported::getbytecode constructor constructorless 978} -cleanup { 979 constructorless destroy 980} -result {"constructorless" has no defined constructor} 981test compile-18.48 {disassembler - basics} -setup { 982 oo::class create foo {constructor {} {set x 1}} 983} -body { 984 dict keys [tcl::unsupported::getbytecode constructor foo] 985} -cleanup { 986 foo destroy 987} -result "$bytecodekeys" 988# There is no compile-18.49 989test compile-18.50 {disassembler - basics} -returnCodes error -body { 990 tcl::unsupported::disassemble destructor 991} -match glob -result {wrong # args: should be "* destructor className"} 992test compile-18.51 {disassembler - basics} -returnCodes error -body { 993 tcl::unsupported::disassemble destructor nosuchclass 994} -result {nosuchclass does not refer to an object} 995test compile-18.52 {disassembler - basics} -returnCodes error -setup { 996 oo::object create justanobject 997} -body { 998 tcl::unsupported::disassemble destructor justanobject 999} -cleanup { 1000 justanobject destroy 1001} -result {"justanobject" is not a class} 1002test compile-18.53 {disassembler - basics} -returnCodes error -setup { 1003 oo::class create constructorless 1004} -body { 1005 tcl::unsupported::disassemble destructor constructorless 1006} -cleanup { 1007 constructorless destroy 1008} -result {"constructorless" has no defined destructor} 1009test compile-18.54 {disassembler - basics} -setup { 1010 oo::class create foo {destructor {set x 1}} 1011} -body { 1012 # Allow any string: the result format is not defined anywhere! 1013 tcl::unsupported::disassemble destructor foo 1014} -cleanup { 1015 foo destroy 1016} -match glob -result * 1017test compile-18.55 {disassembler - basics} -returnCodes error -body { 1018 tcl::unsupported::getbytecode destructor 1019} -match glob -result {wrong # args: should be "* destructor className"} 1020test compile-18.56 {disassembler - basics} -returnCodes error -body { 1021 tcl::unsupported::getbytecode destructor nosuchobject 1022} -result {nosuchobject does not refer to an object} 1023test compile-18.57 {disassembler - basics} -returnCodes error -setup { 1024 oo::class create constructorless 1025} -body { 1026 tcl::unsupported::getbytecode destructor constructorless 1027} -cleanup { 1028 constructorless destroy 1029} -result {"constructorless" has no defined destructor} 1030test compile-18.58 {disassembler - basics} -setup { 1031 oo::class create foo {destructor {set x 1}} 1032} -body { 1033 dict keys [tcl::unsupported::getbytecode destructor foo] 1034} -cleanup { 1035 foo destroy 1036} -result "$bytecodekeys" 1037 1038test compile-19.0 {Bug 3614102: reset stack housekeeping} -body { 1039 # This will panic in a --enable-symbols=compile build, unless bug is fixed. 1040 apply {{} {list [if 1]}} 1041} -returnCodes error -match glob -result * 1042 1043test compile-20.1 {ensure there are no infinite loops in optimizing} { 1044 tcl::unsupported::disassemble script { 1045 while 1 { 1046 return -code continue -level 0 1047 } 1048 } 1049 return 1050} {} 1051test compile-20.2 {ensure there are no infinite loops in optimizing} { 1052 tcl::unsupported::disassemble script { 1053 while 1 { 1054 while 1 { 1055 return -code break -level 0 1056 } 1057 } 1058 } 1059 return 1060} {} 1061 1062test compile-21.1 {stack balance management} { 1063 apply {{} { 1064 set result {} 1065 while 1 { 1066 lappend result a 1067 lappend result [list b [break]] 1068 lappend result c 1069 } 1070 return $result 1071 }} 1072} a 1073test compile-21.2 {stack balance management} { 1074 apply {{} { 1075 set result {} 1076 while {[incr i] <= 10} { 1077 lappend result $i 1078 lappend result [list b [continue] c] 1079 lappend result c 1080 } 1081 return $result 1082 }} 1083} {1 2 3 4 5 6 7 8 9 10} 1084test compile-21.3 {stack balance management} { 1085 apply {args { 1086 set result {} 1087 while 1 { 1088 lappend result a 1089 lappend result [concat {*}$args [break]] 1090 lappend result c 1091 } 1092 return $result 1093 }} P Q R S T 1094} a 1095test compile-21.4 {stack balance management} { 1096 apply {args { 1097 set result {} 1098 while {[incr i] <= 10} { 1099 lappend result $i 1100 lappend result [concat {*}$args [continue] c] 1101 lappend result c 1102 } 1103 return $result 1104 }} P Q R S T 1105} {1 2 3 4 5 6 7 8 9 10} 1106 1107# TODO sometime - check that bytecode from tbcload is *not* disassembled. 1108 1109# cleanup 1110catch {rename p ""} 1111catch {namespace delete test_ns_compile} 1112catch {unset x} 1113catch {unset y} 1114catch {unset a} 1115::tcltest::cleanupTests 1116return 1117 1118# Local Variables: 1119# mode: tcl 1120# fill-column: 78 1121# End: 1122