[25] | 1 | # This file contains tests for the files tclCompile.c, tclCompCmds.c |
---|
| 2 | # and tclLiteral.c |
---|
| 3 | # |
---|
| 4 | # This file contains a collection of tests for one or more of the Tcl |
---|
| 5 | # built-in commands. Sourcing this file into Tcl runs the tests and |
---|
| 6 | # generates output for errors. No output means no errors were found. |
---|
| 7 | # |
---|
| 8 | # Copyright (c) 1997 by Sun Microsystems, Inc. |
---|
| 9 | # Copyright (c) 1998-1999 by Scriptics Corporation. |
---|
| 10 | # |
---|
| 11 | # See the file "license.terms" for information on usage and redistribution |
---|
| 12 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 13 | # |
---|
| 14 | # RCS: @(#) $Id: compile.test,v 1.48 2007/12/13 15:26:06 dgp Exp $ |
---|
| 15 | |
---|
| 16 | package require tcltest 2 |
---|
| 17 | namespace import -force ::tcltest::* |
---|
| 18 | |
---|
| 19 | testConstraint exec [llength [info commands exec]] |
---|
| 20 | testConstraint memory [llength [info commands memory]] |
---|
| 21 | testConstraint testevalex [llength [info commands testevalex]] |
---|
| 22 | |
---|
| 23 | # The following tests are very incomplete, although the rest of the |
---|
| 24 | # test suite covers this file fairly well. |
---|
| 25 | |
---|
| 26 | catch {rename p ""} |
---|
| 27 | catch {namespace delete test_ns_compile} |
---|
| 28 | catch {unset x} |
---|
| 29 | catch {unset y} |
---|
| 30 | catch {unset a} |
---|
| 31 | |
---|
| 32 | test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} { |
---|
| 33 | catch {namespace delete test_ns_compile} |
---|
| 34 | catch {unset x} |
---|
| 35 | set x 123 |
---|
| 36 | namespace eval test_ns_compile { |
---|
| 37 | proc set {args} { |
---|
| 38 | global x |
---|
| 39 | lappend x test_ns_compile::set |
---|
| 40 | } |
---|
| 41 | proc p {} { |
---|
| 42 | set 0 |
---|
| 43 | } |
---|
| 44 | } |
---|
| 45 | list [test_ns_compile::p] [set x] |
---|
| 46 | } {{123 test_ns_compile::set} {123 test_ns_compile::set}} |
---|
| 47 | test compile-1.2 {TclCompileString, error result is reset if TclGetLong determines word isn't an integer} { |
---|
| 48 | proc p {x} {info commands 3m} |
---|
| 49 | list [catch {p} msg] $msg |
---|
| 50 | } {1 {wrong # args: should be "p x"}} |
---|
| 51 | test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} { |
---|
| 52 | catch {unset x} |
---|
| 53 | set x 123 |
---|
| 54 | list $::x [expr {[lsearch -exact [info globals] x] != 0}] |
---|
| 55 | } {123 1} |
---|
| 56 | test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} { |
---|
| 57 | catch {unset y} |
---|
| 58 | proc p {} { |
---|
| 59 | set ::y 789 |
---|
| 60 | return $::y |
---|
| 61 | } |
---|
| 62 | list [p] $::y [expr {[lsearch -exact [info globals] y] != 0}] |
---|
| 63 | } {789 789 1} |
---|
| 64 | test compile-2.3 {TclCompileDollarVar: global array name with ::s} { |
---|
| 65 | catch {unset a} |
---|
| 66 | set ::a(1) 2 |
---|
| 67 | list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {[lsearch -exact [info globals] a] != 0}] |
---|
| 68 | } {2 3 3 1} |
---|
| 69 | test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} { |
---|
| 70 | catch {unset a} |
---|
| 71 | proc p {} { |
---|
| 72 | set ::a(1) 1 |
---|
| 73 | return $::a($::a(1)) |
---|
| 74 | } |
---|
| 75 | list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] |
---|
| 76 | } {1 1 1} |
---|
| 77 | test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} { |
---|
| 78 | catch {unset a} |
---|
| 79 | proc p {} { |
---|
| 80 | global a |
---|
| 81 | set a(1) 1 |
---|
| 82 | return ${a(1)}$::a(1)$a(1) |
---|
| 83 | } |
---|
| 84 | list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] |
---|
| 85 | } {111 1 1} |
---|
| 86 | |
---|
| 87 | test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} { |
---|
| 88 | catch {unset a} |
---|
| 89 | set a(1) xyzzyx |
---|
| 90 | proc p {} { |
---|
| 91 | global a |
---|
| 92 | catch {set x 123} a(1) |
---|
| 93 | } |
---|
| 94 | list [p] $a(1) |
---|
| 95 | } {0 123} |
---|
| 96 | test compile-3.2 {TclCompileCatchCmd: non-local variables} { |
---|
| 97 | set ::foo 1 |
---|
| 98 | proc catch-test {} { |
---|
| 99 | catch {set x 3} ::foo |
---|
| 100 | } |
---|
| 101 | catch-test |
---|
| 102 | set ::foo |
---|
| 103 | } 3 |
---|
| 104 | test compile-3.3 {TclCompileCatchCmd: overagressive compiling [bug 219184]} { |
---|
| 105 | proc catch-test {str} { |
---|
| 106 | catch [eval $str GOOD] |
---|
| 107 | error BAD |
---|
| 108 | } |
---|
| 109 | catch {catch-test error} ::foo |
---|
| 110 | set ::foo |
---|
| 111 | } {GOOD} |
---|
| 112 | test compile-3.4 {TclCompileCatchCmd: bcc'ed [return] is caught} { |
---|
| 113 | proc foo {} { |
---|
| 114 | set fail [catch { |
---|
| 115 | return 1 |
---|
| 116 | }] ; # {} |
---|
| 117 | return 2 |
---|
| 118 | } |
---|
| 119 | foo |
---|
| 120 | } {2} |
---|
| 121 | test compile-3.5 {TclCompileCatchCmd: recover from error, [Bug 705406]} { |
---|
| 122 | proc foo {} { |
---|
| 123 | catch { |
---|
| 124 | if {[a]} { |
---|
| 125 | if b {} |
---|
| 126 | } |
---|
| 127 | } |
---|
| 128 | } |
---|
| 129 | list [catch foo msg] $msg |
---|
| 130 | } {0 1} |
---|
| 131 | |
---|
| 132 | test compile-4.1 {TclCompileForCmd: command substituted test expression} { |
---|
| 133 | set i 0 |
---|
| 134 | set j 0 |
---|
| 135 | # Should be "forever" |
---|
| 136 | for {} [expr $i < 3] {} { |
---|
| 137 | set j [incr i] |
---|
| 138 | if {$j > 3} break |
---|
| 139 | } |
---|
| 140 | set j |
---|
| 141 | } {4} |
---|
| 142 | |
---|
| 143 | test compile-5.1 {TclCompileForeachCmd: exception stack} { |
---|
| 144 | proc foreach-exception-test {} { |
---|
| 145 | foreach array(index) [list 1 2 3] break |
---|
| 146 | foreach array(index) [list 1 2 3] break |
---|
| 147 | foreach scalar [list 1 2 3] break |
---|
| 148 | } |
---|
| 149 | list [catch foreach-exception-test result] $result |
---|
| 150 | } {0 {}} |
---|
| 151 | test compile-5.2 {TclCompileForeachCmd: non-local variables} { |
---|
| 152 | set ::foo 1 |
---|
| 153 | proc foreach-test {} { |
---|
| 154 | foreach ::foo {1 2 3} {} |
---|
| 155 | } |
---|
| 156 | foreach-test |
---|
| 157 | set ::foo |
---|
| 158 | } 3 |
---|
| 159 | |
---|
| 160 | test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} { |
---|
| 161 | catch {unset x} |
---|
| 162 | catch {unset y} |
---|
| 163 | set x 123 |
---|
| 164 | proc p {} { |
---|
| 165 | set ::y 789 |
---|
| 166 | return $::y |
---|
| 167 | } |
---|
| 168 | list $::x [expr {[lsearch -exact [info globals] x] != 0}] \ |
---|
| 169 | [p] $::y [expr {[lsearch -exact [info globals] y] != 0}] |
---|
| 170 | } {123 1 789 789 1} |
---|
| 171 | test compile-6.2 {TclCompileSetCmd: global array names with ::s} { |
---|
| 172 | catch {unset a} |
---|
| 173 | set ::a(1) 2 |
---|
| 174 | proc p {} { |
---|
| 175 | set ::a(1) 1 |
---|
| 176 | return $::a($::a(1)) |
---|
| 177 | } |
---|
| 178 | list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] |
---|
| 179 | } {2 1 3 3 1} |
---|
| 180 | test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} { |
---|
| 181 | catch {namespace delete test_ns_compile} |
---|
| 182 | catch {unset x} |
---|
| 183 | namespace eval test_ns_compile { |
---|
| 184 | variable v hello |
---|
| 185 | variable arr |
---|
| 186 | set ::x $::test_ns_compile::v |
---|
| 187 | set ::test_ns_compile::arr(1) 123 |
---|
| 188 | } |
---|
| 189 | list $::x $::test_ns_compile::arr(1) |
---|
| 190 | } {hello 123} |
---|
| 191 | |
---|
| 192 | test compile-7.1 {TclCompileWhileCmd: command substituted test expression} { |
---|
| 193 | set i 0 |
---|
| 194 | set j 0 |
---|
| 195 | # Should be "forever" |
---|
| 196 | while [expr $i < 3] { |
---|
| 197 | set j [incr i] |
---|
| 198 | if {$j > 3} break |
---|
| 199 | } |
---|
| 200 | set j |
---|
| 201 | } {4} |
---|
| 202 | |
---|
| 203 | test compile-8.1 {CollectArgInfo: binary data} { |
---|
| 204 | list [catch "string length \000foo" msg] $msg |
---|
| 205 | } {0 4} |
---|
| 206 | test compile-8.2 {CollectArgInfo: binary data} { |
---|
| 207 | list [catch "string length foo\000" msg] $msg |
---|
| 208 | } {0 4} |
---|
| 209 | test compile-8.3 {CollectArgInfo: handle "]" at end of command properly} { |
---|
| 210 | set x ] |
---|
| 211 | } {]} |
---|
| 212 | |
---|
| 213 | test compile-9.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} { |
---|
| 214 | proc p {} { |
---|
| 215 | set x {} |
---|
| 216 | eval $x |
---|
| 217 | append x { } |
---|
| 218 | eval $x |
---|
| 219 | } |
---|
| 220 | p |
---|
| 221 | } {} |
---|
| 222 | |
---|
| 223 | test compile-10.1 {BLACKBOX: exception stack overflow} { |
---|
| 224 | set x {{0}} |
---|
| 225 | set y 0 |
---|
| 226 | while {$y < 100} { |
---|
| 227 | if !$x {incr y} |
---|
| 228 | } |
---|
| 229 | } {} |
---|
| 230 | |
---|
| 231 | test compile-11.1 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { |
---|
| 232 | proc p {} { |
---|
| 233 | # shared object - Interp result && Var 'r' |
---|
| 234 | set r [list foobar] |
---|
| 235 | # command that will add error to result |
---|
| 236 | lindex a bogus |
---|
| 237 | } |
---|
| 238 | list [catch {p} msg] $msg |
---|
| 239 | } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} |
---|
| 240 | test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { |
---|
| 241 | proc p {} { set r [list foobar] ; string index a bogus } |
---|
| 242 | list [catch {p} msg] $msg |
---|
| 243 | } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} |
---|
| 244 | test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { |
---|
| 245 | proc p {} { set r [list foobar] ; string index a 0o9 } |
---|
| 246 | list [catch {p} msg] $msg |
---|
| 247 | } -match glob -result {1 {*invalid octal number*}} |
---|
| 248 | test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { |
---|
| 249 | proc p {} { set r [list foobar] ; array set var {one two many} } |
---|
| 250 | list [catch {p} msg] $msg |
---|
| 251 | } {1 {list must have an even number of elements}} |
---|
| 252 | test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { |
---|
| 253 | proc p {} { set r [list foobar] ; incr foo bar baz} |
---|
| 254 | list [catch {p} msg] $msg |
---|
| 255 | } {1 {wrong # args: should be "incr varName ?increment?"}} |
---|
| 256 | test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { |
---|
| 257 | proc p {} { set r [list foobar] ; incr} |
---|
| 258 | list [catch {p} msg] $msg |
---|
| 259 | } {1 {wrong # args: should be "incr varName ?increment?"}} |
---|
| 260 | test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { |
---|
| 261 | proc p {} { set r [list foobar] ; expr !a } |
---|
| 262 | p |
---|
| 263 | } -returnCodes error -match glob -result * |
---|
| 264 | test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { |
---|
| 265 | proc p {} { set r [list foobar] ; expr {!a} } |
---|
| 266 | p |
---|
| 267 | } -returnCodes error -match glob -result * |
---|
| 268 | test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { |
---|
| 269 | proc p {} { set r [list foobar] ; llength "\{" } |
---|
| 270 | list [catch {p} msg] $msg |
---|
| 271 | } {1 {unmatched open brace in list}} |
---|
| 272 | |
---|
| 273 | # |
---|
| 274 | # Special section for tests of tclLiteral.c |
---|
| 275 | # The following tests check for incorrect memory handling in |
---|
| 276 | # TclReleaseLiteral. They are only effective when tcl is compiled |
---|
| 277 | # with TCL_MEM_DEBUG |
---|
| 278 | # |
---|
| 279 | # Special test for leak on interp delete [Bug 467523]. |
---|
| 280 | test compile-12.1 {testing literal leak on interp delete} -setup { |
---|
| 281 | proc getbytes {} { |
---|
| 282 | set lines [split [memory info] "\n"] |
---|
| 283 | lindex $lines 3 3 |
---|
| 284 | } |
---|
| 285 | } -constraints memory -body { |
---|
| 286 | set end [getbytes] |
---|
| 287 | for {set i 0} {$i < 5} {incr i} { |
---|
| 288 | interp create foo |
---|
| 289 | foo eval { |
---|
| 290 | namespace eval bar {} |
---|
| 291 | } |
---|
| 292 | interp delete foo |
---|
| 293 | set tmp $end |
---|
| 294 | set end [getbytes] |
---|
| 295 | } |
---|
| 296 | set leakedBytes [expr {$end - $tmp}] |
---|
| 297 | } -cleanup { |
---|
| 298 | rename getbytes {} |
---|
| 299 | } -result 0 |
---|
| 300 | # Special test for a memory error in a preliminary fix of [Bug 467523]. |
---|
| 301 | # It requires executing a helpfile. Presumably the child process is |
---|
| 302 | # used because when this test fails, it crashes. |
---|
| 303 | test compile-12.2 {testing error on literal deletion} -constraints {memory exec} -body { |
---|
| 304 | set sourceFile [makeFile { |
---|
| 305 | for {set i 0} {$i < 5} {incr i} { |
---|
| 306 | namespace eval bar {} |
---|
| 307 | namespace delete bar |
---|
| 308 | } |
---|
| 309 | puts 0 |
---|
| 310 | } source.file] |
---|
| 311 | exec [interpreter] $sourceFile |
---|
| 312 | } -cleanup { |
---|
| 313 | catch {removeFile $sourceFile} |
---|
| 314 | } -result 0 |
---|
| 315 | # Test to catch buffer overrun in TclCompileTokens from buf 530320 |
---|
| 316 | test compile-12.3 {check for a buffer overrun} -body { |
---|
| 317 | proc crash {} { |
---|
| 318 | puts $array([expr {a+2}]) |
---|
| 319 | } |
---|
| 320 | crash |
---|
| 321 | } -returnCodes error -cleanup { |
---|
| 322 | rename crash {} |
---|
| 323 | } -match glob -result * |
---|
| 324 | test compile-12.4 {TclCleanupLiteralTable segfault} -body { |
---|
| 325 | # Tcl Bug 1001997 |
---|
| 326 | # Here, we're trying to test a case that causes a crash in |
---|
| 327 | # TclCleanupLiteralTable. The conditions that we're trying to |
---|
| 328 | # establish are: |
---|
| 329 | # - TclCleanupLiteralTable is attempting to clean up a bytecode |
---|
| 330 | # object in the literal table. |
---|
| 331 | # - The bytecode object in question contains the only reference |
---|
| 332 | # to another literal. |
---|
| 333 | # - The literal in question is in the same hash bucket as the bytecode |
---|
| 334 | # object, and immediately follows it in the chain. |
---|
| 335 | # Since newly registered literals are added at the FRONT of the |
---|
| 336 | # bucket chains, and since the bytecode object is registered before |
---|
| 337 | # its literals, this is difficult to achieve. What we do is: |
---|
| 338 | # (a) do a [namespace eval] of a string that's calculated to |
---|
| 339 | # hash into the same bucket as a literal that it contains. |
---|
| 340 | # In this case, the script and the variable 'bugbug' |
---|
| 341 | # land in the same bucket. |
---|
| 342 | # (b) do a [namespace eval] of a string that contains enough |
---|
| 343 | # literals to force TclRegisterLiteral to rebuild the global |
---|
| 344 | # literal table. The newly created hash buckets will contain |
---|
| 345 | # the literals, IN REVERSE ORDER, thus putting the bytecode |
---|
| 346 | # immediately ahead of 'bugbug' and 'bug4345bug'. The bytecode |
---|
| 347 | # object will contain the only references to those two literals. |
---|
| 348 | # (c) Delete the interpreter to invoke TclCleanupLiteralTable |
---|
| 349 | # and tickle the bug. |
---|
| 350 | proc foo {} { |
---|
| 351 | set i [interp create] |
---|
| 352 | $i eval { |
---|
| 353 | namespace eval ::w {concat 4649; variable bugbug} |
---|
| 354 | namespace eval ::w { |
---|
| 355 | concat x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 \ |
---|
| 356 | x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 \ |
---|
| 357 | x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 \ |
---|
| 358 | x31 x32 X33 X34 X35 X36 X37 X38 X39 X40 \ |
---|
| 359 | x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 \ |
---|
| 360 | x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 \ |
---|
| 361 | x61 x62 x63 x64 |
---|
| 362 | concat y1 y2 y3 y4 y5 y6 y7 y8 y9 y10 \ |
---|
| 363 | y11 y12 y13 y14 y15 y16 y17 y18 y19 y20 \ |
---|
| 364 | y21 y22 y23 y24 y25 y26 y27 y28 y29 y30 \ |
---|
| 365 | y31 y32 Y33 Y34 Y35 Y36 Y37 Y38 Y39 Y40 \ |
---|
| 366 | y41 y42 y43 y44 y45 y46 y47 y48 y49 y50 \ |
---|
| 367 | y51 y52 y53 y54 y55 y56 y57 y58 y59 y60 \ |
---|
| 368 | y61 y62 y63 y64 |
---|
| 369 | concat z1 z2 z3 z4 z5 z6 z7 z8 z9 z10 \ |
---|
| 370 | z11 z12 z13 z14 z15 z16 z17 z18 z19 z20 \ |
---|
| 371 | z21 z22 z23 z24 z25 z26 z27 z28 z29 z30 \ |
---|
| 372 | z31 z32 |
---|
| 373 | } |
---|
| 374 | } |
---|
| 375 | interp delete $i; # must not crash |
---|
| 376 | return ok |
---|
| 377 | } |
---|
| 378 | foo |
---|
| 379 | } -cleanup { |
---|
| 380 | rename foo {} |
---|
| 381 | } -result ok |
---|
| 382 | |
---|
| 383 | # Special test for underestimating the maxStackSize required for a |
---|
| 384 | # compiled command. A failure will cause a segfault in the child |
---|
| 385 | # process. |
---|
| 386 | test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} { |
---|
| 387 | set body {set x [list} |
---|
| 388 | for {set i 0} {$i < 3000} {incr i} { |
---|
| 389 | append body " $i" |
---|
| 390 | } |
---|
| 391 | append body {]; puts OK} |
---|
| 392 | regsub BODY {proc crash {} {BODY}; crash} $body script |
---|
| 393 | list [catch {exec [interpreter] << $script} msg] $msg |
---|
| 394 | } {0 OK} |
---|
| 395 | |
---|
| 396 | # Special test for compiling tokens from a copy of the source |
---|
| 397 | # string [Bug #599788] |
---|
| 398 | test compile-14.1 {testing errors in element name; segfault?} {} { |
---|
| 399 | catch {set a([error])} msg1 |
---|
| 400 | catch {set bubba([join $abba $jubba]) $vol} msg2 |
---|
| 401 | list $msg1 $msg2 |
---|
| 402 | } {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}} |
---|
| 403 | |
---|
| 404 | # Tests compile-15.* cover Tcl Bug 633204 |
---|
| 405 | test compile-15.1 {proper TCL_RETURN code from [return]} { |
---|
| 406 | proc p {} {catch return} |
---|
| 407 | set result [p] |
---|
| 408 | rename p {} |
---|
| 409 | set result |
---|
| 410 | } 2 |
---|
| 411 | test compile-15.2 {proper TCL_RETURN code from [return]} { |
---|
| 412 | proc p {} {catch {return foo}} |
---|
| 413 | set result [p] |
---|
| 414 | rename p {} |
---|
| 415 | set result |
---|
| 416 | } 2 |
---|
| 417 | test compile-15.3 {proper TCL_RETURN code from [return]} { |
---|
| 418 | proc p {} {catch {return $::tcl_library}} |
---|
| 419 | set result [p] |
---|
| 420 | rename p {} |
---|
| 421 | set result |
---|
| 422 | } 2 |
---|
| 423 | test compile-15.4 {proper TCL_RETURN code from [return]} { |
---|
| 424 | proc p {} {catch {return [info library]}} |
---|
| 425 | set result [p] |
---|
| 426 | rename p {} |
---|
| 427 | set result |
---|
| 428 | } 2 |
---|
| 429 | test compile-15.5 {proper TCL_RETURN code from [return]} { |
---|
| 430 | proc p {} {catch {set a 1}; return} |
---|
| 431 | set result [p] |
---|
| 432 | rename p {} |
---|
| 433 | set result |
---|
| 434 | } "" |
---|
| 435 | |
---|
| 436 | for {set noComp 0} {$noComp <= 1} {incr noComp} { |
---|
| 437 | |
---|
| 438 | if $noComp { |
---|
| 439 | interp alias {} run {} testevalex |
---|
| 440 | set constraints testevalex |
---|
| 441 | } else { |
---|
| 442 | interp alias {} run {} if 1 |
---|
| 443 | set constraints {} |
---|
| 444 | } |
---|
| 445 | |
---|
| 446 | test compile-16.1.$noComp {TclCompileScript: word expansion} $constraints { |
---|
| 447 | run "list [string repeat {{*}a } 255]" |
---|
| 448 | } [lrepeat 255 a] |
---|
| 449 | test compile-16.2.$noComp {TclCompileScript: word expansion} $constraints { |
---|
| 450 | run "list [string repeat {{*}a } 256]" |
---|
| 451 | } [lrepeat 256 a] |
---|
| 452 | test compile-16.3.$noComp {TclCompileScript: word expansion} $constraints { |
---|
| 453 | run "list [string repeat {{*}a } 257]" |
---|
| 454 | } [lrepeat 257 a] |
---|
| 455 | test compile-16.4.$noComp {TclCompileScript: word expansion} $constraints { |
---|
| 456 | run {{*}list} |
---|
| 457 | } {} |
---|
| 458 | test compile-16.5.$noComp {TclCompileScript: word expansion} $constraints { |
---|
| 459 | run {{*}list {*}{x y z}} |
---|
| 460 | } {x y z} |
---|
| 461 | test compile-16.6.$noComp {TclCompileScript: word expansion} $constraints { |
---|
| 462 | run {{*}list {*}[list x y z]} |
---|
| 463 | } {x y z} |
---|
| 464 | test compile-16.7.$noComp {TclCompileScript: word expansion} $constraints { |
---|
| 465 | run {{*}list {*}[list x y z][list x y z]} |
---|
| 466 | } {x y zx y z} |
---|
| 467 | test compile-16.8.$noComp {TclCompileScript: word expansion} -body { |
---|
| 468 | set l {x y z} |
---|
| 469 | run {{*}list {*}$l} |
---|
| 470 | } -constraints $constraints -cleanup { |
---|
| 471 | unset l |
---|
| 472 | } -result {x y z} |
---|
| 473 | test compile-16.9.$noComp {TclCompileScript: word expansion} -body { |
---|
| 474 | set l {x y z} |
---|
| 475 | run {{*}list {*}$l$l} |
---|
| 476 | } -constraints $constraints -cleanup { |
---|
| 477 | unset l |
---|
| 478 | } -result {x y zx y z} |
---|
| 479 | test compile-16.10.$noComp {TclCompileScript: word expansion} -body { |
---|
| 480 | run {{*}\{} |
---|
| 481 | } -constraints $constraints -returnCodes error \ |
---|
| 482 | -result {unmatched open brace in list} |
---|
| 483 | test compile-16.11.$noComp {TclCompileScript: word expansion} -body { |
---|
| 484 | proc badList {} {return \{} |
---|
| 485 | run {{*}[badList]} |
---|
| 486 | } -constraints $constraints -cleanup { |
---|
| 487 | rename badList {} |
---|
| 488 | } -returnCodes error -result {unmatched open brace in list} |
---|
| 489 | test compile-16.12.$noComp {TclCompileScript: word expansion} $constraints { |
---|
| 490 | run {{*}list x y z} |
---|
| 491 | } {x y z} |
---|
| 492 | test compile-16.13.$noComp {TclCompileScript: word expansion} $constraints { |
---|
| 493 | run {{*}list x y {*}z} |
---|
| 494 | } {x y z} |
---|
| 495 | test compile-16.14.$noComp {TclCompileScript: word expansion} $constraints { |
---|
| 496 | run {{*}list x {*}y z} |
---|
| 497 | } {x y z} |
---|
| 498 | test compile-16.15.$noComp {TclCompileScript: word expansion} $constraints { |
---|
| 499 | run {list x y {*}z} |
---|
| 500 | } {x y z} |
---|
| 501 | test compile-16.16.$noComp {TclCompileScript: word expansion} $constraints { |
---|
| 502 | run {list x {*}y z} |
---|
| 503 | } {x y z} |
---|
| 504 | test compile-16.17.$noComp {TclCompileScript: word expansion} $constraints { |
---|
| 505 | run {list {*}x y z} |
---|
| 506 | } {x y z} |
---|
| 507 | |
---|
| 508 | # These tests note that expansion can in theory cause the number of |
---|
| 509 | # arguments to a command to exceed INT_MAX, which is as big as objc |
---|
| 510 | # is allowed to get. |
---|
| 511 | # |
---|
| 512 | # In practice, it seems we will run out of memory before we confront |
---|
| 513 | # this issue. Note that compiled operations run out of memory at |
---|
| 514 | # smaller objc values than direct string evaluation. |
---|
| 515 | # |
---|
| 516 | # These tests are constrained as knownBug because they are likely |
---|
| 517 | # to cause memory allocation panics somewhere, and we don't want |
---|
| 518 | # panics in the test suite. |
---|
| 519 | # |
---|
| 520 | test compile-16.18.$noComp {TclCompileScript: word expansion} -body { |
---|
| 521 | proc LongList {} {return [lrepeat [expr {1<<10}] x]} |
---|
| 522 | llength [run "list [string repeat {{*}[LongList] } [expr {1<<10}]]"] |
---|
| 523 | } -constraints [linsert $constraints 0 knownBug] -cleanup { |
---|
| 524 | rename LongList {} |
---|
| 525 | } -returnCodes ok -result [expr {1<<20}] |
---|
| 526 | test compile-16.19.$noComp {TclCompileScript: word expansion} -body { |
---|
| 527 | proc LongList {} {return [lrepeat [expr {1<<11}] x]} |
---|
| 528 | llength [run "list [string repeat {{*}[LongList] } [expr {1<<11}]]"] |
---|
| 529 | } -constraints [linsert $constraints 0 knownBug] -cleanup { |
---|
| 530 | rename LongList {} |
---|
| 531 | } -returnCodes ok -result [expr {1<<22}] |
---|
| 532 | test compile-16.20.$noComp {TclCompileScript: word expansion} -body { |
---|
| 533 | proc LongList {} {return [lrepeat [expr {1<<12}] x]} |
---|
| 534 | llength [run "list [string repeat {{*}[LongList] } [expr {1<<12}]]"] |
---|
| 535 | } -constraints [linsert $constraints 0 knownBug] -cleanup { |
---|
| 536 | rename LongList {} |
---|
| 537 | } -returnCodes ok -result [expr {1<<24}] |
---|
| 538 | # This is the one that should cause overflow |
---|
| 539 | test compile-16.21.$noComp {TclCompileScript: word expansion} -body { |
---|
| 540 | proc LongList {} {return [lrepeat [expr {1<<16}] x]} |
---|
| 541 | llength [run "list [string repeat {{*}[LongList] } [expr {1<<16}]]"] |
---|
| 542 | } -constraints [linsert $constraints 0 knownBug] -cleanup { |
---|
| 543 | rename LongList {} |
---|
| 544 | } -returnCodes ok -result [expr {wide(1)<<32}] |
---|
| 545 | test compile-16.22.$noComp { |
---|
| 546 | Bug 845412: TclCompileScript: word expansion not mandatory |
---|
| 547 | } -body { |
---|
| 548 | # This test may crash and will fail unless Bug 845412 is fixed. |
---|
| 549 | proc ReturnResults args {return $args} |
---|
| 550 | run "ReturnResults [string repeat {x } 260]" |
---|
| 551 | } -constraints $constraints -cleanup { |
---|
| 552 | rename ReturnResults {} |
---|
| 553 | } -returnCodes ok -result [string trim [string repeat {x } 260]] |
---|
| 554 | test compile-16.23.$noComp { |
---|
| 555 | Bug 1032805: defer parse error until run time |
---|
| 556 | } -constraints $constraints -body { |
---|
| 557 | namespace eval x { |
---|
| 558 | run { |
---|
| 559 | proc if {a b} {uplevel 1 [list set $a $b]} |
---|
| 560 | if 1 {syntax {}{}} |
---|
| 561 | } |
---|
| 562 | } |
---|
| 563 | } -cleanup { |
---|
| 564 | namespace delete x |
---|
| 565 | } -returnCodes ok -result {syntax {}{}} |
---|
| 566 | test compile-16.24.$noComp { |
---|
| 567 | Bug 1638414: bad list constant as first expanded term |
---|
| 568 | } -constraints $constraints -body { |
---|
| 569 | run "{*}\"\{foo bar\"" |
---|
| 570 | } -returnCodes error -result {unmatched open brace in list} |
---|
| 571 | } ;# End of noComp loop |
---|
| 572 | |
---|
| 573 | # These tests are messy because it wrecks the interpreter it runs in! |
---|
| 574 | # They demonstrate issues arising from [FRQ 1101710] |
---|
| 575 | test compile-17.1 {Command interpretation binding for compiled code} -constraints knownBug -setup { |
---|
| 576 | set i [interp create] |
---|
| 577 | } -body { |
---|
| 578 | $i eval { |
---|
| 579 | if 1 { |
---|
| 580 | expr [ |
---|
| 581 | proc expr args {return substituted} |
---|
| 582 | format {[subst compiled]} |
---|
| 583 | ] |
---|
| 584 | } |
---|
| 585 | } |
---|
| 586 | } -cleanup { |
---|
| 587 | interp delete $i |
---|
| 588 | } -result substituted |
---|
| 589 | test compile-17.2 {Command interpretation binding for non-compiled code} -setup { |
---|
| 590 | set i [interp create] |
---|
| 591 | } -body { |
---|
| 592 | $i eval { |
---|
| 593 | if 1 { |
---|
| 594 | [subst expr] [ |
---|
| 595 | proc expr args {return substituted} |
---|
| 596 | format {[subst compiled]} |
---|
| 597 | ] |
---|
| 598 | } |
---|
| 599 | } |
---|
| 600 | } -cleanup { |
---|
| 601 | interp delete $i |
---|
| 602 | } -result substituted |
---|
| 603 | |
---|
| 604 | # cleanup |
---|
| 605 | catch {rename p ""} |
---|
| 606 | catch {namespace delete test_ns_compile} |
---|
| 607 | catch {unset x} |
---|
| 608 | catch {unset y} |
---|
| 609 | catch {unset a} |
---|
| 610 | ::tcltest::cleanupTests |
---|
| 611 | return |
---|