1# assemble.test -- 2# 3# Test suite for the 'tcl::unsupported::assemble' command 4# 5# Copyright © 2010 Ozgur Dogan Ugurlu. 6# Copyright © 2010 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 assemble {load x} 856 } 857 } 858 -result {cannot use this instruction to create a variable in a non-proc context} 859 -errorCode {TCL ASSEM LVT} 860 -cleanup {namespace delete assem} 861} 862test assemble-8.6 {load1} { 863 -body { 864 proc x {a} { 865 assemble { 866 load a 867 } 868 } 869 x able 870 } 871 -result able 872 -cleanup {rename x {}} 873} 874test assemble-8.7 {load4} { 875 -body { 876 proc x {a} " 877 [fillTables] 878 set b \$a 879 assemble {load b} 880 " 881 x able 882 } 883 -result able 884 -cleanup {rename x {}} 885} 886test assemble-8.8 {loadArray1} { 887 -body { 888 proc x {} { 889 set able(baker) charlie 890 assemble { 891 push baker 892 loadArray able 893 } 894 } 895 x 896 } 897 -result charlie 898 -cleanup {rename x {}} 899} 900test assemble-8.9 {loadArray4} { 901 -body " 902 proc x {} { 903 [fillTables] 904 set able(baker) charlie 905 assemble { 906 push baker 907 loadArray able 908 } 909 } 910 x 911 " 912 -result charlie 913 -cleanup {rename x {}} 914} 915test assemble-8.10 {append1} { 916 -body { 917 proc x {} { 918 set y {hello, } 919 assemble { 920 push world; append y 921 } 922 } 923 x 924 } 925 -result {hello, world} 926 -cleanup {rename x {}} 927} 928test assemble-8.11 {append4} { 929 -body { 930 proc x {} " 931 [fillTables] 932 set y {hello, } 933 assemble { 934 push world; append y 935 } 936 " 937 x 938 } 939 -result {hello, world} 940 -cleanup {rename x {}} 941} 942test assemble-8.12 {appendArray1} { 943 -body { 944 proc x {} { 945 set y(z) {hello, } 946 assemble { 947 push z; push world; appendArray y 948 } 949 } 950 x 951 } 952 -result {hello, world} 953 -cleanup {rename x {}} 954} 955test assemble-8.13 {appendArray4} { 956 -body { 957 proc x {} " 958 [fillTables] 959 set y(z) {hello, } 960 assemble { 961 push z; push world; appendArray y 962 } 963 " 964 x 965 } 966 -result {hello, world} 967 -cleanup {rename x {}} 968} 969test assemble-8.14 {lappend1} { 970 -body { 971 proc x {} { 972 set y {hello,} 973 assemble { 974 push world; lappend y 975 } 976 } 977 x 978 } 979 -result {hello, world} 980 -cleanup {rename x {}} 981} 982test assemble-8.15 {lappend4} { 983 -body { 984 proc x {} " 985 [fillTables] 986 set y {hello,} 987 assemble { 988 push world; lappend y 989 } 990 " 991 x 992 } 993 -result {hello, world} 994 -cleanup {rename x {}} 995} 996test assemble-8.16 {lappendArray1} { 997 -body { 998 proc x {} { 999 set y(z) {hello,} 1000 assemble { 1001 push z; push world; lappendArray y 1002 } 1003 } 1004 x 1005 } 1006 -result {hello, world} 1007 -cleanup {rename x {}} 1008} 1009test assemble-8.17 {lappendArray4} { 1010 -body { 1011 proc x {} " 1012 [fillTables] 1013 set y(z) {hello,} 1014 assemble { 1015 push z; push world; lappendArray y 1016 } 1017 " 1018 x 1019 } 1020 -result {hello, world} 1021 -cleanup {rename x {}} 1022} 1023test assemble-8.18 {store1} { 1024 -body { 1025 proc x {} { 1026 assemble { 1027 push test; store y 1028 } 1029 set y 1030 } 1031 x 1032 } 1033 -result {test} 1034 -cleanup {rename x {}} 1035} 1036test assemble-8.19 {store4} { 1037 -body { 1038 proc x {} " 1039 [fillTables] 1040 assemble { 1041 push test; store y 1042 } 1043 set y 1044 " 1045 x 1046 } 1047 -result test 1048 -cleanup {rename x {}} 1049} 1050test assemble-8.20 {storeArray1} { 1051 -body { 1052 proc x {} { 1053 assemble { 1054 push z; push test; storeArray y 1055 } 1056 set y(z) 1057 } 1058 x 1059 } 1060 -result test 1061 -cleanup {rename x {}} 1062} 1063test assemble-8.21 {storeArray4} { 1064 -body { 1065 proc x {} " 1066 [fillTables] 1067 assemble { 1068 push z; push test; storeArray y 1069 } 1070 " 1071 x 1072 } 1073 -result test 1074 -cleanup {rename x {}} 1075} 1076 1077# assemble-9 - ASSEM_CONCAT1, GetIntegerOperand, CheckOneByte 1078 1079test assemble-9.1 {wrong # args} { 1080 -body {assemble concat} 1081 -result {wrong # args*} 1082 -match glob 1083 -returnCodes error 1084} 1085test assemble-9.2 {wrong # args} { 1086 -body {assemble {concat too many}} 1087 -result {wrong # args*} 1088 -match glob 1089 -returnCodes error 1090} 1091test assemble-9.3 {not a number} { 1092 -body {assemble {concat rubbish}} 1093 -result {expected integer but got "rubbish"} 1094 -returnCodes error 1095} 1096test assemble-9.4 {too small} { 1097 -body {assemble {concat -1}} 1098 -result {operand does not fit in one byte} 1099 -returnCodes error 1100} 1101test assemble-9.5 {too small} { 1102 -body {assemble {concat 256}} 1103 -result {operand does not fit in one byte} 1104 -returnCodes error 1105} 1106test assemble-9.6 {concat} { 1107 -body { 1108 assemble {push h; push e; push l; push l; push o; concat 5} 1109 } 1110 -result hello 1111} 1112test assemble-9.7 {concat} { 1113 -body { 1114 assemble {concat 0} 1115 } 1116 -result {operand must be positive} 1117 -errorCode {TCL ASSEM POSITIVE} 1118} 1119 1120# assemble-10 -- eval and expr 1121 1122test assemble-10.1 {eval - wrong # args} { 1123 -body { 1124 assemble {eval} 1125 } 1126 -returnCodes error 1127 -match glob 1128 -result {wrong # args*} 1129} 1130test assemble-10.2 {eval - wrong # args} { 1131 -body { 1132 assemble {eval too many} 1133 } 1134 -returnCodes error 1135 -match glob 1136 -result {wrong # args*} 1137} 1138test assemble-10.3 {eval} { 1139 -body { 1140 proc x {} { 1141 assemble { 1142 push 3 1143 store n 1144 pop 1145 eval {expr {3*$n + 1}} 1146 push 1 1147 add 1148 } 1149 } 1150 x 1151 } 1152 -result 11 1153 -cleanup {rename x {}} 1154} 1155test assemble-10.4 {expr} { 1156 -body { 1157 proc x {} { 1158 assemble { 1159 push 3 1160 store n 1161 pop 1162 expr {3*$n + 1} 1163 push 1 1164 add 1165 } 1166 } 1167 x 1168 } 1169 -result 11 1170 -cleanup {rename x {}} 1171} 1172test assemble-10.5 {eval and expr - nonsimple} { 1173 -body { 1174 proc x {} { 1175 assemble { 1176 eval "s\x65t n 3" 1177 pop 1178 expr "\x33*\$n + 1" 1179 push 1 1180 add 1181 } 1182 } 1183 x 1184 } 1185 -result 11 1186 -cleanup { 1187 rename x {} 1188 } 1189} 1190test assemble-10.6 {eval - noncompilable} { 1191 -body { 1192 list [catch {assemble {eval $x}} result] $result $::errorCode 1193 } 1194 -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} 1195} 1196test assemble-10.7 {expr - noncompilable} { 1197 -body { 1198 list [catch {assemble {expr $x}} result] $result $::errorCode 1199 } 1200 -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} 1201} 1202 1203# assemble-11 - ASSEM_LVT4 (exist, existArray, dictAppend, dictLappend, 1204# nsupvar, variable, upvar) 1205 1206test assemble-11.1 {exist - wrong # args} { 1207 -body { 1208 assemble {exist} 1209 } 1210 -returnCodes error 1211 -match glob 1212 -result {wrong # args*} 1213} 1214test assemble-11.2 {exist - wrong # args} { 1215 -body { 1216 assemble {exist too many} 1217 } 1218 -returnCodes error 1219 -match glob 1220 -result {wrong # args*} 1221} 1222test assemble-11.3 {nonlocal var} { 1223 -body { 1224 list [catch {assemble {exist ::env}} result] $result $errorCode 1225 } 1226 -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} 1227 -cleanup {unset result} 1228} 1229test assemble-11.4 {exist} { 1230 -body { 1231 proc x {} { 1232 set y z 1233 list [assemble {exist y}] \ 1234 [assemble {exist z}] 1235 } 1236 x 1237 } 1238 -result {1 0} 1239 -cleanup {rename x {}} 1240} 1241test assemble-11.5 {existArray} { 1242 -body { 1243 proc x {} { 1244 set a(b) c 1245 list [assemble {push b; existArray a}] \ 1246 [assemble {push c; existArray a}] \ 1247 [assemble {push a; existArray b}] 1248 } 1249 x 1250 } 1251 -result {1 0 0} 1252 -cleanup {rename x {}} 1253} 1254test assemble-11.6 {dictAppend} { 1255 -body { 1256 proc x {} { 1257 set dict {a 1 b 2 c 3} 1258 assemble {push b; push 22; dictAppend dict} 1259 } 1260 x 1261 } 1262 -result {a 1 b 222 c 3} 1263 -cleanup {rename x {}} 1264} 1265test assemble-11.7 {dictLappend} { 1266 -body { 1267 proc x {} { 1268 set dict {a 1 b 2 c 3} 1269 assemble {push b; push 2; dictLappend dict} 1270 } 1271 x 1272 } 1273 -result {a 1 b {2 2} c 3} 1274 -cleanup {rename x {}} 1275} 1276test assemble-11.8 {upvar} { 1277 -body { 1278 proc x {v} { 1279 assemble {push 1; load v; upvar w; pop; load w} 1280 } 1281 proc y {} { 1282 set z 123 1283 x z 1284 } 1285 y 1286 } 1287 -result 123 1288 -cleanup {rename x {}; rename y {}} 1289} 1290test assemble-11.9 {nsupvar} { 1291 -body { 1292 namespace eval q { variable v 123 } 1293 proc x {} { 1294 assemble {push q; push v; nsupvar y; pop; load y} 1295 } 1296 x 1297 } 1298 -result 123 1299 -cleanup {namespace delete q; rename x {}} 1300} 1301test assemble-11.10 {variable} { 1302 -body { 1303 namespace eval q { namespace eval r {variable v 123}} 1304 proc x {} { 1305 assemble {push q::r::v; variable y; load y} 1306 } 1307 x 1308 } 1309 -result 123 1310 -cleanup {namespace delete q; rename x {}} 1311} 1312 1313# assemble-12 - ASSEM_LVT1 (incr and incrArray) 1314 1315test assemble-12.1 {incr - wrong # args} { 1316 -body { 1317 assemble {incr} 1318 } 1319 -returnCodes error 1320 -match glob 1321 -result {wrong # args*} 1322} 1323test assemble-12.2 {incr - wrong # args} { 1324 -body { 1325 assemble {incr too many} 1326 } 1327 -returnCodes error 1328 -match glob 1329 -result {wrong # args*} 1330} 1331test assemble-12.3 {incr nonlocal var} { 1332 -body { 1333 list [catch {assemble {incr ::env}} result] $result $errorCode 1334 } 1335 -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} 1336 -cleanup {unset result} 1337} 1338test assemble-12.4 {incr} { 1339 -body { 1340 proc x {} { 1341 set y 5 1342 assemble {push 3; incr y} 1343 } 1344 x 1345 } 1346 -result 8 1347 -cleanup {rename x {}} 1348} 1349test assemble-12.5 {incrArray} { 1350 -body { 1351 proc x {} { 1352 set a(b) 5 1353 assemble {push b; push 3; incrArray a} 1354 } 1355 x 1356 } 1357 -result 8 1358 -cleanup {rename x {}} 1359} 1360test assemble-12.6 {incr, stupid stack restriction} { 1361 -body { 1362 proc x {} " 1363 [fillTables] 1364 set y 5 1365 assemble {push 3; incr y} 1366 " 1367 list [catch {x} result] $result $errorCode 1368 } 1369 -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} 1370 -cleanup {unset result; rename x {}} 1371} 1372 1373# assemble-13 -- ASSEM_LVT1_SINT1 - incrImm and incrArrayImm 1374 1375test assemble-13.1 {incrImm - wrong # args} { 1376 -body { 1377 assemble {incrImm x} 1378 } 1379 -returnCodes error 1380 -match glob 1381 -result {wrong # args*} 1382} 1383test assemble-13.2 {incrImm - wrong # args} { 1384 -body { 1385 assemble {incrImm too many args} 1386 } 1387 -returnCodes error 1388 -match glob 1389 -result {wrong # args*} 1390} 1391test assemble-13.3 {incrImm nonlocal var} { 1392 -body { 1393 list [catch {assemble {incrImm ::env 2}} result] $result $errorCode 1394 } 1395 -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} 1396 -cleanup {unset result} 1397} 1398test assemble-13.4 {incrImm not a number} { 1399 -body { 1400 proc x {} { 1401 assemble {incrImm x rubbish} 1402 } 1403 x 1404 } 1405 -returnCodes error 1406 -result {expected integer but got "rubbish"} 1407 -cleanup {rename x {}} 1408} 1409test assemble-13.5 {incrImm too big} { 1410 -body { 1411 proc x {} { 1412 assemble {incrImm x 0x80} 1413 } 1414 list [catch x result] $result $::errorCode 1415 } 1416 -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} 1417 -cleanup {rename x {}; unset result} 1418} 1419test assemble-13.6 {incrImm too small} { 1420 -body { 1421 proc x {} { 1422 assemble {incrImm x -0x81} 1423 } 1424 list [catch x result] $result $::errorCode 1425 } 1426 -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} 1427 -cleanup {rename x {}; unset result} 1428} 1429test assemble-13.7 {incrImm} { 1430 -body { 1431 proc x {} { 1432 set y 1 1433 list [assemble {incrImm y -0x80}] [assemble {incrImm y 0x7f}] 1434 } 1435 x 1436 } 1437 -result {-127 0} 1438 -cleanup {rename x {}} 1439} 1440test assemble-13.8 {incrArrayImm} { 1441 -body { 1442 proc x {} { 1443 set a(b) 5 1444 assemble {push b; incrArrayImm a 3} 1445 } 1446 x 1447 } 1448 -result 8 1449 -cleanup {rename x {}} 1450} 1451test assemble-13.9 {incrImm, stupid stack restriction} { 1452 -body { 1453 proc x {} " 1454 [fillTables] 1455 set y 5 1456 assemble {incrImm y 3} 1457 " 1458 list [catch {x} result] $result $errorCode 1459 } 1460 -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} 1461 -cleanup {unset result; rename x {}} 1462} 1463 1464# assemble-14 -- ASSEM_SINT1 (incrArrayStkImm and incrStkImm) 1465 1466test assemble-14.1 {incrStkImm - wrong # args} { 1467 -body { 1468 assemble {incrStkImm} 1469 } 1470 -returnCodes error 1471 -match glob 1472 -result {wrong # args*} 1473} 1474test assemble-14.2 {incrStkImm - wrong # args} { 1475 -body { 1476 assemble {incrStkImm too many} 1477 } 1478 -returnCodes error 1479 -match glob 1480 -result {wrong # args*} 1481} 1482test assemble-14.3 {incrStkImm not a number} { 1483 -body { 1484 proc x {} { 1485 assemble {incrStkImm rubbish} 1486 } 1487 x 1488 } 1489 -returnCodes error 1490 -result {expected integer but got "rubbish"} 1491 -cleanup {rename x {}} 1492} 1493test assemble-14.4 {incrStkImm too big} { 1494 -body { 1495 proc x {} { 1496 assemble {incrStkImm 0x80} 1497 } 1498 list [catch x result] $result $::errorCode 1499 } 1500 -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} 1501 -cleanup {rename x {}; unset result} 1502} 1503test assemble-14.5 {incrStkImm too small} { 1504 -body { 1505 proc x {} { 1506 assemble {incrStkImm -0x81} 1507 } 1508 list [catch x result] $result $::errorCode 1509 } 1510 -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} 1511 -cleanup {rename x {}; unset result} 1512} 1513test assemble-14.6 {incrStkImm} { 1514 -body { 1515 proc x {} { 1516 set y 1 1517 list [assemble {push y; incrStkImm -0x80}] \ 1518 [assemble {push y; incrStkImm 0x7f}] 1519 } 1520 x 1521 } 1522 -result {-127 0} 1523 -cleanup {rename x {}} 1524} 1525test assemble-14.7 {incrArrayStkImm} { 1526 -body { 1527 proc x {} { 1528 set a(b) 5 1529 assemble {push a; push b; incrArrayStkImm 3} 1530 } 1531 x 1532 } 1533 -result 8 1534 -cleanup {rename x {}} 1535} 1536 1537# assemble-15 - listIndexImm 1538 1539test assemble-15.1 {listIndexImm - wrong # args} -body { 1540 assemble {listIndexImm} 1541} -returnCodes error -match glob -result {wrong # args*} 1542test assemble-15.2 {listIndexImm - wrong # args} -body { 1543 assemble {listIndexImm too many} 1544} -returnCodes error -match glob -result {wrong # args*} 1545test assemble-15.3 {listIndexImm - bad substitution} -body { 1546 list [catch {assemble {listIndexImm $foo}} result] $result $::errorCode 1547} -cleanup { 1548 unset result 1549} -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} 1550test assemble-15.4 {listIndexImm - invalid index} -body { 1551 assemble {listIndexImm rubbish} 1552} -returnCodes error -match glob -result {bad index "rubbish"*} 1553test assemble-15.5 {listIndexImm} -body { 1554 assemble {push {a b c}; listIndexImm 2} 1555} -result c 1556test assemble-15.6 {listIndexImm} -body { 1557 assemble {push {a b c}; listIndexImm end-1} 1558} -result b 1559test assemble-15.7 {listIndexImm} -body { 1560 assemble {push {a b c}; listIndexImm end} 1561} -result c 1562test assemble-15.8 {listIndexImm} -body { 1563 assemble {push {a b c}; listIndexImm end+2} 1564} -result {} 1565test assemble-15.9 {listIndexImm} -body { 1566 assemble {push {a b c}; listIndexImm -1-1} 1567} -result {} 1568 1569# assemble-16 - invokeStk 1570 1571test assemble-16.1 {invokeStk - wrong # args} { 1572 -body { 1573 assemble {invokeStk} 1574 } 1575 -returnCodes error 1576 -match glob 1577 -result {wrong # args*} 1578} 1579test assemble-16.2 {invokeStk - wrong # args} { 1580 -body { 1581 assemble {invokeStk too many} 1582 } 1583 -returnCodes error 1584 -match glob 1585 -result {wrong # args*} 1586} 1587test assemble-16.3 {invokeStk - not a number} { 1588 -body { 1589 proc x {} { 1590 assemble {invokeStk rubbish} 1591 } 1592 x 1593 } 1594 -returnCodes error 1595 -result {expected integer but got "rubbish"} 1596 -cleanup {rename x {}} 1597} 1598test assemble-16.4 {invokeStk - no operands} { 1599 -body { 1600 proc x {} { 1601 assemble {invokeStk 0} 1602 } 1603 list [catch x result] $result $::errorCode 1604 } 1605 -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} 1606 -cleanup {rename x {}; unset result} 1607} 1608test assemble-16.5 {invokeStk1} { 1609 -body { 1610 tcl::unsupported::assemble {push concat; push 1; push 2; invokeStk 3} 1611 } 1612 -result {1 2} 1613} 1614test assemble-16.6 {invokeStk4} { 1615 -body { 1616 proc x {n} { 1617 set code {push concat} 1618 set shouldbe {} 1619 for {set i 1} {$i < $n} {incr i} { 1620 append code \n {push a} $i 1621 lappend shouldbe a$i 1622 } 1623 append code \n {invokeStk} { } $n 1624 set is [assemble $code] 1625 expr {$is eq $shouldbe} 1626 } 1627 list [x 254] [x 255] [x 256] [x 257] 1628 } 1629 -result {1 1 1 1} 1630 -cleanup {rename x {}} 1631} 1632 1633# assemble-17 -- jumps and labels 1634 1635test assemble-17.1 {label, wrong # args} { 1636 -body { 1637 assemble {label} 1638 } 1639 -returnCodes error 1640 -match glob 1641 -result {wrong # args*} 1642} 1643test assemble-17.2 {label, wrong # args} { 1644 -body { 1645 assemble {label too many} 1646 } 1647 -returnCodes error 1648 -match glob 1649 -result {wrong # args*} 1650} 1651test assemble-17.3 {label, bad subst} { 1652 -body { 1653 list [catch {assemble {label $foo}} result] $result $::errorCode 1654 } 1655 -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} 1656 -cleanup {unset result} 1657} 1658test assemble-17.4 {duplicate label} { 1659 -body { 1660 list [catch {assemble {label foo; label foo}} result] \ 1661 $result $::errorCode 1662 } 1663 -result {1 {duplicate definition of label "foo"} {TCL ASSEM DUPLABEL foo}} 1664} 1665test assemble-17.5 {jump, wrong # args} { 1666 -body { 1667 assemble {jump} 1668 } 1669 -returnCodes error 1670 -match glob 1671 -result {wrong # args*} 1672} 1673test assemble-17.6 {jump, wrong # args} { 1674 -body { 1675 assemble {jump too many} 1676 } 1677 -returnCodes error 1678 -match glob 1679 -result {wrong # args*} 1680} 1681test assemble-17.7 {jump, bad subst} { 1682 -body { 1683 list [catch {assemble {jump $foo}} result] $result $::errorCode 1684 } 1685 -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} 1686 -cleanup {unset result} 1687} 1688test assemble-17.8 {jump - ahead and back} { 1689 -body { 1690 assemble { 1691 jump three 1692 1693 label one 1694 push a 1695 jump four 1696 1697 label two 1698 push b 1699 jump six 1700 1701 label three 1702 push c 1703 jump five 1704 1705 label four 1706 push d 1707 jump two 1708 1709 label five 1710 push e 1711 jump one 1712 1713 label six 1714 push f 1715 concat 6 1716 } 1717 } 1718 -result ceadbf 1719} 1720test assemble-17.9 {jump - resolve a label multiple times} { 1721 -body { 1722 proc x {} { 1723 set case 0 1724 set result {} 1725 assemble { 1726 jump common 1727 1728 label zero 1729 pop 1730 incrImm case 1 1731 pop 1732 push a 1733 append result 1734 pop 1735 jump common 1736 1737 label one 1738 pop 1739 incrImm case 1 1740 pop 1741 push b 1742 append result 1743 pop 1744 jump common 1745 1746 label common 1747 load case 1748 dup 1749 push 0 1750 eq 1751 jumpTrue zero 1752 dup 1753 push 1 1754 eq 1755 jumpTrue one 1756 dup 1757 push 2 1758 eq 1759 jumpTrue two 1760 dup 1761 push 3 1762 eq 1763 jumpTrue three 1764 1765 label two 1766 pop 1767 incrImm case 1 1768 pop 1769 push c 1770 append result 1771 pop 1772 jump common 1773 1774 label three 1775 pop 1776 incrImm case 1 1777 pop 1778 push d 1779 append result 1780 } 1781 } 1782 x 1783 } 1784 -result abcd 1785 -cleanup {rename x {}} 1786} 1787test assemble-17.10 {jump4 needed} { 1788 -body { 1789 assemble "push x; jump one; label two; [string repeat {dup; pop;} 128] 1790 jump three; label one; jump two; label three" 1791 } 1792 -result x 1793} 1794test assemble-17.11 {jumpTrue} { 1795 -body { 1796 proc x {y} { 1797 assemble { 1798 load y 1799 jumpTrue then 1800 push no 1801 jump else 1802 label then 1803 push yes 1804 label else 1805 } 1806 } 1807 list [x 0] [x 1] 1808 } 1809 -result {no yes} 1810 -cleanup {rename x {}} 1811} 1812test assemble-17.12 {jumpFalse} { 1813 -body { 1814 proc x {y} { 1815 assemble { 1816 load y 1817 jumpFalse then 1818 push no 1819 jump else 1820 label then 1821 push yes 1822 label else 1823 } 1824 } 1825 list [x 0] [x 1] 1826 } 1827 -result {yes no} 1828 -cleanup {rename x {}} 1829} 1830test assemble-17.13 {jump to undefined label} { 1831 -body { 1832 list [catch {assemble {jump nowhere}} result] $result $::errorCode 1833 } 1834 -result {1 {undefined label "nowhere"} {TCL ASSEM NOLABEL nowhere}} 1835} 1836test assemble-17.14 {jump to undefined label, line number correct?} { 1837 -body { 1838 catch {assemble {#1 1839 #2 1840 #3 1841 jump nowhere 1842 #5 1843 #6 1844 }} 1845 set ::errorInfo 1846 } 1847 -match glob 1848 -result {*"assemble" body, line 4*} 1849} 1850test assemble-17.15 {multiple passes of code resizing} { 1851 -setup { 1852 set body { 1853 push - 1854 } 1855 for {set i 0} {$i < 14} {incr i} { 1856 append body "label a" $i \ 1857 "; push a; concat 2; nop; nop; jump b" \ 1858 $i \n 1859 } 1860 append body {label a14; push a; concat 2; push 1; jumpTrue b14} \n 1861 append body {label a15; push a; concat 2; push 0; jumpFalse b15} \n 1862 for {set i 0} {$i < 15} {incr i} { 1863 append body "label b" $i \ 1864 "; push b; concat 2; nop; nop; jump a" \ 1865 [expr {$i+1}] \n 1866 } 1867 append body {label c; push -; concat 2; nop; nop; nop; jump d} \n 1868 append body {label b15; push b; concat 2; nop; nop; jump c} \n 1869 append body {label d} 1870 proc x {} [list assemble $body] 1871 } 1872 -body { 1873 x 1874 } 1875 -cleanup { 1876 catch {unset body} 1877 catch {rename x {}} 1878 } 1879 -result -abababababababababababababababab- 1880} 1881 1882# assemble-18 - lindexMulti 1883 1884test assemble-18.1 {lindexMulti - wrong # args} { 1885 -body { 1886 assemble {lindexMulti} 1887 } 1888 -returnCodes error 1889 -match glob 1890 -result {wrong # args*} 1891} 1892test assemble-18.2 {lindexMulti - wrong # args} { 1893 -body { 1894 assemble {lindexMulti too many} 1895 } 1896 -returnCodes error 1897 -match glob 1898 -result {wrong # args*} 1899} 1900test assemble-18.3 {lindexMulti - bad subst} { 1901 -body { 1902 assemble {lindexMulti $foo} 1903 } 1904 -returnCodes error 1905 -match glob 1906 -result {assembly code may not contain substitutions} 1907} 1908test assemble-18.4 {lindexMulti - not a number} { 1909 -body { 1910 proc x {} { 1911 assemble {lindexMulti rubbish} 1912 } 1913 x 1914 } 1915 -returnCodes error 1916 -result {expected integer but got "rubbish"} 1917 -cleanup {rename x {}} 1918} 1919test assemble-18.5 {lindexMulti - bad operand count} { 1920 -body { 1921 proc x {} { 1922 assemble {lindexMulti 0} 1923 } 1924 list [catch x result] $result $::errorCode 1925 } 1926 -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} 1927 -cleanup {rename x {}; unset result} 1928} 1929test assemble-18.6 {lindexMulti} { 1930 -body { 1931 assemble {push {{a b c} {d e f} {g h j}}; lindexMulti 1} 1932 } 1933 -result {{a b c} {d e f} {g h j}} 1934} 1935test assemble-18.7 {lindexMulti} { 1936 -body { 1937 assemble {push {{a b c} {d e f} {g h j}}; push 1; lindexMulti 2} 1938 } 1939 -result {d e f} 1940} 1941test assemble-18.8 {lindexMulti} { 1942 -body { 1943 assemble {push {{a b c} {d e f} {g h j}}; push 2; push 1; lindexMulti 3} 1944 } 1945 -result h 1946} 1947 1948# assemble-19 - list 1949 1950test assemble-19.1 {list - wrong # args} { 1951 -body { 1952 assemble {list} 1953 } 1954 -returnCodes error 1955 -match glob 1956 -result {wrong # args*} 1957} 1958test assemble-19.2 {list - wrong # args} { 1959 -body { 1960 assemble {list too many} 1961 } 1962 -returnCodes error 1963 -match glob 1964 -result {wrong # args*} 1965} 1966test assemble-19.3 {list - bad subst} { 1967 -body { 1968 assemble {list $foo} 1969 } 1970 -returnCodes error 1971 -match glob 1972 -result {assembly code may not contain substitutions} 1973} 1974test assemble-19.4 {list - not a number} { 1975 -body { 1976 proc x {} { 1977 assemble {list rubbish} 1978 } 1979 x 1980 } 1981 -returnCodes error 1982 -result {expected integer but got "rubbish"} 1983 -cleanup {rename x {}} 1984} 1985test assemble-19.5 {list - negative operand count} { 1986 -body { 1987 proc x {} { 1988 assemble {list -1} 1989 } 1990 list [catch x result] $result $::errorCode 1991 } 1992 -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} 1993 -cleanup {rename x {}; unset result} 1994} 1995test assemble-19.6 {list - no args} { 1996 -body { 1997 assemble {list 0} 1998 } 1999 -result {} 2000} 2001test assemble-19.7 {list - 1 arg} { 2002 -body { 2003 assemble {push hello; list 1} 2004 } 2005 -result hello 2006} 2007test assemble-19.8 {list - 2 args} { 2008 -body { 2009 assemble {push hello; push world; list 2} 2010 } 2011 -result {hello world} 2012} 2013 2014# assemble-20 - lsetFlat 2015 2016test assemble-20.1 {lsetFlat - wrong # args} { 2017 -body { 2018 assemble {lsetFlat} 2019 } 2020 -returnCodes error 2021 -match glob 2022 -result {wrong # args*} 2023} 2024test assemble-20.2 {lsetFlat - wrong # args} { 2025 -body { 2026 assemble {lsetFlat too many} 2027 } 2028 -returnCodes error 2029 -match glob 2030 -result {wrong # args*} 2031} 2032test assemble-20.3 {lsetFlat - bad subst} { 2033 -body { 2034 assemble {lsetFlat $foo} 2035 } 2036 -returnCodes error 2037 -match glob 2038 -result {assembly code may not contain substitutions} 2039} 2040test assemble-20.4 {lsetFlat - not a number} { 2041 -body { 2042 proc x {} { 2043 assemble {lsetFlat rubbish} 2044 } 2045 x 2046 } 2047 -returnCodes error 2048 -result {expected integer but got "rubbish"} 2049 -cleanup {rename x {}} 2050} 2051test assemble-20.5 {lsetFlat - negative operand count} { 2052 -body { 2053 proc x {} { 2054 assemble {lsetFlat 1} 2055 } 2056 list [catch x result] $result $::errorCode 2057 } 2058 -result {1 {operand must be >=2} {TCL ASSEM OPERAND>=2}} 2059 -cleanup {rename x {}; unset result} 2060} 2061test assemble-20.6 {lsetFlat} { 2062 -body { 2063 assemble {push b; push a; lsetFlat 2} 2064 } 2065 -result b 2066} 2067test assemble-20.7 {lsetFlat} { 2068 -body { 2069 assemble {push 1; push d; push {a b c}; lsetFlat 3} 2070 } 2071 -result {a d c} 2072} 2073 2074# assemble-21 - over 2075 2076test assemble-21.1 {over - wrong # args} { 2077 -body { 2078 assemble {over} 2079 } 2080 -returnCodes error 2081 -match glob 2082 -result {wrong # args*} 2083} 2084test assemble-21.2 {over - wrong # args} { 2085 -body { 2086 assemble {over too many} 2087 } 2088 -returnCodes error 2089 -match glob 2090 -result {wrong # args*} 2091} 2092test assemble-21.3 {over - bad subst} { 2093 -body { 2094 assemble {over $foo} 2095 } 2096 -returnCodes error 2097 -match glob 2098 -result {assembly code may not contain substitutions} 2099} 2100test assemble-21.4 {over - not a number} { 2101 -body { 2102 proc x {} { 2103 assemble {over rubbish} 2104 } 2105 x 2106 } 2107 -returnCodes error 2108 -result {expected integer but got "rubbish"} 2109 -cleanup {rename x {}} 2110} 2111test assemble-21.5 {over - negative operand count} { 2112 -body { 2113 proc x {} { 2114 assemble {over -1} 2115 } 2116 list [catch x result] $result $::errorCode 2117 } 2118 -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} 2119 -cleanup {rename x {}; unset result} 2120} 2121test assemble-21.6 {over} { 2122 -body { 2123 proc x {} { 2124 assemble { 2125 push 1 2126 push 2 2127 push 3 2128 over 0 2129 store x 2130 pop 2131 pop 2132 pop 2133 pop 2134 load x 2135 } 2136 } 2137 x 2138 } 2139 -result 3 2140 -cleanup {rename x {}} 2141} 2142test assemble-21.7 {over} { 2143 -body { 2144 proc x {} { 2145 assemble { 2146 push 1 2147 push 2 2148 push 3 2149 over 2 2150 store x 2151 pop 2152 pop 2153 pop 2154 pop 2155 load x 2156 } 2157 } 2158 x 2159 } 2160 -result 1 2161 -cleanup {rename x {}} 2162} 2163 2164# assemble-22 - reverse 2165 2166test assemble-22.1 {reverse - wrong # args} { 2167 -body { 2168 assemble {reverse} 2169 } 2170 -returnCodes error 2171 -match glob 2172 -result {wrong # args*} 2173} 2174test assemble-22.2 {reverse - wrong # args} { 2175 -body { 2176 assemble {reverse too many} 2177 } 2178 -returnCodes error 2179 -match glob 2180 -result {wrong # args*} 2181} 2182 2183test assemble-22.3 {reverse - bad subst} { 2184 -body { 2185 assemble {reverse $foo} 2186 } 2187 -returnCodes error 2188 -match glob 2189 -result {assembly code may not contain substitutions} 2190} 2191 2192test assemble-22.4 {reverse - not a number} { 2193 -body { 2194 proc x {} { 2195 assemble {reverse rubbish} 2196 } 2197 x 2198 } 2199 -returnCodes error 2200 -result {expected integer but got "rubbish"} 2201 -cleanup {rename x {}} 2202} 2203test assemble-22.5 {reverse - negative operand count} { 2204 -body { 2205 proc x {} { 2206 assemble {reverse -1} 2207 } 2208 list [catch x result] $result $::errorCode 2209 } 2210 -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} 2211 -cleanup {rename x {}; unset result} 2212} 2213test assemble-22.6 {reverse - zero operand count} { 2214 -body { 2215 proc x {} { 2216 assemble {push 1; reverse 0} 2217 } 2218 x 2219 } 2220 -result 1 2221 -cleanup {rename x {}} 2222} 2223test assemble-22.7 {reverse} { 2224 -body { 2225 proc x {} { 2226 assemble { 2227 push 1 2228 push 2 2229 push 3 2230 reverse 1 2231 store x 2232 pop 2233 pop 2234 pop 2235 load x 2236 } 2237 } 2238 x 2239 } 2240 -result 3 2241 -cleanup {rename x {}} 2242} 2243test assemble-22.8 {reverse} { 2244 -body { 2245 proc x {} { 2246 assemble { 2247 push 1 2248 push 2 2249 push 3 2250 reverse 3 2251 store x 2252 pop 2253 pop 2254 pop 2255 load x 2256 } 2257 } 2258 x 2259 } 2260 -result 1 2261 -cleanup {rename x {}} 2262} 2263 2264# assemble-23 - ASSEM_BOOL (strmatch, unsetStk, unsetArrayStk) 2265 2266test assemble-23.1 {strmatch - wrong # args} { 2267 -body { 2268 assemble {strmatch} 2269 } 2270 -returnCodes error 2271 -match glob 2272 -result {wrong # args*} 2273} 2274test assemble-23.2 {strmatch - wrong # args} { 2275 -body { 2276 assemble {strmatch too many} 2277 } 2278 -returnCodes error 2279 -match glob 2280 -result {wrong # args*} 2281} 2282test assemble-23.3 {strmatch - bad subst} { 2283 -body { 2284 assemble {strmatch $foo} 2285 } 2286 -returnCodes error 2287 -match glob 2288 -result {assembly code may not contain substitutions} 2289} 2290test assemble-23.4 {strmatch - not a boolean} { 2291 -body { 2292 proc x {} { 2293 assemble {strmatch rubbish} 2294 } 2295 x 2296 } 2297 -returnCodes error 2298 -result {expected boolean value but got "rubbish"} 2299 -cleanup {rename x {}} 2300} 2301test assemble-23.5 {strmatch} { 2302 -body { 2303 proc x {a b} { 2304 list [assemble {load a; load b; strmatch 0}] \ 2305 [assemble {load a; load b; strmatch 1}] 2306 } 2307 list [x foo*.grill fengbar.grill] [x foo*.grill foobar.grill] [x foo*.grill FOOBAR.GRILL] 2308 } 2309 -result {{0 0} {1 1} {0 1}} 2310 -cleanup {rename x {}} 2311} 2312test assemble-23.6 {unsetStk} { 2313 -body { 2314 proc x {} { 2315 set a {} 2316 assemble {push a; unsetStk false} 2317 info exists a 2318 } 2319 x 2320 } 2321 -result 0 2322 -cleanup {rename x {}} 2323} 2324test assemble-23.7 {unsetStk} { 2325 -body { 2326 proc x {} { 2327 assemble {push a; unsetStk false} 2328 info exists a 2329 } 2330 x 2331 } 2332 -result 0 2333 -cleanup {rename x {}} 2334} 2335test assemble-23.8 {unsetStk} { 2336 -body { 2337 proc x {} { 2338 assemble {push a; unsetStk true} 2339 info exists a 2340 } 2341 x 2342 } 2343 -returnCodes error 2344 -result {can't unset "a": no such variable} 2345 -cleanup {rename x {}} 2346} 2347test assemble-23.9 {unsetArrayStk} { 2348 -body { 2349 proc x {} { 2350 set a(b) {} 2351 assemble {push a; push b; unsetArrayStk false} 2352 info exists a(b) 2353 } 2354 x 2355 } 2356 -result 0 2357 -cleanup {rename x {}} 2358} 2359test assemble-23.10 {unsetArrayStk} { 2360 -body { 2361 proc x {} { 2362 assemble {push a; push b; unsetArrayStk false} 2363 info exists a(b) 2364 } 2365 x 2366 } 2367 -result 0 2368 -cleanup {rename x {}} 2369} 2370test assemble-23.11 {unsetArrayStk} { 2371 -body { 2372 proc x {} { 2373 assemble {push a; push b; unsetArrayStk true} 2374 info exists a(b) 2375 } 2376 x 2377 } 2378 -returnCodes error 2379 -result {can't unset "a(b)": no such variable} 2380 -cleanup {rename x {}} 2381} 2382 2383# assemble-24 -- ASSEM_BOOL_LVT4 (unset; unsetArray) 2384 2385test assemble-24.1 {unset - wrong # args} { 2386 -body { 2387 assemble {unset one} 2388 } 2389 -returnCodes error 2390 -match glob 2391 -result {wrong # args*} 2392} 2393test assemble-24.2 {unset - wrong # args} { 2394 -body { 2395 assemble {unset too many args} 2396 } 2397 -returnCodes error 2398 -match glob 2399 -result {wrong # args*} 2400} 2401test assemble-24.3 {unset - bad subst -arg 1} { 2402 -body { 2403 assemble {unset $foo bar} 2404 } 2405 -returnCodes error 2406 -match glob 2407 -result {assembly code may not contain substitutions} 2408} 2409test assemble-24.4 {unset - not a boolean} { 2410 -body { 2411 proc x {} { 2412 assemble {unset rubbish trash} 2413 } 2414 x 2415 } 2416 -returnCodes error 2417 -result {expected boolean value but got "rubbish"} 2418 -cleanup {rename x {}} 2419} 2420test assemble-24.5 {unset - bad subst - arg 2} { 2421 -body { 2422 assemble {unset true $bar} 2423 } 2424 -returnCodes error 2425 -result {assembly code may not contain substitutions} 2426} 2427test assemble-24.6 {unset - nonlocal var} { 2428 -body { 2429 assemble {unset true ::foo::bar} 2430 } 2431 -returnCodes error 2432 -result {variable "::foo::bar" is not local} 2433} 2434test assemble-24.7 {unset} { 2435 -body { 2436 proc x {} { 2437 set a {} 2438 assemble {unset false a} 2439 info exists a 2440 } 2441 x 2442 } 2443 -result 0 2444 -cleanup {rename x {}} 2445} 2446test assemble-24.8 {unset} { 2447 -body { 2448 proc x {} { 2449 assemble {unset false a} 2450 info exists a 2451 } 2452 x 2453 } 2454 -result 0 2455 -cleanup {rename x {}} 2456} 2457test assemble-24.9 {unset} { 2458 -body { 2459 proc x {} { 2460 assemble {unset true a} 2461 info exists a 2462 } 2463 x 2464 } 2465 -returnCodes error 2466 -result {can't unset "a": no such variable} 2467 -cleanup {rename x {}} 2468} 2469test assemble-24.10 {unsetArray} { 2470 -body { 2471 proc x {} { 2472 set a(b) {} 2473 assemble {push b; unsetArray false a} 2474 info exists a(b) 2475 } 2476 x 2477 } 2478 -result 0 2479 -cleanup {rename x {}} 2480} 2481test assemble-24.11 {unsetArray} { 2482 -body { 2483 proc x {} { 2484 assemble {push b; unsetArray false a} 2485 info exists a(b) 2486 } 2487 x 2488 } 2489 -result 0 2490 -cleanup {rename x {}} 2491} 2492test assemble-24.12 {unsetArray} { 2493 -body { 2494 proc x {} { 2495 assemble {push b; unsetArray true a} 2496 info exists a(b) 2497 } 2498 x 2499 } 2500 -returnCodes error 2501 -result {can't unset "a(b)": no such variable} 2502 -cleanup {rename x {}} 2503} 2504 2505# assemble-25 - dict get 2506 2507test assemble-25.1 {dict get - wrong # args} { 2508 -body { 2509 assemble {dictGet} 2510 } 2511 -returnCodes error 2512 -match glob 2513 -result {wrong # args*} 2514} 2515test assemble-25.2 {dict get - wrong # args} { 2516 -body { 2517 assemble {dictGet too many} 2518 } 2519 -returnCodes error 2520 -match glob 2521 -result {wrong # args*} 2522} 2523test assemble-25.3 {dictGet - bad subst} { 2524 -body { 2525 assemble {dictGet $foo} 2526 } 2527 -returnCodes error 2528 -match glob 2529 -result {assembly code may not contain substitutions} 2530} 2531test assemble-25.4 {dict get - not a number} { 2532 -body { 2533 proc x {} { 2534 assemble {dictGet rubbish} 2535 } 2536 x 2537 } 2538 -returnCodes error 2539 -result {expected integer but got "rubbish"} 2540 -cleanup {rename x {}} 2541} 2542test assemble-25.5 {dictGet - negative operand count} { 2543 -body { 2544 proc x {} { 2545 assemble {dictGet 0} 2546 } 2547 list [catch x result] $result $::errorCode 2548 } 2549 -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} 2550 -cleanup {rename x {}; unset result} 2551} 2552test assemble-25.6 {dictGet - 1 index} { 2553 -body { 2554 assemble {push {a 1 b 2}; push a; dictGet 1} 2555 } 2556 -result 1 2557} 2558 2559# assemble-26 - dict set 2560 2561test assemble-26.1 {dict set - wrong # args} { 2562 -body { 2563 assemble {dictSet 1} 2564 } 2565 -returnCodes error 2566 -match glob 2567 -result {wrong # args*} 2568} 2569test assemble-26.2 {dict get - wrong # args} { 2570 -body { 2571 assemble {dictSet too many args} 2572 } 2573 -returnCodes error 2574 -match glob 2575 -result {wrong # args*} 2576} 2577test assemble-26.3 {dictSet - bad subst} { 2578 -body { 2579 assemble {dictSet 1 $foo} 2580 } 2581 -returnCodes error 2582 -match glob 2583 -result {assembly code may not contain substitutions} 2584} 2585test assemble-26.4 {dictSet - not a number} { 2586 -body { 2587 proc x {} { 2588 assemble {dictSet rubbish foo} 2589 } 2590 x 2591 } 2592 -returnCodes error 2593 -result {expected integer but got "rubbish"} 2594 -cleanup {rename x {}} 2595} 2596test assemble-26.5 {dictSet - zero operand count} { 2597 -body { 2598 proc x {} { 2599 assemble {dictSet 0 foo} 2600 } 2601 list [catch x result] $result $::errorCode 2602 } 2603 -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} 2604 -cleanup {rename x {}; unset result} 2605} 2606test assemble-26.6 {dictSet - bad local} { 2607 -body { 2608 proc x {} { 2609 assemble {dictSet 1 ::foo::bar} 2610 } 2611 list [catch x result] $result $::errorCode 2612 } 2613 -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} 2614 -cleanup {rename x {}; unset result} 2615} 2616test assemble-26.7 {dictSet} { 2617 -body { 2618 proc x {} { 2619 set dict {a 1 b 2 c 3} 2620 assemble {push b; push 4; dictSet 1 dict} 2621 } 2622 x 2623 } 2624 -result {a 1 b 4 c 3} 2625 -cleanup {rename x {}} 2626} 2627 2628# assemble-27 - dictUnset 2629 2630test assemble-27.1 {dictUnset - wrong # args} { 2631 -body { 2632 assemble {dictUnset 1} 2633 } 2634 -returnCodes error 2635 -match glob 2636 -result {wrong # args*} 2637} 2638test assemble-27.2 {dictUnset - wrong # args} { 2639 -body { 2640 assemble {dictUnset too many args} 2641 } 2642 -returnCodes error 2643 -match glob 2644 -result {wrong # args*} 2645} 2646test assemble-27.3 {dictUnset - bad subst} { 2647 -body { 2648 assemble {dictUnset 1 $foo} 2649 } 2650 -returnCodes error 2651 -match glob 2652 -result {assembly code may not contain substitutions} 2653} 2654test assemble-27.4 {dictUnset - not a number} { 2655 -body { 2656 proc x {} { 2657 assemble {dictUnset rubbish foo} 2658 } 2659 x 2660 } 2661 -returnCodes error 2662 -result {expected integer but got "rubbish"} 2663 -cleanup {rename x {}} 2664} 2665test assemble-27.5 {dictUnset - zero operand count} { 2666 -body { 2667 proc x {} { 2668 assemble {dictUnset 0 foo} 2669 } 2670 list [catch x result] $result $::errorCode 2671 } 2672 -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} 2673 -cleanup {rename x {}; unset result} 2674} 2675test assemble-27.6 {dictUnset - bad local} { 2676 -body { 2677 proc x {} { 2678 assemble {dictUnset 1 ::foo::bar} 2679 } 2680 list [catch x result] $result $::errorCode 2681 } 2682 -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} 2683 -cleanup {rename x {}; unset result} 2684} 2685test assemble-27.7 {dictUnset} { 2686 -body { 2687 proc x {} { 2688 set dict {a 1 b 2 c 3} 2689 assemble {push b; dictUnset 1 dict} 2690 } 2691 x 2692 } 2693 -result {a 1 c 3} 2694 -cleanup {rename x {}} 2695} 2696 2697# assemble-28 - dictIncrImm 2698 2699test assemble-28.1 {dictIncrImm - wrong # args} { 2700 -body { 2701 assemble {dictIncrImm 1} 2702 } 2703 -returnCodes error 2704 -match glob 2705 -result {wrong # args*} 2706} 2707test assemble-28.2 {dictIncrImm - wrong # args} { 2708 -body { 2709 assemble {dictIncrImm too many args} 2710 } 2711 -returnCodes error 2712 -match glob 2713 -result {wrong # args*} 2714} 2715test assemble-28.3 {dictIncrImm - bad subst} { 2716 -body { 2717 assemble {dictIncrImm 1 $foo} 2718 } 2719 -returnCodes error 2720 -match glob 2721 -result {assembly code may not contain substitutions} 2722} 2723test assemble-28.4 {dictIncrImm - not a number} { 2724 -body { 2725 proc x {} { 2726 assemble {dictIncrImm rubbish foo} 2727 } 2728 x 2729 } 2730 -returnCodes error 2731 -result {expected integer but got "rubbish"} 2732 -cleanup {rename x {}} 2733} 2734test assemble-28.5 {dictIncrImm - bad local} { 2735 -body { 2736 proc x {} { 2737 assemble {dictIncrImm 1 ::foo::bar} 2738 } 2739 list [catch x result] $result $::errorCode 2740 } 2741 -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} 2742 -cleanup {rename x {}; unset result} 2743} 2744test assemble-28.6 {dictIncrImm} { 2745 -body { 2746 proc x {} { 2747 set dict {a 1 b 2 c 3} 2748 assemble {push b; dictIncrImm 42 dict} 2749 } 2750 x 2751 } 2752 -result {a 1 b 44 c 3} 2753 -cleanup {rename x {}} 2754} 2755 2756# assemble-29 - ASSEM_REGEXP 2757 2758test assemble-29.1 {regexp - wrong # args} { 2759 -body { 2760 assemble {regexp} 2761 } 2762 -returnCodes error 2763 -match glob 2764 -result {wrong # args*} 2765} 2766test assemble-29.2 {regexp - wrong # args} { 2767 -body { 2768 assemble {regexp too many} 2769 } 2770 -returnCodes error 2771 -match glob 2772 -result {wrong # args*} 2773} 2774test assemble-29.3 {regexp - bad subst} { 2775 -body { 2776 assemble {regexp $foo} 2777 } 2778 -returnCodes error 2779 -match glob 2780 -result {assembly code may not contain substitutions} 2781} 2782test assemble-29.4 {regexp - not a boolean} { 2783 -body { 2784 proc x {} { 2785 assemble {regexp rubbish} 2786 } 2787 x 2788 } 2789 -returnCodes error 2790 -result {expected boolean value but got "rubbish"} 2791 -cleanup {rename x {}} 2792} 2793test assemble-29.5 {regexp} { 2794 -body { 2795 assemble {push br.*br; push abracadabra; regexp false} 2796 } 2797 -result 1 2798} 2799test assemble-29.6 {regexp} { 2800 -body { 2801 assemble {push br.*br; push aBRacadabra; regexp false} 2802 } 2803 -result 0 2804} 2805test assemble-29.7 {regexp} { 2806 -body { 2807 assemble {push br.*br; push aBRacadabra; regexp true} 2808 } 2809 -result 1 2810} 2811 2812# assemble-30 - Catches 2813 2814test assemble-30.1 {simplest possible catch} { 2815 -body { 2816 proc x {} { 2817 assemble { 2818 beginCatch @bad 2819 push error 2820 push testing 2821 invokeStk 2 2822 pop 2823 push 0 2824 jump @ok 2825 label @bad 2826 push 1; # should be pushReturnCode 2827 label @ok 2828 endCatch 2829 } 2830 } 2831 x 2832 } 2833 -result 1 2834 -cleanup {rename x {}} 2835} 2836test assemble-30.2 {catch in external catch conntext} { 2837 -body { 2838 proc x {} { 2839 list [catch { 2840 assemble { 2841 beginCatch @bad 2842 push error 2843 push testing 2844 invokeStk 2 2845 pop 2846 push 0 2847 jump @ok 2848 label @bad 2849 pushReturnCode 2850 label @ok 2851 endCatch 2852 } 2853 } result] $result 2854 } 2855 x 2856 } 2857 -result {0 1} 2858 -cleanup {rename x {}} 2859} 2860test assemble-30.3 {embedded catches} { 2861 -body { 2862 proc x {} { 2863 list [catch { 2864 assemble { 2865 beginCatch @bad 2866 push error 2867 eval { list [catch {error whatever} result] $result } 2868 invokeStk 2 2869 push 0 2870 reverse 2 2871 jump @done 2872 label @bad 2873 pushReturnCode 2874 pushResult 2875 label @done 2876 endCatch 2877 list 2 2878 } 2879 } result2] $result2 2880 } 2881 x 2882 } 2883 -result {0 {1 {1 whatever}}} 2884 -cleanup {rename x {}} 2885} 2886test assemble-30.4 {throw in wrong context} { 2887 -body { 2888 proc x {} { 2889 list [catch { 2890 assemble { 2891 beginCatch @bad 2892 push error 2893 eval { list [catch {error whatever} result] $result } 2894 invokeStk 2 2895 push 0 2896 reverse 2 2897 jump @done 2898 2899 label @bad 2900 load x 2901 pushResult 2902 2903 label @done 2904 endCatch 2905 list 2 2906 } 2907 } result] $result $::errorCode [split $::errorInfo \n] 2908 } 2909 x 2910 } 2911 -match glob 2912 -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}*}} 2913 -cleanup {rename x {}} 2914} 2915test assemble-30.5 {unclosed catch} { 2916 -body { 2917 proc x {} { 2918 assemble { 2919 beginCatch @error 2920 push 0 2921 jump @done 2922 label @error 2923 push 1 2924 label @done 2925 push "" 2926 pop 2927 } 2928 } 2929 list [catch {x} result] $result $::errorCode $::errorInfo 2930 } 2931 -match glob 2932 -result {1 {catch still active on exit from assembly code} {TCL ASSEM UNCLOSEDCATCH} {catch still active on exit from assembly code 2933 ("assemble" body, line 2)*}} 2934 -cleanup {rename x {}} 2935} 2936test assemble-30.6 {inconsistent catch contexts} { 2937 -body { 2938 proc x {y} { 2939 assemble { 2940 load y 2941 jumpTrue @inblock 2942 beginCatch @error 2943 label @inblock 2944 push 0 2945 jump @done 2946 label @error 2947 push 1 2948 label @done 2949 } 2950 } 2951 list [catch {x 2} result] $::errorCode $::errorInfo 2952 } 2953 -match glob 2954 -result {1 {TCL ASSEM BADCATCH} {execution reaches an instruction in inconsistent exception contexts 2955 ("assemble" body, line 5)*}} 2956 -cleanup {rename x {}} 2957} 2958 2959# assemble-31 - Jump tables 2960 2961test assemble-31.1 {jumpTable, wrong # args} { 2962 -body { 2963 assemble {jumpTable} 2964 } 2965 -returnCodes error 2966 -match glob 2967 -result {wrong # args*} 2968} 2969test assemble-31.2 {jumpTable, wrong # args} { 2970 -body { 2971 assemble {jumpTable too many} 2972 } 2973 -returnCodes error 2974 -match glob 2975 -result {wrong # args*} 2976} 2977test assemble-31.3 {jumpTable - bad subst} { 2978 -body { 2979 assemble {jumpTable $foo} 2980 } 2981 -returnCodes error 2982 -match glob 2983 -result {assembly code may not contain substitutions} 2984} 2985test assemble-31.4 {jumptable - not a list} { 2986 -body { 2987 assemble {jumpTable \{rubbish} 2988 } 2989 -returnCodes error 2990 -result {unmatched open brace in list} 2991} 2992test assemble-31.5 {jumpTable, badly structured} { 2993 -body { 2994 list [catch {assemble { 2995 # line 2 2996 jumpTable {one two three};# line 3 2997 }} result] \ 2998 $result $::errorCode $::errorInfo 2999 } 3000 -match glob 3001 -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)*}} 3002} 3003test assemble-31.6 {jumpTable, missing symbol} { 3004 -body { 3005 list [catch {assemble { 3006 # line 2 3007 jumpTable {1 a};# line 3 3008 }} result] \ 3009 $result $::errorCode $::errorInfo 3010 } 3011 -match glob 3012 -result {1 {undefined label "a"} {TCL ASSEM NOLABEL a} {undefined label "a"*("assemble" body, line 3)*}} 3013} 3014test assemble-31.7 {jumptable, actual example} { 3015 -setup { 3016 proc x {} { 3017 set result {} 3018 for {set i 0} {$i < 5} {incr i} { 3019 lappend result [assemble { 3020 load i 3021 jumpTable {1 @one 2 @two 3 @three} 3022 push {none of the above} 3023 jump @done 3024 label @one 3025 push one 3026 jump @done 3027 label @two 3028 push two 3029 jump @done 3030 label @three 3031 push three 3032 label @done 3033 }] 3034 } 3035 set tcl_traceCompile 2 3036 set result 3037 } 3038 } 3039 -body x 3040 -result {{none of the above} one two three {none of the above}} 3041 -cleanup {set tcl_traceCompile 0; rename x {}} 3042} 3043 3044test assemble-40.1 {unbalanced stack} { 3045 -body { 3046 list \ 3047 [catch { 3048 assemble { 3049 push 3 3050 dup 3051 mult 3052 push 4 3053 dup 3054 mult 3055 pop 3056 expon 3057 } 3058 } result] $result $::errorInfo 3059 } 3060 -result {1 {stack underflow} {stack underflow 3061 in assembly code between lines 1 and end of assembly code*}} 3062 -match glob 3063 -returnCodes ok 3064} 3065test assemble-40.2 {unbalanced stack} {*}{ 3066 -body { 3067 list \ 3068 [catch { 3069 assemble { 3070 label a 3071 push {} 3072 label b 3073 pop 3074 label c 3075 pop 3076 label d 3077 push {} 3078 } 3079 } result] $result $::errorInfo 3080 } 3081 -result {1 {stack underflow} {stack underflow 3082 in assembly code between lines 7 and 9*}} 3083 -match glob 3084 -returnCodes ok 3085} 3086 3087test assemble-41.1 {Inconsistent stack usage} {*}{ 3088 -body { 3089 proc x {y} { 3090 assemble { 3091 load y 3092 jumpFalse else 3093 push 0 3094 jump then 3095 label else 3096 push 1 3097 push 2 3098 label then 3099 pop 3100 } 3101 } 3102 catch {x 1} 3103 set errorInfo 3104 } 3105 -match glob 3106 -result {inconsistent stack depths on two execution paths 3107 ("assemble" body, line 10)*} 3108} 3109test assemble-41.2 {Inconsistent stack, jumptable and default} { 3110 -body { 3111 proc x {y} { 3112 assemble { 3113 load y 3114 jumpTable {0 else} 3115 push 0 3116 label else 3117 pop 3118 } 3119 } 3120 catch {x 1} 3121 set errorInfo 3122 } 3123 -match glob 3124 -result {inconsistent stack depths on two execution paths 3125 ("assemble" body, line 6)*} 3126} 3127test assemble-41.3 {Inconsistent stack, two legs of jumptable} { 3128 -body { 3129 proc x {y} { 3130 assemble { 3131 load y 3132 jumpTable {0 no 1 yes} 3133 label no 3134 push 0 3135 label yes 3136 pop 3137 } 3138 } 3139 catch {x 1} 3140 set errorInfo 3141 } 3142 -match glob 3143 -result {inconsistent stack depths on two execution paths 3144 ("assemble" body, line 7)*} 3145} 3146 3147test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} { 3148 -body { 3149 proc ulam {n} { 3150 assemble { 3151 load n; # max 3152 dup; # max n 3153 jump start; # max n 3154 3155 label loop; # max n 3156 over 1; # max n max 3157 over 1; # max in max n 3158 ge; # man n max>=n 3159 jumpTrue skip; # max n 3160 3161 reverse 2; # n max 3162 pop; # n 3163 dup; # n n 3164 3165 label skip; # max n 3166 dup; # max n n 3167 push 2; # max n n 2 3168 mod; # max n n%2 3169 jumpTrue odd; # max n 3170 3171 push 2; # max n 2 3172 div; # max n/2 -> max n 3173 jump start; # max n 3174 3175 label odd; # max n 3176 push 3; # max n 3 3177 mult; # max 3*n 3178 push 1; # max 3*n 1 3179 add; # max 3*n+1 3180 3181 label start; # max n 3182 dup; # max n n 3183 push 1; # max n n 1 3184 neq; # max n n>1 3185 jumpTrue loop; # max n 3186 3187 pop; # max 3188 } 3189 } 3190 set result {} 3191 for {set i 1} {$i < 30} {incr i} { 3192 lappend result [ulam $i] 3193 } 3194 set result 3195 } 3196 -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} 3197} 3198 3199test assemble-51.1 {memory leak testing} memory { 3200 leaktest { 3201 apply {{} {assemble {push hello}}} 3202 } 3203} 0 3204test assemble-51.2 {memory leak testing} memory { 3205 leaktest { 3206 apply {{{x 0}} {assemble {incrImm x 1}}} 3207 } 3208} 0 3209test assemble-51.3 {memory leak testing} memory { 3210 leaktest { 3211 apply {{n} { 3212 assemble { 3213 load n; # max 3214 dup; # max n 3215 jump start; # max n 3216 3217 label loop; # max n 3218 over 1; # max n max 3219 over 1; # max in max n 3220 ge; # man n max>=n 3221 jumpTrue skip; # max n 3222 3223 reverse 2; # n max 3224 pop; # n 3225 dup; # n n 3226 3227 label skip; # max n 3228 dup; # max n n 3229 push 2; # max n n 2 3230 mod; # max n n%2 3231 jumpTrue odd; # max n 3232 3233 push 2; # max n 2 3234 div; # max n/2 -> max n 3235 jump start; # max n 3236 3237 label odd; # max n 3238 push 3; # max n 3 3239 mult; # max 3*n 3240 push 1; # max 3*n 1 3241 add; # max 3*n+1 3242 3243 label start; # max n 3244 dup; # max n n 3245 push 1; # max n n 1 3246 neq; # max n n>1 3247 jumpTrue loop; # max n 3248 3249 pop; # max 3250 } 3251 }} 1 3252 } 3253} 0 3254test assemble-51.4 {memory leak testing} memory { 3255 leaktest { 3256 catch { 3257 apply {{} { 3258 assemble {reverse polish notation} 3259 }} 3260 } 3261 } 3262} 0 3263 3264test assemble-52.1 {Bug 3154ea2759} { 3265 apply {{} { 3266 # Needs six exception ranges to force the range allocations to use the 3267 # malloced store. 3268 ::tcl::unsupported::assemble { 3269 beginCatch @badLabel 3270 push error 3271 push testing 3272 invokeStk 2 3273 pop 3274 push 0 3275 jump @okLabel 3276 label @badLabel 3277 push 1; # should be pushReturnCode 3278 label @okLabel 3279 endCatch 3280 pop 3281 3282 beginCatch @badLabel2 3283 push error 3284 push testing 3285 invokeStk 2 3286 pop 3287 push 0 3288 jump @okLabel2 3289 label @badLabel2 3290 push 1; # should be pushReturnCode 3291 label @okLabel2 3292 endCatch 3293 pop 3294 3295 beginCatch @badLabel3 3296 push error 3297 push testing 3298 invokeStk 2 3299 pop 3300 push 0 3301 jump @okLabel3 3302 label @badLabel3 3303 push 1; # should be pushReturnCode 3304 label @okLabel3 3305 endCatch 3306 pop 3307 3308 beginCatch @badLabel4 3309 push error 3310 push testing 3311 invokeStk 2 3312 pop 3313 push 0 3314 jump @okLabel4 3315 label @badLabel4 3316 push 1; # should be pushReturnCode 3317 label @okLabel4 3318 endCatch 3319 pop 3320 3321 beginCatch @badLabel5 3322 push error 3323 push testing 3324 invokeStk 2 3325 pop 3326 push 0 3327 jump @okLabel5 3328 label @badLabel5 3329 push 1; # should be pushReturnCode 3330 label @okLabel5 3331 endCatch 3332 pop 3333 3334 beginCatch @badLabel6 3335 push error 3336 push testing 3337 invokeStk 2 3338 pop 3339 push 0 3340 jump @okLabel6 3341 label @badLabel6 3342 push 1; # should be pushReturnCode 3343 label @okLabel6 3344 endCatch 3345 pop 3346 } 3347 }} 3348} {}; # must not crash 3349 3350rename fillTables {} 3351rename assemble {} 3352 3353::tcltest::cleanupTests 3354return 3355 3356# Local Variables: 3357# mode: tcl 3358# fill-column: 78 3359# End: 3360