1# assemble.test -- 2# 3# Test suite for the 'tcl::unsupported::assemble' command 4# 5# Copyright (c) 2010 by Ozgur Dogan Ugurlu. 6# Copyright (c) 2010 by Kevin B. Kenny. 7# 8# See the file "license.terms" for information on usage and redistribution of 9# this file, and for a DISCLAIMER OF ALL WARRANTIES. 10#----------------------------------------------------------------------------- 11 12# Commands covered: assemble 13 14if {"::tcltest" ni [namespace children]} { 15 package require tcltest 2.5 16 namespace import -force ::tcltest::* 17} 18namespace eval tcl::unsupported {namespace export assemble} 19namespace import tcl::unsupported::assemble 20 21# Procedure to make code that fills the literal and local variable tables, to 22# force instructions to spill to four bytes. 23 24proc fillTables {} { 25 set s {} 26 set sep {} 27 for {set i 0} {$i < 256} {incr i} { 28 append s $sep [list set v$i literal$i] 29 set sep \n 30 } 31 return $s 32} 33 34testConstraint memory [llength [info commands memory]] 35if {[testConstraint memory]} { 36 proc getbytes {} { 37 set lines [split [memory info] \n] 38 return [lindex $lines 3 3] 39 } 40 proc leaktest {script {iterations 3}} { 41 set end [getbytes] 42 for {set i 0} {$i < $iterations} {incr i} { 43 uplevel 1 $script 44 set tmp $end 45 set end [getbytes] 46 } 47 return [expr {$end - $tmp}] 48 } 49} 50 51# assemble-1 - TclNRAssembleObjCmd 52 53test assemble-1.1 {wrong # args, direct eval} { 54 -body { 55 eval [list assemble] 56 } 57 -returnCodes error 58 -result {wrong # args*} 59 -match glob 60} 61test assemble-1.2 {wrong # args, direct eval} { 62 -body { 63 eval [list assemble too many] 64 } 65 -returnCodes error 66 -result {wrong # args*} 67 -match glob 68} 69test assemble-1.3 {error reporting, direct eval} { 70 -body { 71 list [catch { 72 eval [list assemble { 73 # bad opcode 74 rubbish 75 }] 76 } result] $result $errorInfo 77 } 78 -match glob 79 -result {1 {bad instruction "rubbish":*} {bad instruction "rubbish":* 80 while executing 81"rubbish" 82 ("assemble" body, line 3)*}} 83 -cleanup {unset result} 84} 85test assemble-1.4 {simple direct eval} { 86 -body { 87 eval [list assemble {push {this is a test}}] 88 } 89 -result {this is a test} 90} 91 92# assemble-2 - CompileAssembleObj 93 94test assemble-2.1 {bytecode reuse, direct eval} { 95 -body { 96 set x {push "this is a test"} 97 list [eval [list assemble $x]] \ 98 [eval [list assemble $x]] 99 } 100 -result {{this is a test} {this is a test}} 101} 102test assemble-2.2 {bytecode discard, direct eval} { 103 -body { 104 set x {load value} 105 proc p1 {x} { 106 set value value1 107 assemble $x 108 } 109 proc p2 {x} { 110 set a b 111 set value value2 112 assemble $x 113 } 114 list [p1 $x] [p2 $x] 115 } 116 -result {value1 value2} 117 -cleanup { 118 unset x 119 rename p1 {} 120 rename p2 {} 121 } 122} 123test assemble-2.3 {null script, direct eval} { 124 -body { 125 set x {} 126 assemble $x 127 } 128 -result {} 129 -cleanup {unset x} 130} 131 132# assemble-3 - TclCompileAssembleCmd 133 134test assemble-3.1 {wrong # args, compiled path} { 135 -body { 136 proc x {} { 137 assemble 138 } 139 x 140 } 141 -returnCodes error 142 -match glob 143 -result {wrong # args:*} 144} 145test assemble-3.2 {wrong # args, compiled path} { 146 -body { 147 proc x {} { 148 assemble too many 149 } 150 x 151 } 152 -returnCodes error 153 -match glob 154 -result {wrong # args:*} 155 -cleanup { 156 rename x {} 157 } 158} 159 160# assemble-4 - TclAssembleCode mainline 161 162test assemble-4.1 {syntax error} { 163 -body { 164 proc x {} { 165 assemble { 166 {}extra 167 } 168 } 169 list [catch x result] $result $::errorInfo 170 } 171 -cleanup { 172 rename x {} 173 unset result 174 } 175 -match glob 176 -result {1 {extra characters after close-brace} {extra characters after close-brace 177 while executing 178"{}e" 179 ("assemble" body, line 2)*}} 180} 181test assemble-4.2 {null command} { 182 -body { 183 proc x {} { 184 assemble { 185 push hello; pop;;push goodbye 186 } 187 } 188 x 189 } 190 -result goodbye 191 -cleanup { 192 rename x {} 193 } 194} 195 196# assemble-5 - GetNextOperand off-nominal cases 197 198test assemble-5.1 {unsupported expansion} { 199 -body { 200 proc x {y} { 201 assemble { 202 {*}$y 203 } 204 } 205 list [catch {x {push hello}} result] $result $::errorCode 206 } 207 -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} 208 -cleanup { 209 rename x {} 210 unset result 211 } 212} 213test assemble-5.2 {unsupported substitution} { 214 -body { 215 proc x {y} { 216 assemble { 217 $y 218 } 219 } 220 list [catch {x {nop}} result] $result $::errorCode 221 } 222 -cleanup { 223 rename x {} 224 unset result 225 } 226 -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} 227} 228test assemble-5.3 {unsupported substitution} { 229 -body { 230 proc x {} { 231 assemble { 232 [x] 233 } 234 } 235 list [catch {x} result] $result $::errorCode 236 } 237 -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} 238} 239test assemble-5.4 {backslash substitution} { 240 -body { 241 proc x {} { 242 assemble { 243 p\x75sh\ 244 hello\ world 245 } 246 } 247 x 248 } 249 -cleanup { 250 rename x {} 251 } 252 -result {hello world} 253} 254 255# assemble-6 - ASSEM_PUSH 256 257test assemble-6.1 {push, wrong # args} { 258 -body { 259 assemble push 260 } 261 -returnCodes error 262 -match glob 263 -result {wrong # args*} 264} 265test assemble-6.2 {push, wrong # args} { 266 -body { 267 assemble {push too many} 268 } 269 -returnCodes error 270 -match glob 271 -result {wrong # args*} 272} 273test assemble-6.3 {push} { 274 -body { 275 eval [list assemble {push hello}] 276 } 277 -result hello 278} 279test assemble-6.4 {push4} { 280 -body { 281 proc x {} " 282 [fillTables] 283 assemble {push hello} 284 " 285 x 286 } 287 -cleanup { 288 rename x {} 289 } 290 -result hello 291} 292 293# assemble-7 - ASSEM_1BYTE 294 295test assemble-7.1 {add, wrong # args} { 296 -body { 297 assemble {add excess} 298 } 299 -returnCodes error 300 -match glob 301 -result {wrong # args*} 302} 303test assemble-7.2 {add} { 304 -body { 305 assemble { 306 push 2 307 push 2 308 add 309 } 310 } 311 -result {4} 312} 313test assemble-7.3 {appendArrayStk} { 314 -body { 315 set a(b) {hello, } 316 assemble { 317 push a 318 push b 319 push world 320 appendArrayStk 321 } 322 set a(b) 323 } 324 -result {hello, world} 325 -cleanup {unset a} 326} 327test assemble-7.4 {appendStk} { 328 -body { 329 set a {hello, } 330 assemble { 331 push a 332 push world 333 appendStk 334 } 335 set a 336 } 337 -result {hello, world} 338 -cleanup {unset a} 339} 340test assemble-7.5 {bitwise ops} { 341 -body { 342 list \ 343 [assemble {push 0b1100; push 0b1010; bitand}] \ 344 [assemble {push 0b1100; bitnot}] \ 345 [assemble {push 0b1100; push 0b1010; bitor}] \ 346 [assemble {push 0b1100; push 0b1010; bitxor}] 347 } 348 -result {8 -13 14 6} 349} 350test assemble-7.6 {div} { 351 -body { 352 assemble {push 999999; push 7; div} 353 } 354 -result 142857 355} 356test assemble-7.7 {dup} { 357 -body { 358 assemble { 359 push 1; dup; dup; add; dup; add; dup; add; add 360 } 361 } 362 -result 9 363} 364test assemble-7.8 {eq} { 365 -body { 366 list \ 367 [assemble {push able; push baker; eq}] \ 368 [assemble {push able; push able; eq}] 369 } 370 -result {0 1} 371} 372test assemble-7.9 {evalStk} { 373 -body { 374 assemble { 375 push {concat test 7.3} 376 evalStk 377 } 378 } 379 -result {test 7.3} 380} 381test assemble-7.9a {evalStk, syntax} { 382 -body { 383 assemble { 384 push {{}bad} 385 evalStk 386 } 387 } 388 -returnCodes error 389 -result {extra characters after close-brace} 390} 391test assemble-7.9b {evalStk, backtrace} { 392 -body { 393 proc y {z} { 394 error testing 395 } 396 proc x {} { 397 assemble { 398 push { 399 # test error in evalStk 400 y asd 401 } 402 evalStk 403 } 404 } 405 list [catch x result] $result $errorInfo 406 } 407 -result {1 testing {testing 408 while executing 409"error testing" 410 (procedure "y" line 2) 411 invoked from within 412"y asd"*}} 413 -match glob 414 -cleanup { 415 rename y {} 416 rename x {} 417 } 418} 419test assemble-7.10 {existArrayStk} { 420 -body { 421 proc x {name key} { 422 set a(b) c 423 assemble { 424 load name; load key; existArrayStk 425 } 426 } 427 list [x a a] [x a b] [x b a] [x b b] 428 } 429 -result {0 1 0 0} 430 -cleanup {rename x {}} 431} 432test assemble-7.11 {existStk} { 433 -body { 434 proc x {name} { 435 set a b 436 assemble { 437 load name; existStk 438 } 439 } 440 list [x a] [x b] 441 } 442 -result {1 0} 443 -cleanup {rename x {}} 444} 445test assemble-7.12 {expon} { 446 -body { 447 assemble {push 3; push 4; expon} 448 } 449 -result 81 450} 451test assemble-7.13 {exprStk} { 452 -body { 453 assemble { 454 push {acos(-1)} 455 exprStk 456 } 457 } 458 -result 3.141592653589793 459} 460test assemble-7.13a {exprStk, syntax} { 461 -body { 462 assemble { 463 push {2+} 464 exprStk 465 } 466 } 467 -returnCodes error 468 -result {missing operand at _@_ 469in expression "2+_@_"} 470} 471test assemble-7.13b {exprStk, backtrace} { 472 -body { 473 proc y {z} { 474 error testing 475 } 476 proc x {} { 477 assemble { 478 push {[y asd]} 479 exprStk 480 } 481 } 482 list [catch x result] $result $errorInfo 483 } 484 -result {1 testing {testing 485 while executing 486"error testing" 487 (procedure "y" line 2) 488 invoked from within 489"y asd"*}} 490 -match glob 491 -cleanup { 492 rename y {} 493 rename x {} 494 } 495} 496test assemble-7.14 {ge gt le lt} { 497 -body { 498 proc x {a b} { 499 list [assemble {load a; load b; ge}] \ 500 [assemble {load a; load b; gt}] \ 501 [assemble {load a; load b; le}] \ 502 [assemble {load a; load b; lt}] 503 } 504 list [x 0 0] [x 0 1] [x 1 0] 505 } 506 -result {{1 0 1 0} {0 0 1 1} {1 1 0 0}} 507 -cleanup {rename x {}} 508} 509test assemble-7.15 {incrArrayStk} { 510 -body { 511 proc x {} { 512 set a(b) 5 513 assemble { 514 push a; push b; push 7; incrArrayStk 515 } 516 } 517 x 518 } 519 -result 12 520 -cleanup {rename x {}} 521} 522test assemble-7.16 {incrStk} { 523 -body { 524 proc x {} { 525 set a 5 526 assemble { 527 push a; push 7; incrStk 528 } 529 } 530 x 531 } 532 -result 12 533 -cleanup {rename x {}} 534} 535test assemble-7.17 {land/lor} { 536 -body { 537 proc x {a b} { 538 list \ 539 [assemble {load a; load b; land}] \ 540 [assemble {load a; load b; lor}] 541 } 542 list [x 0 0] [x 0 23] [x 35 0] [x 47 59] 543 } 544 -result {{0 0} {0 1} {0 1} {1 1}} 545 -cleanup {rename x {}} 546} 547test assemble-7.18 {lappendArrayStk} { 548 -body { 549 proc x {} { 550 set able(baker) charlie 551 assemble { 552 push able 553 push baker 554 push dog 555 lappendArrayStk 556 } 557 } 558 x 559 } 560 -result {charlie dog} 561 -cleanup {rename x {}} 562} 563test assemble-7.19 {lappendStk} { 564 -body { 565 proc x {} { 566 set able baker 567 assemble { 568 push able 569 push charlie 570 lappendStk 571 } 572 } 573 x 574 } 575 -result {baker charlie} 576 -cleanup {rename x {}} 577} 578test assemble-7.20 {listIndex} { 579 -body { 580 assemble { 581 push {a b c d} 582 push 2 583 listIndex 584 } 585 } 586 -result c 587} 588test assemble-7.21 {listLength} { 589 -body { 590 assemble { 591 push {a b c d} 592 listLength 593 } 594 } 595 -result 4 596} 597test assemble-7.22 {loadArrayStk} { 598 -body { 599 proc x {} { 600 set able(baker) charlie 601 assemble { 602 push able 603 push baker 604 loadArrayStk 605 } 606 } 607 x 608 } 609 -result charlie 610 -cleanup {rename x {}} 611} 612test assemble-7.23 {loadStk} { 613 -body { 614 proc x {} { 615 set able baker 616 assemble { 617 push able 618 loadStk 619 } 620 } 621 x 622 } 623 -result baker 624 -cleanup {rename x {}} 625} 626test assemble-7.24 {lsetList} { 627 -body { 628 proc x {} { 629 set l {{a b} {c d} {e f} {g h}} 630 assemble { 631 push {2 1}; push i; load l; lsetList 632 } 633 } 634 x 635 } 636 -result {{a b} {c d} {e i} {g h}} 637} 638test assemble-7.25 {lshift} { 639 -body { 640 assemble {push 16; push 4; lshift} 641 } 642 -result 256 643} 644test assemble-7.26 {mod} { 645 -body { 646 assemble {push 123456; push 1000; mod} 647 } 648 -result 456 649} 650test assemble-7.27 {mult} { 651 -body { 652 assemble {push 12345679; push 9; mult} 653 } 654 -result 111111111 655} 656test assemble-7.28 {neq} { 657 -body { 658 list \ 659 [assemble {push able; push baker; neq}] \ 660 [assemble {push able; push able; neq}] 661 } 662 -result {1 0} 663} 664test assemble-7.29 {not} { 665 -body { 666 list \ 667 [assemble {push 17; not}] \ 668 [assemble {push 0; not}] 669 } 670 -result {0 1} 671} 672test assemble-7.30 {pop} { 673 -body { 674 assemble {push this; pop; push that} 675 } 676 -result that 677} 678test assemble-7.31 {rshift} { 679 -body { 680 assemble {push 257; push 4; rshift} 681 } 682 -result 16 683} 684test assemble-7.32 {storeArrayStk} { 685 -body { 686 proc x {} { 687 assemble { 688 push able; push baker; push charlie; storeArrayStk 689 } 690 array get able 691 } 692 x 693 } 694 -result {baker charlie} 695 -cleanup {rename x {}} 696} 697test assemble-7.33 {storeStk} { 698 -body { 699 proc x {} { 700 assemble { 701 push able; push baker; storeStk 702 } 703 set able 704 } 705 x 706 } 707 -result {baker} 708 -cleanup {rename x {}} 709} 710test assemble-7,34 {strcmp} { 711 -body { 712 proc x {a b} { 713 assemble { 714 load a; load b; strcmp 715 } 716 } 717 list [x able baker] [x baker able] [x baker baker] 718 } 719 -result {-1 1 0} 720 -cleanup {rename x {}} 721} 722test assemble-7.35 {streq/strneq} { 723 -body { 724 proc x {a b} { 725 list \ 726 [assemble {load a; load b; streq}] \ 727 [assemble {load a; load b; strneq}] 728 } 729 list [x able able] [x able baker] 730 } 731 -result {{1 0} {0 1}} 732 -cleanup {rename x {}} 733} 734test assemble-7.36 {strindex} { 735 -body { 736 assemble {push testing; push 4; strindex} 737 } 738 -result i 739} 740test assemble-7.37 {strlen} { 741 -body { 742 assemble {push testing; strlen} 743 } 744 -result 7 745} 746test assemble-7.38 {sub} { 747 -body { 748 assemble {push 42; push 17; sub} 749 } 750 -result 25 751} 752test assemble-7.39 {tryCvtToNumeric} { 753 -body { 754 assemble { 755 push 42; tryCvtToNumeric 756 } 757 } 758 -result 42 759} 760# assemble-7.40 absent 761test assemble-7.41 {uminus} { 762 -body { 763 assemble { 764 push 42; uminus 765 } 766 } 767 -result -42 768} 769test assemble-7.42 {uplus} { 770 -body { 771 assemble { 772 push 42; uplus 773 } 774 } 775 -result 42 776} 777test assemble-7.43 {uplus} { 778 -body { 779 assemble { 780 push NaN; uplus 781 } 782 } 783 -returnCodes error 784 -result {can't use non-numeric floating-point value as operand of "+"} 785} 786test assemble-7.43.1 {tryCvtToNumeric} { 787 -body { 788 assemble { 789 push NaN; tryCvtToNumeric 790 } 791 } 792 -returnCodes error 793 -result {domain error: argument not in valid range} 794} 795test assemble-7.44 {listIn} { 796 -body { 797 assemble { 798 push b; push {a b c}; listIn 799 } 800 } 801 -result 1 802} 803test assemble-7.45 {listNotIn} { 804 -body { 805 assemble { 806 push d; push {a b c}; listNotIn 807 } 808 } 809 -result 1 810} 811test assemble-7.46 {nop} { 812 -body { 813 assemble { push x; nop; nop; nop} 814 } 815 -result x 816} 817 818# assemble-8 ASSEM_LVT and FindLocalVar 819 820test assemble-8.1 {load, wrong # args} { 821 -body { 822 assemble load 823 } 824 -returnCodes error 825 -match glob 826 -result {wrong # args*} 827} 828test assemble-8.2 {load, wrong # args} { 829 -body { 830 assemble {load too many} 831 } 832 -returnCodes error 833 -match glob 834 -result {wrong # args*} 835} 836test assemble-8.3 {nonlocal var} { 837 -body { 838 list [catch {assemble {load ::env}} result] $result $errorCode 839 } 840 -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} 841 -cleanup {unset result} 842} 843test assemble-8.4 {bad context} { 844 -body { 845 set x 1 846 list [catch {assemble {load x}} result] $result $errorCode 847 } 848 -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} 849 -cleanup {unset result} 850} 851test assemble-8.5 {bad context} { 852 -body { 853 namespace eval assem { 854 set x 1 855 list [catch {assemble {load x}} result opts] $result [dict get $opts -errorcode] 856 } 857 } 858 -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} 859 -cleanup {namespace delete assem} 860} 861test assemble-8.6 {load1} { 862 -body { 863 proc x {a} { 864 assemble { 865 load a 866 } 867 } 868 x able 869 } 870 -result able 871 -cleanup {rename x {}} 872} 873test assemble-8.7 {load4} { 874 -body { 875 proc x {a} " 876 [fillTables] 877 set b \$a 878 assemble {load b} 879 " 880 x able 881 } 882 -result able 883 -cleanup {rename x {}} 884} 885test assemble-8.8 {loadArray1} { 886 -body { 887 proc x {} { 888 set able(baker) charlie 889 assemble { 890 push baker 891 loadArray able 892 } 893 } 894 x 895 } 896 -result charlie 897 -cleanup {rename x {}} 898} 899test assemble-8.9 {loadArray4} { 900 -body " 901 proc x {} { 902 [fillTables] 903 set able(baker) charlie 904 assemble { 905 push baker 906 loadArray able 907 } 908 } 909 x 910 " 911 -result charlie 912 -cleanup {rename x {}} 913} 914test assemble-8.10 {append1} { 915 -body { 916 proc x {} { 917 set y {hello, } 918 assemble { 919 push world; append y 920 } 921 } 922 x 923 } 924 -result {hello, world} 925 -cleanup {rename x {}} 926} 927test assemble-8.11 {append4} { 928 -body { 929 proc x {} " 930 [fillTables] 931 set y {hello, } 932 assemble { 933 push world; append y 934 } 935 " 936 x 937 } 938 -result {hello, world} 939 -cleanup {rename x {}} 940} 941test assemble-8.12 {appendArray1} { 942 -body { 943 proc x {} { 944 set y(z) {hello, } 945 assemble { 946 push z; push world; appendArray y 947 } 948 } 949 x 950 } 951 -result {hello, world} 952 -cleanup {rename x {}} 953} 954test assemble-8.13 {appendArray4} { 955 -body { 956 proc x {} " 957 [fillTables] 958 set y(z) {hello, } 959 assemble { 960 push z; push world; appendArray y 961 } 962 " 963 x 964 } 965 -result {hello, world} 966 -cleanup {rename x {}} 967} 968test assemble-8.14 {lappend1} { 969 -body { 970 proc x {} { 971 set y {hello,} 972 assemble { 973 push world; lappend y 974 } 975 } 976 x 977 } 978 -result {hello, world} 979 -cleanup {rename x {}} 980} 981test assemble-8.15 {lappend4} { 982 -body { 983 proc x {} " 984 [fillTables] 985 set y {hello,} 986 assemble { 987 push world; lappend y 988 } 989 " 990 x 991 } 992 -result {hello, world} 993 -cleanup {rename x {}} 994} 995test assemble-8.16 {lappendArray1} { 996 -body { 997 proc x {} { 998 set y(z) {hello,} 999 assemble { 1000 push z; push world; lappendArray y 1001 } 1002 } 1003 x 1004 } 1005 -result {hello, world} 1006 -cleanup {rename x {}} 1007} 1008test assemble-8.17 {lappendArray4} { 1009 -body { 1010 proc x {} " 1011 [fillTables] 1012 set y(z) {hello,} 1013 assemble { 1014 push z; push world; lappendArray y 1015 } 1016 " 1017 x 1018 } 1019 -result {hello, world} 1020 -cleanup {rename x {}} 1021} 1022test assemble-8.18 {store1} { 1023 -body { 1024 proc x {} { 1025 assemble { 1026 push test; store y 1027 } 1028 set y 1029 } 1030 x 1031 } 1032 -result {test} 1033 -cleanup {rename x {}} 1034} 1035test assemble-8.19 {store4} { 1036 -body { 1037 proc x {} " 1038 [fillTables] 1039 assemble { 1040 push test; store y 1041 } 1042 set y 1043 " 1044 x 1045 } 1046 -result test 1047 -cleanup {rename x {}} 1048} 1049test assemble-8.20 {storeArray1} { 1050 -body { 1051 proc x {} { 1052 assemble { 1053 push z; push test; storeArray y 1054 } 1055 set y(z) 1056 } 1057 x 1058 } 1059 -result test 1060 -cleanup {rename x {}} 1061} 1062test assemble-8.21 {storeArray4} { 1063 -body { 1064 proc x {} " 1065 [fillTables] 1066 assemble { 1067 push z; push test; storeArray y 1068 } 1069 " 1070 x 1071 } 1072 -result test 1073 -cleanup {rename x {}} 1074} 1075 1076# assemble-9 - ASSEM_CONCAT1, GetIntegerOperand, CheckOneByte 1077 1078test assemble-9.1 {wrong # args} { 1079 -body {assemble concat} 1080 -result {wrong # args*} 1081 -match glob 1082 -returnCodes error 1083} 1084test assemble-9.2 {wrong # args} { 1085 -body {assemble {concat too many}} 1086 -result {wrong # args*} 1087 -match glob 1088 -returnCodes error 1089} 1090test assemble-9.3 {not a number} { 1091 -body {assemble {concat rubbish}} 1092 -result {expected integer but got "rubbish"} 1093 -returnCodes error 1094} 1095test assemble-9.4 {too small} { 1096 -body {assemble {concat -1}} 1097 -result {operand does not fit in one byte} 1098 -returnCodes error 1099} 1100test assemble-9.5 {too small} { 1101 -body {assemble {concat 256}} 1102 -result {operand does not fit in one byte} 1103 -returnCodes error 1104} 1105test assemble-9.6 {concat} { 1106 -body { 1107 assemble {push h; push e; push l; push l; push o; concat 5} 1108 } 1109 -result hello 1110} 1111test assemble-9.7 {concat} { 1112 -body { 1113 list [catch {assemble {concat 0}} result] $result $::errorCode 1114 } 1115 -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} 1116 -cleanup {unset result} 1117} 1118 1119# assemble-10 -- eval and expr 1120 1121test assemble-10.1 {eval - wrong # args} { 1122 -body { 1123 assemble {eval} 1124 } 1125 -returnCodes error 1126 -match glob 1127 -result {wrong # args*} 1128} 1129test assemble-10.2 {eval - wrong # args} { 1130 -body { 1131 assemble {eval too many} 1132 } 1133 -returnCodes error 1134 -match glob 1135 -result {wrong # args*} 1136} 1137test assemble-10.3 {eval} { 1138 -body { 1139 proc x {} { 1140 assemble { 1141 push 3 1142 store n 1143 pop 1144 eval {expr {3*$n + 1}} 1145 push 1 1146 add 1147 } 1148 } 1149 x 1150 } 1151 -result 11 1152 -cleanup {rename x {}} 1153} 1154test assemble-10.4 {expr} { 1155 -body { 1156 proc x {} { 1157 assemble { 1158 push 3 1159 store n 1160 pop 1161 expr {3*$n + 1} 1162 push 1 1163 add 1164 } 1165 } 1166 x 1167 } 1168 -result 11 1169 -cleanup {rename x {}} 1170} 1171test assemble-10.5 {eval and expr - nonsimple} { 1172 -body { 1173 proc x {} { 1174 assemble { 1175 eval "s\x65t n 3" 1176 pop 1177 expr "\x33*\$n + 1" 1178 push 1 1179 add 1180 } 1181 } 1182 x 1183 } 1184 -result 11 1185 -cleanup { 1186 rename x {} 1187 } 1188} 1189test assemble-10.6 {eval - noncompilable} { 1190 -body { 1191 list [catch {assemble {eval $x}} result] $result $::errorCode 1192 } 1193 -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} 1194} 1195test assemble-10.7 {expr - noncompilable} { 1196 -body { 1197 list [catch {assemble {expr $x}} result] $result $::errorCode 1198 } 1199 -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} 1200} 1201 1202# assemble-11 - ASSEM_LVT4 (exist, existArray, dictAppend, dictLappend, 1203# nsupvar, variable, upvar) 1204 1205test assemble-11.1 {exist - wrong # args} { 1206 -body { 1207 assemble {exist} 1208 } 1209 -returnCodes error 1210 -match glob 1211 -result {wrong # args*} 1212} 1213test assemble-11.2 {exist - wrong # args} { 1214 -body { 1215 assemble {exist too many} 1216 } 1217 -returnCodes error 1218 -match glob 1219 -result {wrong # args*} 1220} 1221test assemble-11.3 {nonlocal var} { 1222 -body { 1223 list [catch {assemble {exist ::env}} result] $result $errorCode 1224 } 1225 -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} 1226 -cleanup {unset result} 1227} 1228test assemble-11.4 {exist} { 1229 -body { 1230 proc x {} { 1231 set y z 1232 list [assemble {exist y}] \ 1233 [assemble {exist z}] 1234 } 1235 x 1236 } 1237 -result {1 0} 1238 -cleanup {rename x {}} 1239} 1240test assemble-11.5 {existArray} { 1241 -body { 1242 proc x {} { 1243 set a(b) c 1244 list [assemble {push b; existArray a}] \ 1245 [assemble {push c; existArray a}] \ 1246 [assemble {push a; existArray b}] 1247 } 1248 x 1249 } 1250 -result {1 0 0} 1251 -cleanup {rename x {}} 1252} 1253test assemble-11.6 {dictAppend} { 1254 -body { 1255 proc x {} { 1256 set dict {a 1 b 2 c 3} 1257 assemble {push b; push 22; dictAppend dict} 1258 } 1259 x 1260 } 1261 -result {a 1 b 222 c 3} 1262 -cleanup {rename x {}} 1263} 1264test assemble-11.7 {dictLappend} { 1265 -body { 1266 proc x {} { 1267 set dict {a 1 b 2 c 3} 1268 assemble {push b; push 2; dictLappend dict} 1269 } 1270 x 1271 } 1272 -result {a 1 b {2 2} c 3} 1273 -cleanup {rename x {}} 1274} 1275test assemble-11.8 {upvar} { 1276 -body { 1277 proc x {v} { 1278 assemble {push 1; load v; upvar w; pop; load w} 1279 } 1280 proc y {} { 1281 set z 123 1282 x z 1283 } 1284 y 1285 } 1286 -result 123 1287 -cleanup {rename x {}; rename y {}} 1288} 1289test assemble-11.9 {nsupvar} { 1290 -body { 1291 namespace eval q { variable v 123 } 1292 proc x {} { 1293 assemble {push q; push v; nsupvar y; pop; load y} 1294 } 1295 x 1296 } 1297 -result 123 1298 -cleanup {namespace delete q; rename x {}} 1299} 1300test assemble-11.10 {variable} { 1301 -body { 1302 namespace eval q { namespace eval r {variable v 123}} 1303 proc x {} { 1304 assemble {push q::r::v; variable y; load y} 1305 } 1306 x 1307 } 1308 -result 123 1309 -cleanup {namespace delete q; rename x {}} 1310} 1311 1312# assemble-12 - ASSEM_LVT1 (incr and incrArray) 1313 1314test assemble-12.1 {incr - wrong # args} { 1315 -body { 1316 assemble {incr} 1317 } 1318 -returnCodes error 1319 -match glob 1320 -result {wrong # args*} 1321} 1322test assemble-12.2 {incr - wrong # args} { 1323 -body { 1324 assemble {incr too many} 1325 } 1326 -returnCodes error 1327 -match glob 1328 -result {wrong # args*} 1329} 1330test assemble-12.3 {incr nonlocal var} { 1331 -body { 1332 list [catch {assemble {incr ::env}} result] $result $errorCode 1333 } 1334 -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} 1335 -cleanup {unset result} 1336} 1337test assemble-12.4 {incr} { 1338 -body { 1339 proc x {} { 1340 set y 5 1341 assemble {push 3; incr y} 1342 } 1343 x 1344 } 1345 -result 8 1346 -cleanup {rename x {}} 1347} 1348test assemble-12.5 {incrArray} { 1349 -body { 1350 proc x {} { 1351 set a(b) 5 1352 assemble {push b; push 3; incrArray a} 1353 } 1354 x 1355 } 1356 -result 8 1357 -cleanup {rename x {}} 1358} 1359test assemble-12.6 {incr, stupid stack restriction} { 1360 -body { 1361 proc x {} " 1362 [fillTables] 1363 set y 5 1364 assemble {push 3; incr y} 1365 " 1366 list [catch {x} result] $result $errorCode 1367 } 1368 -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} 1369 -cleanup {unset result; rename x {}} 1370} 1371 1372# assemble-13 -- ASSEM_LVT1_SINT1 - incrImm and incrArrayImm 1373 1374test assemble-13.1 {incrImm - wrong # args} { 1375 -body { 1376 assemble {incrImm x} 1377 } 1378 -returnCodes error 1379 -match glob 1380 -result {wrong # args*} 1381} 1382test assemble-13.2 {incrImm - wrong # args} { 1383 -body { 1384 assemble {incrImm too many args} 1385 } 1386 -returnCodes error 1387 -match glob 1388 -result {wrong # args*} 1389} 1390test assemble-13.3 {incrImm nonlocal var} { 1391 -body { 1392 list [catch {assemble {incrImm ::env 2}} result] $result $errorCode 1393 } 1394 -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} 1395 -cleanup {unset result} 1396} 1397test assemble-13.4 {incrImm not a number} { 1398 -body { 1399 proc x {} { 1400 assemble {incrImm x rubbish} 1401 } 1402 x 1403 } 1404 -returnCodes error 1405 -result {expected integer but got "rubbish"} 1406 -cleanup {rename x {}} 1407} 1408test assemble-13.5 {incrImm too big} { 1409 -body { 1410 proc x {} { 1411 assemble {incrImm x 0x80} 1412 } 1413 list [catch x result] $result $::errorCode 1414 } 1415 -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} 1416 -cleanup {rename x {}; unset result} 1417} 1418test assemble-13.6 {incrImm too small} { 1419 -body { 1420 proc x {} { 1421 assemble {incrImm x -0x81} 1422 } 1423 list [catch x result] $result $::errorCode 1424 } 1425 -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} 1426 -cleanup {rename x {}; unset result} 1427} 1428test assemble-13.7 {incrImm} { 1429 -body { 1430 proc x {} { 1431 set y 1 1432 list [assemble {incrImm y -0x80}] [assemble {incrImm y 0x7f}] 1433 } 1434 x 1435 } 1436 -result {-127 0} 1437 -cleanup {rename x {}} 1438} 1439test assemble-13.8 {incrArrayImm} { 1440 -body { 1441 proc x {} { 1442 set a(b) 5 1443 assemble {push b; incrArrayImm a 3} 1444 } 1445 x 1446 } 1447 -result 8 1448 -cleanup {rename x {}} 1449} 1450test assemble-13.9 {incrImm, stupid stack restriction} { 1451 -body { 1452 proc x {} " 1453 [fillTables] 1454 set y 5 1455 assemble {incrImm y 3} 1456 " 1457 list [catch {x} result] $result $errorCode 1458 } 1459 -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} 1460 -cleanup {unset result; rename x {}} 1461} 1462 1463# assemble-14 -- ASSEM_SINT1 (incrArrayStkImm and incrStkImm) 1464 1465test assemble-14.1 {incrStkImm - wrong # args} { 1466 -body { 1467 assemble {incrStkImm} 1468 } 1469 -returnCodes error 1470 -match glob 1471 -result {wrong # args*} 1472} 1473test assemble-14.2 {incrStkImm - wrong # args} { 1474 -body { 1475 assemble {incrStkImm too many} 1476 } 1477 -returnCodes error 1478 -match glob 1479 -result {wrong # args*} 1480} 1481test assemble-14.3 {incrStkImm not a number} { 1482 -body { 1483 proc x {} { 1484 assemble {incrStkImm rubbish} 1485 } 1486 x 1487 } 1488 -returnCodes error 1489 -result {expected integer but got "rubbish"} 1490 -cleanup {rename x {}} 1491} 1492test assemble-14.4 {incrStkImm too big} { 1493 -body { 1494 proc x {} { 1495 assemble {incrStkImm 0x80} 1496 } 1497 list [catch x result] $result $::errorCode 1498 } 1499 -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} 1500 -cleanup {rename x {}; unset result} 1501} 1502test assemble-14.5 {incrStkImm too small} { 1503 -body { 1504 proc x {} { 1505 assemble {incrStkImm -0x81} 1506 } 1507 list [catch x result] $result $::errorCode 1508 } 1509 -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} 1510 -cleanup {rename x {}; unset result} 1511} 1512test assemble-14.6 {incrStkImm} { 1513 -body { 1514 proc x {} { 1515 set y 1 1516 list [assemble {push y; incrStkImm -0x80}] \ 1517 [assemble {push y; incrStkImm 0x7f}] 1518 } 1519 x 1520 } 1521 -result {-127 0} 1522 -cleanup {rename x {}} 1523} 1524test assemble-14.7 {incrArrayStkImm} { 1525 -body { 1526 proc x {} { 1527 set a(b) 5 1528 assemble {push a; push b; incrArrayStkImm 3} 1529 } 1530 x 1531 } 1532 -result 8 1533 -cleanup {rename x {}} 1534} 1535 1536# assemble-15 - listIndexImm 1537 1538test assemble-15.1 {listIndexImm - wrong # args} -body { 1539 assemble {listIndexImm} 1540} -returnCodes error -match glob -result {wrong # args*} 1541test assemble-15.2 {listIndexImm - wrong # args} -body { 1542 assemble {listIndexImm too many} 1543} -returnCodes error -match glob -result {wrong # args*} 1544test assemble-15.3 {listIndexImm - bad substitution} -body { 1545 list [catch {assemble {listIndexImm $foo}} result] $result $::errorCode 1546} -cleanup { 1547 unset result 1548} -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} 1549test assemble-15.4 {listIndexImm - invalid index} -body { 1550 assemble {listIndexImm rubbish} 1551} -returnCodes error -match glob -result {bad index "rubbish"*} 1552test assemble-15.5 {listIndexImm} -body { 1553 assemble {push {a b c}; listIndexImm 2} 1554} -result c 1555test assemble-15.6 {listIndexImm} -body { 1556 assemble {push {a b c}; listIndexImm end-1} 1557} -result b 1558test assemble-15.7 {listIndexImm} -body { 1559 assemble {push {a b c}; listIndexImm end} 1560} -result c 1561test assemble-15.8 {listIndexImm} -body { 1562 assemble {push {a b c}; listIndexImm end+2} 1563} -result {} 1564test assemble-15.9 {listIndexImm} -body { 1565 assemble {push {a b c}; listIndexImm -1-1} 1566} -result {} 1567 1568# assemble-16 - invokeStk 1569 1570test assemble-16.1 {invokeStk - wrong # args} { 1571 -body { 1572 assemble {invokeStk} 1573 } 1574 -returnCodes error 1575 -match glob 1576 -result {wrong # args*} 1577} 1578test assemble-16.2 {invokeStk - wrong # args} { 1579 -body { 1580 assemble {invokeStk too many} 1581 } 1582 -returnCodes error 1583 -match glob 1584 -result {wrong # args*} 1585} 1586test assemble-16.3 {invokeStk - not a number} { 1587 -body { 1588 proc x {} { 1589 assemble {invokeStk rubbish} 1590 } 1591 x 1592 } 1593 -returnCodes error 1594 -result {expected integer but got "rubbish"} 1595 -cleanup {rename x {}} 1596} 1597test assemble-16.4 {invokeStk - no operands} { 1598 -body { 1599 proc x {} { 1600 assemble {invokeStk 0} 1601 } 1602 list [catch x result] $result $::errorCode 1603 } 1604 -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} 1605 -cleanup {rename x {}; unset result} 1606} 1607test assemble-16.5 {invokeStk1} { 1608 -body { 1609 tcl::unsupported::assemble {push concat; push 1; push 2; invokeStk 3} 1610 } 1611 -result {1 2} 1612} 1613test assemble-16.6 {invokeStk4} { 1614 -body { 1615 proc x {n} { 1616 set code {push concat} 1617 set shouldbe {} 1618 for {set i 1} {$i < $n} {incr i} { 1619 append code \n {push a} $i 1620 lappend shouldbe a$i 1621 } 1622 append code \n {invokeStk} { } $n 1623 set is [assemble $code] 1624 expr {$is eq $shouldbe} 1625 } 1626 list [x 254] [x 255] [x 256] [x 257] 1627 } 1628 -result {1 1 1 1} 1629 -cleanup {rename x {}} 1630} 1631 1632# assemble-17 -- jumps and labels 1633 1634test assemble-17.1 {label, wrong # args} { 1635 -body { 1636 assemble {label} 1637 } 1638 -returnCodes error 1639 -match glob 1640 -result {wrong # args*} 1641} 1642test assemble-17.2 {label, wrong # args} { 1643 -body { 1644 assemble {label too many} 1645 } 1646 -returnCodes error 1647 -match glob 1648 -result {wrong # args*} 1649} 1650test assemble-17.3 {label, bad subst} { 1651 -body { 1652 list [catch {assemble {label $foo}} result] $result $::errorCode 1653 } 1654 -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} 1655 -cleanup {unset result} 1656} 1657test assemble-17.4 {duplicate label} { 1658 -body { 1659 list [catch {assemble {label foo; label foo}} result] \ 1660 $result $::errorCode 1661 } 1662 -result {1 {duplicate definition of label "foo"} {TCL ASSEM DUPLABEL foo}} 1663} 1664test assemble-17.5 {jump, wrong # args} { 1665 -body { 1666 assemble {jump} 1667 } 1668 -returnCodes error 1669 -match glob 1670 -result {wrong # args*} 1671} 1672test assemble-17.6 {jump, wrong # args} { 1673 -body { 1674 assemble {jump too many} 1675 } 1676 -returnCodes error 1677 -match glob 1678 -result {wrong # args*} 1679} 1680test assemble-17.7 {jump, bad subst} { 1681 -body { 1682 list [catch {assemble {jump $foo}} result] $result $::errorCode 1683 } 1684 -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} 1685 -cleanup {unset result} 1686} 1687test assemble-17.8 {jump - ahead and back} { 1688 -body { 1689 assemble { 1690 jump three 1691 1692 label one 1693 push a 1694 jump four 1695 1696 label two 1697 push b 1698 jump six 1699 1700 label three 1701 push c 1702 jump five 1703 1704 label four 1705 push d 1706 jump two 1707 1708 label five 1709 push e 1710 jump one 1711 1712 label six 1713 push f 1714 concat 6 1715 } 1716 } 1717 -result ceadbf 1718} 1719test assemble-17.9 {jump - resolve a label multiple times} { 1720 -body { 1721 proc x {} { 1722 set case 0 1723 set result {} 1724 assemble { 1725 jump common 1726 1727 label zero 1728 pop 1729 incrImm case 1 1730 pop 1731 push a 1732 append result 1733 pop 1734 jump common 1735 1736 label one 1737 pop 1738 incrImm case 1 1739 pop 1740 push b 1741 append result 1742 pop 1743 jump common 1744 1745 label common 1746 load case 1747 dup 1748 push 0 1749 eq 1750 jumpTrue zero 1751 dup 1752 push 1 1753 eq 1754 jumpTrue one 1755 dup 1756 push 2 1757 eq 1758 jumpTrue two 1759 dup 1760 push 3 1761 eq 1762 jumpTrue three 1763 1764 label two 1765 pop 1766 incrImm case 1 1767 pop 1768 push c 1769 append result 1770 pop 1771 jump common 1772 1773 label three 1774 pop 1775 incrImm case 1 1776 pop 1777 push d 1778 append result 1779 } 1780 } 1781 x 1782 } 1783 -result abcd 1784 -cleanup {rename x {}} 1785} 1786test assemble-17.10 {jump4 needed} { 1787 -body { 1788 assemble "push x; jump one; label two; [string repeat {dup; pop;} 128] 1789 jump three; label one; jump two; label three" 1790 } 1791 -result x 1792} 1793test assemble-17.11 {jumpTrue} { 1794 -body { 1795 proc x {y} { 1796 assemble { 1797 load y 1798 jumpTrue then 1799 push no 1800 jump else 1801 label then 1802 push yes 1803 label else 1804 } 1805 } 1806 list [x 0] [x 1] 1807 } 1808 -result {no yes} 1809 -cleanup {rename x {}} 1810} 1811test assemble-17.12 {jumpFalse} { 1812 -body { 1813 proc x {y} { 1814 assemble { 1815 load y 1816 jumpFalse then 1817 push no 1818 jump else 1819 label then 1820 push yes 1821 label else 1822 } 1823 } 1824 list [x 0] [x 1] 1825 } 1826 -result {yes no} 1827 -cleanup {rename x {}} 1828} 1829test assemble-17.13 {jump to undefined label} { 1830 -body { 1831 list [catch {assemble {jump nowhere}} result] $result $::errorCode 1832 } 1833 -result {1 {undefined label "nowhere"} {TCL ASSEM NOLABEL nowhere}} 1834} 1835test assemble-17.14 {jump to undefined label, line number correct?} { 1836 -body { 1837 catch {assemble {#1 1838 #2 1839 #3 1840 jump nowhere 1841 #5 1842 #6 1843 }} 1844 set ::errorInfo 1845 } 1846 -match glob 1847 -result {*"assemble" body, line 4*} 1848} 1849test assemble-17.15 {multiple passes of code resizing} { 1850 -setup { 1851 set body { 1852 push - 1853 } 1854 for {set i 0} {$i < 14} {incr i} { 1855 append body "label a" $i \ 1856 "; push a; concat 2; nop; nop; jump b" \ 1857 $i \n 1858 } 1859 append body {label a14; push a; concat 2; push 1; jumpTrue b14} \n 1860 append body {label a15; push a; concat 2; push 0; jumpFalse b15} \n 1861 for {set i 0} {$i < 15} {incr i} { 1862 append body "label b" $i \ 1863 "; push b; concat 2; nop; nop; jump a" \ 1864 [expr {$i+1}] \n 1865 } 1866 append body {label c; push -; concat 2; nop; nop; nop; jump d} \n 1867 append body {label b15; push b; concat 2; nop; nop; jump c} \n 1868 append body {label d} 1869 proc x {} [list assemble $body] 1870 } 1871 -body { 1872 x 1873 } 1874 -cleanup { 1875 catch {unset body} 1876 catch {rename x {}} 1877 } 1878 -result -abababababababababababababababab- 1879} 1880 1881# assemble-18 - lindexMulti 1882 1883test assemble-18.1 {lindexMulti - wrong # args} { 1884 -body { 1885 assemble {lindexMulti} 1886 } 1887 -returnCodes error 1888 -match glob 1889 -result {wrong # args*} 1890} 1891test assemble-18.2 {lindexMulti - wrong # args} { 1892 -body { 1893 assemble {lindexMulti too many} 1894 } 1895 -returnCodes error 1896 -match glob 1897 -result {wrong # args*} 1898} 1899test assemble-18.3 {lindexMulti - bad subst} { 1900 -body { 1901 assemble {lindexMulti $foo} 1902 } 1903 -returnCodes error 1904 -match glob 1905 -result {assembly code may not contain substitutions} 1906} 1907test assemble-18.4 {lindexMulti - not a number} { 1908 -body { 1909 proc x {} { 1910 assemble {lindexMulti rubbish} 1911 } 1912 x 1913 } 1914 -returnCodes error 1915 -result {expected integer but got "rubbish"} 1916 -cleanup {rename x {}} 1917} 1918test assemble-18.5 {lindexMulti - bad operand count} { 1919 -body { 1920 proc x {} { 1921 assemble {lindexMulti 0} 1922 } 1923 list [catch x result] $result $::errorCode 1924 } 1925 -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} 1926 -cleanup {rename x {}; unset result} 1927} 1928test assemble-18.6 {lindexMulti} { 1929 -body { 1930 assemble {push {{a b c} {d e f} {g h j}}; lindexMulti 1} 1931 } 1932 -result {{a b c} {d e f} {g h j}} 1933} 1934test assemble-18.7 {lindexMulti} { 1935 -body { 1936 assemble {push {{a b c} {d e f} {g h j}}; push 1; lindexMulti 2} 1937 } 1938 -result {d e f} 1939} 1940test assemble-18.8 {lindexMulti} { 1941 -body { 1942 assemble {push {{a b c} {d e f} {g h j}}; push 2; push 1; lindexMulti 3} 1943 } 1944 -result h 1945} 1946 1947# assemble-19 - list 1948 1949test assemble-19.1 {list - wrong # args} { 1950 -body { 1951 assemble {list} 1952 } 1953 -returnCodes error 1954 -match glob 1955 -result {wrong # args*} 1956} 1957test assemble-19.2 {list - wrong # args} { 1958 -body { 1959 assemble {list too many} 1960 } 1961 -returnCodes error 1962 -match glob 1963 -result {wrong # args*} 1964} 1965test assemble-19.3 {list - bad subst} { 1966 -body { 1967 assemble {list $foo} 1968 } 1969 -returnCodes error 1970 -match glob 1971 -result {assembly code may not contain substitutions} 1972} 1973test assemble-19.4 {list - not a number} { 1974 -body { 1975 proc x {} { 1976 assemble {list rubbish} 1977 } 1978 x 1979 } 1980 -returnCodes error 1981 -result {expected integer but got "rubbish"} 1982 -cleanup {rename x {}} 1983} 1984test assemble-19.5 {list - negative operand count} { 1985 -body { 1986 proc x {} { 1987 assemble {list -1} 1988 } 1989 list [catch x result] $result $::errorCode 1990 } 1991 -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} 1992 -cleanup {rename x {}; unset result} 1993} 1994test assemble-19.6 {list - no args} { 1995 -body { 1996 assemble {list 0} 1997 } 1998 -result {} 1999} 2000test assemble-19.7 {list - 1 arg} { 2001 -body { 2002 assemble {push hello; list 1} 2003 } 2004 -result hello 2005} 2006test assemble-19.8 {list - 2 args} { 2007 -body { 2008 assemble {push hello; push world; list 2} 2009 } 2010 -result {hello world} 2011} 2012 2013# assemble-20 - lsetFlat 2014 2015test assemble-20.1 {lsetFlat - wrong # args} { 2016 -body { 2017 assemble {lsetFlat} 2018 } 2019 -returnCodes error 2020 -match glob 2021 -result {wrong # args*} 2022} 2023test assemble-20.2 {lsetFlat - wrong # args} { 2024 -body { 2025 assemble {lsetFlat too many} 2026 } 2027 -returnCodes error 2028 -match glob 2029 -result {wrong # args*} 2030} 2031test assemble-20.3 {lsetFlat - bad subst} { 2032 -body { 2033 assemble {lsetFlat $foo} 2034 } 2035 -returnCodes error 2036 -match glob 2037 -result {assembly code may not contain substitutions} 2038} 2039test assemble-20.4 {lsetFlat - not a number} { 2040 -body { 2041 proc x {} { 2042 assemble {lsetFlat rubbish} 2043 } 2044 x 2045 } 2046 -returnCodes error 2047 -result {expected integer but got "rubbish"} 2048 -cleanup {rename x {}} 2049} 2050test assemble-20.5 {lsetFlat - negative operand count} { 2051 -body { 2052 proc x {} { 2053 assemble {lsetFlat 1} 2054 } 2055 list [catch x result] $result $::errorCode 2056 } 2057 -result {1 {operand must be >=2} {TCL ASSEM OPERAND>=2}} 2058 -cleanup {rename x {}; unset result} 2059} 2060test assemble-20.6 {lsetFlat} { 2061 -body { 2062 assemble {push b; push a; lsetFlat 2} 2063 } 2064 -result b 2065} 2066test assemble-20.7 {lsetFlat} { 2067 -body { 2068 assemble {push 1; push d; push {a b c}; lsetFlat 3} 2069 } 2070 -result {a d c} 2071} 2072 2073# assemble-21 - over 2074 2075test assemble-21.1 {over - wrong # args} { 2076 -body { 2077 assemble {over} 2078 } 2079 -returnCodes error 2080 -match glob 2081 -result {wrong # args*} 2082} 2083test assemble-21.2 {over - wrong # args} { 2084 -body { 2085 assemble {over too many} 2086 } 2087 -returnCodes error 2088 -match glob 2089 -result {wrong # args*} 2090} 2091test assemble-21.3 {over - bad subst} { 2092 -body { 2093 assemble {over $foo} 2094 } 2095 -returnCodes error 2096 -match glob 2097 -result {assembly code may not contain substitutions} 2098} 2099test assemble-21.4 {over - not a number} { 2100 -body { 2101 proc x {} { 2102 assemble {over rubbish} 2103 } 2104 x 2105 } 2106 -returnCodes error 2107 -result {expected integer but got "rubbish"} 2108 -cleanup {rename x {}} 2109} 2110test assemble-21.5 {over - negative operand count} { 2111 -body { 2112 proc x {} { 2113 assemble {over -1} 2114 } 2115 list [catch x result] $result $::errorCode 2116 } 2117 -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} 2118 -cleanup {rename x {}; unset result} 2119} 2120test assemble-21.6 {over} { 2121 -body { 2122 proc x {} { 2123 assemble { 2124 push 1 2125 push 2 2126 push 3 2127 over 0 2128 store x 2129 pop 2130 pop 2131 pop 2132 pop 2133 load x 2134 } 2135 } 2136 x 2137 } 2138 -result 3 2139 -cleanup {rename x {}} 2140} 2141test assemble-21.7 {over} { 2142 -body { 2143 proc x {} { 2144 assemble { 2145 push 1 2146 push 2 2147 push 3 2148 over 2 2149 store x 2150 pop 2151 pop 2152 pop 2153 pop 2154 load x 2155 } 2156 } 2157 x 2158 } 2159 -result 1 2160 -cleanup {rename x {}} 2161} 2162 2163# assemble-22 - reverse 2164 2165test assemble-22.1 {reverse - wrong # args} { 2166 -body { 2167 assemble {reverse} 2168 } 2169 -returnCodes error 2170 -match glob 2171 -result {wrong # args*} 2172} 2173test assemble-22.2 {reverse - wrong # args} { 2174 -body { 2175 assemble {reverse too many} 2176 } 2177 -returnCodes error 2178 -match glob 2179 -result {wrong # args*} 2180} 2181 2182test assemble-22.3 {reverse - bad subst} { 2183 -body { 2184 assemble {reverse $foo} 2185 } 2186 -returnCodes error 2187 -match glob 2188 -result {assembly code may not contain substitutions} 2189} 2190 2191test assemble-22.4 {reverse - not a number} { 2192 -body { 2193 proc x {} { 2194 assemble {reverse rubbish} 2195 } 2196 x 2197 } 2198 -returnCodes error 2199 -result {expected integer but got "rubbish"} 2200 -cleanup {rename x {}} 2201} 2202test assemble-22.5 {reverse - negative operand count} { 2203 -body { 2204 proc x {} { 2205 assemble {reverse -1} 2206 } 2207 list [catch x result] $result $::errorCode 2208 } 2209 -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} 2210 -cleanup {rename x {}; unset result} 2211} 2212test assemble-22.6 {reverse - zero operand count} { 2213 -body { 2214 proc x {} { 2215 assemble {push 1; reverse 0} 2216 } 2217 x 2218 } 2219 -result 1 2220 -cleanup {rename x {}} 2221} 2222test assemble-22.7 {reverse} { 2223 -body { 2224 proc x {} { 2225 assemble { 2226 push 1 2227 push 2 2228 push 3 2229 reverse 1 2230 store x 2231 pop 2232 pop 2233 pop 2234 load x 2235 } 2236 } 2237 x 2238 } 2239 -result 3 2240 -cleanup {rename x {}} 2241} 2242test assemble-22.8 {reverse} { 2243 -body { 2244 proc x {} { 2245 assemble { 2246 push 1 2247 push 2 2248 push 3 2249 reverse 3 2250 store x 2251 pop 2252 pop 2253 pop 2254 load x 2255 } 2256 } 2257 x 2258 } 2259 -result 1 2260 -cleanup {rename x {}} 2261} 2262 2263# assemble-23 - ASSEM_BOOL (strmatch, unsetStk, unsetArrayStk) 2264 2265test assemble-23.1 {strmatch - wrong # args} { 2266 -body { 2267 assemble {strmatch} 2268 } 2269 -returnCodes error 2270 -match glob 2271 -result {wrong # args*} 2272} 2273test assemble-23.2 {strmatch - wrong # args} { 2274 -body { 2275 assemble {strmatch too many} 2276 } 2277 -returnCodes error 2278 -match glob 2279 -result {wrong # args*} 2280} 2281test assemble-23.3 {strmatch - bad subst} { 2282 -body { 2283 assemble {strmatch $foo} 2284 } 2285 -returnCodes error 2286 -match glob 2287 -result {assembly code may not contain substitutions} 2288} 2289test assemble-23.4 {strmatch - not a boolean} { 2290 -body { 2291 proc x {} { 2292 assemble {strmatch rubbish} 2293 } 2294 x 2295 } 2296 -returnCodes error 2297 -result {expected boolean value but got "rubbish"} 2298 -cleanup {rename x {}} 2299} 2300test assemble-23.5 {strmatch} { 2301 -body { 2302 proc x {a b} { 2303 list [assemble {load a; load b; strmatch 0}] \ 2304 [assemble {load a; load b; strmatch 1}] 2305 } 2306 list [x foo*.grill fengbar.grill] [x foo*.grill foobar.grill] [x foo*.grill FOOBAR.GRILL] 2307 } 2308 -result {{0 0} {1 1} {0 1}} 2309 -cleanup {rename x {}} 2310} 2311test assemble-23.6 {unsetStk} { 2312 -body { 2313 proc x {} { 2314 set a {} 2315 assemble {push a; unsetStk false} 2316 info exists a 2317 } 2318 x 2319 } 2320 -result 0 2321 -cleanup {rename x {}} 2322} 2323test assemble-23.7 {unsetStk} { 2324 -body { 2325 proc x {} { 2326 assemble {push a; unsetStk false} 2327 info exists a 2328 } 2329 x 2330 } 2331 -result 0 2332 -cleanup {rename x {}} 2333} 2334test assemble-23.8 {unsetStk} { 2335 -body { 2336 proc x {} { 2337 assemble {push a; unsetStk true} 2338 info exists a 2339 } 2340 x 2341 } 2342 -returnCodes error 2343 -result {can't unset "a": no such variable} 2344 -cleanup {rename x {}} 2345} 2346test assemble-23.9 {unsetArrayStk} { 2347 -body { 2348 proc x {} { 2349 set a(b) {} 2350 assemble {push a; push b; unsetArrayStk false} 2351 info exists a(b) 2352 } 2353 x 2354 } 2355 -result 0 2356 -cleanup {rename x {}} 2357} 2358test assemble-23.10 {unsetArrayStk} { 2359 -body { 2360 proc x {} { 2361 assemble {push a; push b; unsetArrayStk false} 2362 info exists a(b) 2363 } 2364 x 2365 } 2366 -result 0 2367 -cleanup {rename x {}} 2368} 2369test assemble-23.11 {unsetArrayStk} { 2370 -body { 2371 proc x {} { 2372 assemble {push a; push b; unsetArrayStk true} 2373 info exists a(b) 2374 } 2375 x 2376 } 2377 -returnCodes error 2378 -result {can't unset "a(b)": no such variable} 2379 -cleanup {rename x {}} 2380} 2381 2382# assemble-24 -- ASSEM_BOOL_LVT4 (unset; unsetArray) 2383 2384test assemble-24.1 {unset - wrong # args} { 2385 -body { 2386 assemble {unset one} 2387 } 2388 -returnCodes error 2389 -match glob 2390 -result {wrong # args*} 2391} 2392test assemble-24.2 {unset - wrong # args} { 2393 -body { 2394 assemble {unset too many args} 2395 } 2396 -returnCodes error 2397 -match glob 2398 -result {wrong # args*} 2399} 2400test assemble-24.3 {unset - bad subst -arg 1} { 2401 -body { 2402 assemble {unset $foo bar} 2403 } 2404 -returnCodes error 2405 -match glob 2406 -result {assembly code may not contain substitutions} 2407} 2408test assemble-24.4 {unset - not a boolean} { 2409 -body { 2410 proc x {} { 2411 assemble {unset rubbish trash} 2412 } 2413 x 2414 } 2415 -returnCodes error 2416 -result {expected boolean value but got "rubbish"} 2417 -cleanup {rename x {}} 2418} 2419test assemble-24.5 {unset - bad subst - arg 2} { 2420 -body { 2421 assemble {unset true $bar} 2422 } 2423 -returnCodes error 2424 -result {assembly code may not contain substitutions} 2425} 2426test assemble-24.6 {unset - nonlocal var} { 2427 -body { 2428 assemble {unset true ::foo::bar} 2429 } 2430 -returnCodes error 2431 -result {variable "::foo::bar" is not local} 2432} 2433test assemble-24.7 {unset} { 2434 -body { 2435 proc x {} { 2436 set a {} 2437 assemble {unset false a} 2438 info exists a 2439 } 2440 x 2441 } 2442 -result 0 2443 -cleanup {rename x {}} 2444} 2445test assemble-24.8 {unset} { 2446 -body { 2447 proc x {} { 2448 assemble {unset false a} 2449 info exists a 2450 } 2451 x 2452 } 2453 -result 0 2454 -cleanup {rename x {}} 2455} 2456test assemble-24.9 {unset} { 2457 -body { 2458 proc x {} { 2459 assemble {unset true a} 2460 info exists a 2461 } 2462 x 2463 } 2464 -returnCodes error 2465 -result {can't unset "a": no such variable} 2466 -cleanup {rename x {}} 2467} 2468test assemble-24.10 {unsetArray} { 2469 -body { 2470 proc x {} { 2471 set a(b) {} 2472 assemble {push b; unsetArray false a} 2473 info exists a(b) 2474 } 2475 x 2476 } 2477 -result 0 2478 -cleanup {rename x {}} 2479} 2480test assemble-24.11 {unsetArray} { 2481 -body { 2482 proc x {} { 2483 assemble {push b; unsetArray false a} 2484 info exists a(b) 2485 } 2486 x 2487 } 2488 -result 0 2489 -cleanup {rename x {}} 2490} 2491test assemble-24.12 {unsetArray} { 2492 -body { 2493 proc x {} { 2494 assemble {push b; unsetArray true a} 2495 info exists a(b) 2496 } 2497 x 2498 } 2499 -returnCodes error 2500 -result {can't unset "a(b)": no such variable} 2501 -cleanup {rename x {}} 2502} 2503 2504# assemble-25 - dict get 2505 2506test assemble-25.1 {dict get - wrong # args} { 2507 -body { 2508 assemble {dictGet} 2509 } 2510 -returnCodes error 2511 -match glob 2512 -result {wrong # args*} 2513} 2514test assemble-25.2 {dict get - wrong # args} { 2515 -body { 2516 assemble {dictGet too many} 2517 } 2518 -returnCodes error 2519 -match glob 2520 -result {wrong # args*} 2521} 2522test assemble-25.3 {dictGet - bad subst} { 2523 -body { 2524 assemble {dictGet $foo} 2525 } 2526 -returnCodes error 2527 -match glob 2528 -result {assembly code may not contain substitutions} 2529} 2530test assemble-25.4 {dict get - not a number} { 2531 -body { 2532 proc x {} { 2533 assemble {dictGet rubbish} 2534 } 2535 x 2536 } 2537 -returnCodes error 2538 -result {expected integer but got "rubbish"} 2539 -cleanup {rename x {}} 2540} 2541test assemble-25.5 {dictGet - negative operand count} { 2542 -body { 2543 proc x {} { 2544 assemble {dictGet 0} 2545 } 2546 list [catch x result] $result $::errorCode 2547 } 2548 -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} 2549 -cleanup {rename x {}; unset result} 2550} 2551test assemble-25.6 {dictGet - 1 index} { 2552 -body { 2553 assemble {push {a 1 b 2}; push a; dictGet 1} 2554 } 2555 -result 1 2556} 2557 2558# assemble-26 - dict set 2559 2560test assemble-26.1 {dict set - wrong # args} { 2561 -body { 2562 assemble {dictSet 1} 2563 } 2564 -returnCodes error 2565 -match glob 2566 -result {wrong # args*} 2567} 2568test assemble-26.2 {dict get - wrong # args} { 2569 -body { 2570 assemble {dictSet too many args} 2571 } 2572 -returnCodes error 2573 -match glob 2574 -result {wrong # args*} 2575} 2576test assemble-26.3 {dictSet - bad subst} { 2577 -body { 2578 assemble {dictSet 1 $foo} 2579 } 2580 -returnCodes error 2581 -match glob 2582 -result {assembly code may not contain substitutions} 2583} 2584test assemble-26.4 {dictSet - not a number} { 2585 -body { 2586 proc x {} { 2587 assemble {dictSet rubbish foo} 2588 } 2589 x 2590 } 2591 -returnCodes error 2592 -result {expected integer but got "rubbish"} 2593 -cleanup {rename x {}} 2594} 2595test assemble-26.5 {dictSet - zero operand count} { 2596 -body { 2597 proc x {} { 2598 assemble {dictSet 0 foo} 2599 } 2600 list [catch x result] $result $::errorCode 2601 } 2602 -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} 2603 -cleanup {rename x {}; unset result} 2604} 2605test assemble-26.6 {dictSet - bad local} { 2606 -body { 2607 proc x {} { 2608 assemble {dictSet 1 ::foo::bar} 2609 } 2610 list [catch x result] $result $::errorCode 2611 } 2612 -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} 2613 -cleanup {rename x {}; unset result} 2614} 2615test assemble-26.7 {dictSet} { 2616 -body { 2617 proc x {} { 2618 set dict {a 1 b 2 c 3} 2619 assemble {push b; push 4; dictSet 1 dict} 2620 } 2621 x 2622 } 2623 -result {a 1 b 4 c 3} 2624 -cleanup {rename x {}} 2625} 2626 2627# assemble-27 - dictUnset 2628 2629test assemble-27.1 {dictUnset - wrong # args} { 2630 -body { 2631 assemble {dictUnset 1} 2632 } 2633 -returnCodes error 2634 -match glob 2635 -result {wrong # args*} 2636} 2637test assemble-27.2 {dictUnset - wrong # args} { 2638 -body { 2639 assemble {dictUnset too many args} 2640 } 2641 -returnCodes error 2642 -match glob 2643 -result {wrong # args*} 2644} 2645test assemble-27.3 {dictUnset - bad subst} { 2646 -body { 2647 assemble {dictUnset 1 $foo} 2648 } 2649 -returnCodes error 2650 -match glob 2651 -result {assembly code may not contain substitutions} 2652} 2653test assemble-27.4 {dictUnset - not a number} { 2654 -body { 2655 proc x {} { 2656 assemble {dictUnset rubbish foo} 2657 } 2658 x 2659 } 2660 -returnCodes error 2661 -result {expected integer but got "rubbish"} 2662 -cleanup {rename x {}} 2663} 2664test assemble-27.5 {dictUnset - zero operand count} { 2665 -body { 2666 proc x {} { 2667 assemble {dictUnset 0 foo} 2668 } 2669 list [catch x result] $result $::errorCode 2670 } 2671 -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} 2672 -cleanup {rename x {}; unset result} 2673} 2674test assemble-27.6 {dictUnset - bad local} { 2675 -body { 2676 proc x {} { 2677 assemble {dictUnset 1 ::foo::bar} 2678 } 2679 list [catch x result] $result $::errorCode 2680 } 2681 -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} 2682 -cleanup {rename x {}; unset result} 2683} 2684test assemble-27.7 {dictUnset} { 2685 -body { 2686 proc x {} { 2687 set dict {a 1 b 2 c 3} 2688 assemble {push b; dictUnset 1 dict} 2689 } 2690 x 2691 } 2692 -result {a 1 c 3} 2693 -cleanup {rename x {}} 2694} 2695 2696# assemble-28 - dictIncrImm 2697 2698test assemble-28.1 {dictIncrImm - wrong # args} { 2699 -body { 2700 assemble {dictIncrImm 1} 2701 } 2702 -returnCodes error 2703 -match glob 2704 -result {wrong # args*} 2705} 2706test assemble-28.2 {dictIncrImm - wrong # args} { 2707 -body { 2708 assemble {dictIncrImm too many args} 2709 } 2710 -returnCodes error 2711 -match glob 2712 -result {wrong # args*} 2713} 2714test assemble-28.3 {dictIncrImm - bad subst} { 2715 -body { 2716 assemble {dictIncrImm 1 $foo} 2717 } 2718 -returnCodes error 2719 -match glob 2720 -result {assembly code may not contain substitutions} 2721} 2722test assemble-28.4 {dictIncrImm - not a number} { 2723 -body { 2724 proc x {} { 2725 assemble {dictIncrImm rubbish foo} 2726 } 2727 x 2728 } 2729 -returnCodes error 2730 -result {expected integer but got "rubbish"} 2731 -cleanup {rename x {}} 2732} 2733test assemble-28.5 {dictIncrImm - bad local} { 2734 -body { 2735 proc x {} { 2736 assemble {dictIncrImm 1 ::foo::bar} 2737 } 2738 list [catch x result] $result $::errorCode 2739 } 2740 -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} 2741 -cleanup {rename x {}; unset result} 2742} 2743test assemble-28.6 {dictIncrImm} { 2744 -body { 2745 proc x {} { 2746 set dict {a 1 b 2 c 3} 2747 assemble {push b; dictIncrImm 42 dict} 2748 } 2749 x 2750 } 2751 -result {a 1 b 44 c 3} 2752 -cleanup {rename x {}} 2753} 2754 2755# assemble-29 - ASSEM_REGEXP 2756 2757test assemble-29.1 {regexp - wrong # args} { 2758 -body { 2759 assemble {regexp} 2760 } 2761 -returnCodes error 2762 -match glob 2763 -result {wrong # args*} 2764} 2765test assemble-29.2 {regexp - wrong # args} { 2766 -body { 2767 assemble {regexp too many} 2768 } 2769 -returnCodes error 2770 -match glob 2771 -result {wrong # args*} 2772} 2773test assemble-29.3 {regexp - bad subst} { 2774 -body { 2775 assemble {regexp $foo} 2776 } 2777 -returnCodes error 2778 -match glob 2779 -result {assembly code may not contain substitutions} 2780} 2781test assemble-29.4 {regexp - not a boolean} { 2782 -body { 2783 proc x {} { 2784 assemble {regexp rubbish} 2785 } 2786 x 2787 } 2788 -returnCodes error 2789 -result {expected boolean value but got "rubbish"} 2790 -cleanup {rename x {}} 2791} 2792test assemble-29.5 {regexp} { 2793 -body { 2794 assemble {push br.*br; push abracadabra; regexp false} 2795 } 2796 -result 1 2797} 2798test assemble-29.6 {regexp} { 2799 -body { 2800 assemble {push br.*br; push aBRacadabra; regexp false} 2801 } 2802 -result 0 2803} 2804test assemble-29.7 {regexp} { 2805 -body { 2806 assemble {push br.*br; push aBRacadabra; regexp true} 2807 } 2808 -result 1 2809} 2810 2811# assemble-30 - Catches 2812 2813test assemble-30.1 {simplest possible catch} { 2814 -body { 2815 proc x {} { 2816 assemble { 2817 beginCatch @bad 2818 push error 2819 push testing 2820 invokeStk 2 2821 pop 2822 push 0 2823 jump @ok 2824 label @bad 2825 push 1; # should be pushReturnCode 2826 label @ok 2827 endCatch 2828 } 2829 } 2830 x 2831 } 2832 -result 1 2833 -cleanup {rename x {}} 2834} 2835test assemble-30.2 {catch in external catch conntext} { 2836 -body { 2837 proc x {} { 2838 list [catch { 2839 assemble { 2840 beginCatch @bad 2841 push error 2842 push testing 2843 invokeStk 2 2844 pop 2845 push 0 2846 jump @ok 2847 label @bad 2848 pushReturnCode 2849 label @ok 2850 endCatch 2851 } 2852 } result] $result 2853 } 2854 x 2855 } 2856 -result {0 1} 2857 -cleanup {rename x {}} 2858} 2859test assemble-30.3 {embedded catches} { 2860 -body { 2861 proc x {} { 2862 list [catch { 2863 assemble { 2864 beginCatch @bad 2865 push error 2866 eval { list [catch {error whatever} result] $result } 2867 invokeStk 2 2868 push 0 2869 reverse 2 2870 jump @done 2871 label @bad 2872 pushReturnCode 2873 pushResult 2874 label @done 2875 endCatch 2876 list 2 2877 } 2878 } result2] $result2 2879 } 2880 x 2881 } 2882 -result {0 {1 {1 whatever}}} 2883 -cleanup {rename x {}} 2884} 2885test assemble-30.4 {throw in wrong context} { 2886 -body { 2887 proc x {} { 2888 list [catch { 2889 assemble { 2890 beginCatch @bad 2891 push error 2892 eval { list [catch {error whatever} result] $result } 2893 invokeStk 2 2894 push 0 2895 reverse 2 2896 jump @done 2897 2898 label @bad 2899 load x 2900 pushResult 2901 2902 label @done 2903 endCatch 2904 list 2 2905 } 2906 } result] $result $::errorCode [split $::errorInfo \n] 2907 } 2908 x 2909 } 2910 -match glob 2911 -result {1 {"loadScalar1" instruction may not appear in a context where an exception has been caught and not disposed of.} {TCL ASSEM BADTHROW} {{"loadScalar1" instruction may not appear in a context where an exception has been caught and not disposed of.} { in assembly code between lines 10 and 15}*}} 2912 -cleanup {rename x {}} 2913} 2914test assemble-30.5 {unclosed catch} { 2915 -body { 2916 proc x {} { 2917 assemble { 2918 beginCatch @error 2919 push 0 2920 jump @done 2921 label @error 2922 push 1 2923 label @done 2924 push "" 2925 pop 2926 } 2927 } 2928 list [catch {x} result] $result $::errorCode $::errorInfo 2929 } 2930 -match glob 2931 -result {1 {catch still active on exit from assembly code} {TCL ASSEM UNCLOSEDCATCH} {catch still active on exit from assembly code 2932 ("assemble" body, line 2)*}} 2933 -cleanup {rename x {}} 2934} 2935test assemble-30.6 {inconsistent catch contexts} { 2936 -body { 2937 proc x {y} { 2938 assemble { 2939 load y 2940 jumpTrue @inblock 2941 beginCatch @error 2942 label @inblock 2943 push 0 2944 jump @done 2945 label @error 2946 push 1 2947 label @done 2948 } 2949 } 2950 list [catch {x 2} result] $::errorCode $::errorInfo 2951 } 2952 -match glob 2953 -result {1 {TCL ASSEM BADCATCH} {execution reaches an instruction in inconsistent exception contexts 2954 ("assemble" body, line 5)*}} 2955 -cleanup {rename x {}} 2956} 2957 2958# assemble-31 - Jump tables 2959 2960test assemble-31.1 {jumpTable, wrong # args} { 2961 -body { 2962 assemble {jumpTable} 2963 } 2964 -returnCodes error 2965 -match glob 2966 -result {wrong # args*} 2967} 2968test assemble-31.2 {jumpTable, wrong # args} { 2969 -body { 2970 assemble {jumpTable too many} 2971 } 2972 -returnCodes error 2973 -match glob 2974 -result {wrong # args*} 2975} 2976test assemble-31.3 {jumpTable - bad subst} { 2977 -body { 2978 assemble {jumpTable $foo} 2979 } 2980 -returnCodes error 2981 -match glob 2982 -result {assembly code may not contain substitutions} 2983} 2984test assemble-31.4 {jumptable - not a list} { 2985 -body { 2986 assemble {jumpTable \{rubbish} 2987 } 2988 -returnCodes error 2989 -result {unmatched open brace in list} 2990} 2991test assemble-31.5 {jumpTable, badly structured} { 2992 -body { 2993 list [catch {assemble { 2994 # line 2 2995 jumpTable {one two three};# line 3 2996 }} result] \ 2997 $result $::errorCode $::errorInfo 2998 } 2999 -match glob 3000 -result {1 {jump table must have an even number of list elements} {TCL ASSEM BADJUMPTABLE} {jump table must have an even number of list elements*("assemble" body, line 3)*}} 3001} 3002test assemble-31.6 {jumpTable, missing symbol} { 3003 -body { 3004 list [catch {assemble { 3005 # line 2 3006 jumpTable {1 a};# line 3 3007 }} result] \ 3008 $result $::errorCode $::errorInfo 3009 } 3010 -match glob 3011 -result {1 {undefined label "a"} {TCL ASSEM NOLABEL a} {undefined label "a"*("assemble" body, line 3)*}} 3012} 3013test assemble-31.7 {jumptable, actual example} { 3014 -setup { 3015 proc x {} { 3016 set result {} 3017 for {set i 0} {$i < 5} {incr i} { 3018 lappend result [assemble { 3019 load i 3020 jumpTable {1 @one 2 @two 3 @three} 3021 push {none of the above} 3022 jump @done 3023 label @one 3024 push one 3025 jump @done 3026 label @two 3027 push two 3028 jump @done 3029 label @three 3030 push three 3031 label @done 3032 }] 3033 } 3034 set tcl_traceCompile 2 3035 set result 3036 } 3037 } 3038 -body x 3039 -result {{none of the above} one two three {none of the above}} 3040 -cleanup {set tcl_traceCompile 0; rename x {}} 3041} 3042 3043test assemble-40.1 {unbalanced stack} { 3044 -body { 3045 list \ 3046 [catch { 3047 assemble { 3048 push 3 3049 dup 3050 mult 3051 push 4 3052 dup 3053 mult 3054 pop 3055 expon 3056 } 3057 } result] $result $::errorInfo 3058 } 3059 -result {1 {stack underflow} {stack underflow 3060 in assembly code between lines 1 and end of assembly code*}} 3061 -match glob 3062 -returnCodes ok 3063} 3064test assemble-40.2 {unbalanced stack} {*}{ 3065 -body { 3066 list \ 3067 [catch { 3068 assemble { 3069 label a 3070 push {} 3071 label b 3072 pop 3073 label c 3074 pop 3075 label d 3076 push {} 3077 } 3078 } result] $result $::errorInfo 3079 } 3080 -result {1 {stack underflow} {stack underflow 3081 in assembly code between lines 7 and 9*}} 3082 -match glob 3083 -returnCodes ok 3084} 3085 3086test assemble-41.1 {Inconsistent stack usage} {*}{ 3087 -body { 3088 proc x {y} { 3089 assemble { 3090 load y 3091 jumpFalse else 3092 push 0 3093 jump then 3094 label else 3095 push 1 3096 push 2 3097 label then 3098 pop 3099 } 3100 } 3101 catch {x 1} 3102 set errorInfo 3103 } 3104 -match glob 3105 -result {inconsistent stack depths on two execution paths 3106 ("assemble" body, line 10)*} 3107} 3108test assemble-41.2 {Inconsistent stack, jumptable and default} { 3109 -body { 3110 proc x {y} { 3111 assemble { 3112 load y 3113 jumpTable {0 else} 3114 push 0 3115 label else 3116 pop 3117 } 3118 } 3119 catch {x 1} 3120 set errorInfo 3121 } 3122 -match glob 3123 -result {inconsistent stack depths on two execution paths 3124 ("assemble" body, line 6)*} 3125} 3126test assemble-41.3 {Inconsistent stack, two legs of jumptable} { 3127 -body { 3128 proc x {y} { 3129 assemble { 3130 load y 3131 jumpTable {0 no 1 yes} 3132 label no 3133 push 0 3134 label yes 3135 pop 3136 } 3137 } 3138 catch {x 1} 3139 set errorInfo 3140 } 3141 -match glob 3142 -result {inconsistent stack depths on two execution paths 3143 ("assemble" body, line 7)*} 3144} 3145 3146test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} { 3147 -body { 3148 proc ulam {n} { 3149 assemble { 3150 load n; # max 3151 dup; # max n 3152 jump start; # max n 3153 3154 label loop; # max n 3155 over 1; # max n max 3156 over 1; # max in max n 3157 ge; # man n max>=n 3158 jumpTrue skip; # max n 3159 3160 reverse 2; # n max 3161 pop; # n 3162 dup; # n n 3163 3164 label skip; # max n 3165 dup; # max n n 3166 push 2; # max n n 2 3167 mod; # max n n%2 3168 jumpTrue odd; # max n 3169 3170 push 2; # max n 2 3171 div; # max n/2 -> max n 3172 jump start; # max n 3173 3174 label odd; # max n 3175 push 3; # max n 3 3176 mult; # max 3*n 3177 push 1; # max 3*n 1 3178 add; # max 3*n+1 3179 3180 label start; # max n 3181 dup; # max n n 3182 push 1; # max n n 1 3183 neq; # max n n>1 3184 jumpTrue loop; # max n 3185 3186 pop; # max 3187 } 3188 } 3189 set result {} 3190 for {set i 1} {$i < 30} {incr i} { 3191 lappend result [ulam $i] 3192 } 3193 set result 3194 } 3195 -result {1 2 16 4 16 16 52 8 52 16 52 16 40 52 160 16 52 52 88 20 64 52 160 24 88 40 9232 52 88} 3196} 3197 3198test assemble-51.1 {memory leak testing} memory { 3199 leaktest { 3200 apply {{} {assemble {push hello}}} 3201 } 3202} 0 3203test assemble-51.2 {memory leak testing} memory { 3204 leaktest { 3205 apply {{{x 0}} {assemble {incrImm x 1}}} 3206 } 3207} 0 3208test assemble-51.3 {memory leak testing} memory { 3209 leaktest { 3210 apply {{n} { 3211 assemble { 3212 load n; # max 3213 dup; # max n 3214 jump start; # max n 3215 3216 label loop; # max n 3217 over 1; # max n max 3218 over 1; # max in max n 3219 ge; # man n max>=n 3220 jumpTrue skip; # max n 3221 3222 reverse 2; # n max 3223 pop; # n 3224 dup; # n n 3225 3226 label skip; # max n 3227 dup; # max n n 3228 push 2; # max n n 2 3229 mod; # max n n%2 3230 jumpTrue odd; # max n 3231 3232 push 2; # max n 2 3233 div; # max n/2 -> max n 3234 jump start; # max n 3235 3236 label odd; # max n 3237 push 3; # max n 3 3238 mult; # max 3*n 3239 push 1; # max 3*n 1 3240 add; # max 3*n+1 3241 3242 label start; # max n 3243 dup; # max n n 3244 push 1; # max n n 1 3245 neq; # max n n>1 3246 jumpTrue loop; # max n 3247 3248 pop; # max 3249 } 3250 }} 1 3251 } 3252} 0 3253test assemble-51.4 {memory leak testing} memory { 3254 leaktest { 3255 catch { 3256 apply {{} { 3257 assemble {reverse polish notation} 3258 }} 3259 } 3260 } 3261} 0 3262 3263test assemble-52.1 {Bug 3154ea2759} { 3264 apply {{} { 3265 # Needs six exception ranges to force the range allocations to use the 3266 # malloced store. 3267 ::tcl::unsupported::assemble { 3268 beginCatch @badLabel 3269 push error 3270 push testing 3271 invokeStk 2 3272 pop 3273 push 0 3274 jump @okLabel 3275 label @badLabel 3276 push 1; # should be pushReturnCode 3277 label @okLabel 3278 endCatch 3279 pop 3280 3281 beginCatch @badLabel2 3282 push error 3283 push testing 3284 invokeStk 2 3285 pop 3286 push 0 3287 jump @okLabel2 3288 label @badLabel2 3289 push 1; # should be pushReturnCode 3290 label @okLabel2 3291 endCatch 3292 pop 3293 3294 beginCatch @badLabel3 3295 push error 3296 push testing 3297 invokeStk 2 3298 pop 3299 push 0 3300 jump @okLabel3 3301 label @badLabel3 3302 push 1; # should be pushReturnCode 3303 label @okLabel3 3304 endCatch 3305 pop 3306 3307 beginCatch @badLabel4 3308 push error 3309 push testing 3310 invokeStk 2 3311 pop 3312 push 0 3313 jump @okLabel4 3314 label @badLabel4 3315 push 1; # should be pushReturnCode 3316 label @okLabel4 3317 endCatch 3318 pop 3319 3320 beginCatch @badLabel5 3321 push error 3322 push testing 3323 invokeStk 2 3324 pop 3325 push 0 3326 jump @okLabel5 3327 label @badLabel5 3328 push 1; # should be pushReturnCode 3329 label @okLabel5 3330 endCatch 3331 pop 3332 3333 beginCatch @badLabel6 3334 push error 3335 push testing 3336 invokeStk 2 3337 pop 3338 push 0 3339 jump @okLabel6 3340 label @badLabel6 3341 push 1; # should be pushReturnCode 3342 label @okLabel6 3343 endCatch 3344 pop 3345 } 3346 }} 3347} {}; # must not crash 3348 3349rename fillTables {} 3350rename assemble {} 3351 3352::tcltest::cleanupTests 3353return 3354 3355# Local Variables: 3356# mode: tcl 3357# fill-column: 78 3358# End: 3359