diff --git a/tests/czech.inf b/tests/czech.inf new file mode 100644 index 0000000..686befc --- /dev/null +++ b/tests/czech.inf @@ -0,0 +1,1683 @@ +!! CZECH: Comprehensive Z-machine Emulation CHecker +!! +!! Fairly thoroughly test z-machine stuff. +!! +!! Based on nitfol test script, by Evin Robertson, which was placed in +!! the public domain. +!! Amir Karger massively modified it, changed its name, and un-public'ed it. +!! See README.txt for license. (Basically, use/copy/modify, but be nice.) + + + +! Force Inform to use abbreviations +Switches e; + +Constant TEST_VERSION "0.8"; + +!! +!! USAGE NOTES: +!! +!! * To run tests, just compile this with Inform (I used 6.21.) and run +!! the resulting file with your favorite intepreter. +!! +!! * After every test (except print tests) a '.' is printed. +!! The current test number is printed each time a set of tests is started, +!! and whenever a test fails. +!! +!! * At the end, you'll get a summary of passed tests, failed tests, and print +!! tests. (The computer can't test whether a print test was successful.) +!! +!! * Many tests print a string when they fail describing exactly what went +!! wrong, so you can look in the code for that string and see exactly +!! what test failed. If no string is printed out, count tests from the +!! beginning of the set until the test number that failed. +!! +!! * Compile with -v[3468] to test different Z-machine versions. +!! (Inform's default is -v5.) +!! +!! * A set of tests can be skipped. See Main(). +!! +!! * subroutines, print, and some jumps are needed to do +!! most testing. If they have major bugs, the whole script may break. +!! (E.g., You need to call_vn2 (call in v3) just to get to "Main" routine.) +!! Local/Global variables and stack also need to work at least somewhat. + +!-------------------------------------------------------------------- +! Main() calls a bunch of test_* subs. +! test_* subs each test a set of functionality, e.g., arithmetic operators +! do_* subs generally test one op, sometimes two (like load/store) +! assert* routines test that the expected value was obtained, and +! sometimes print a test description, too. +!-------------------------------------------------------------------- +! Still need to test: +! - test globals, locals, stack as ops more thoroughly +! - moreheader stuff +! - IO (streams, read_char, fancy print stuff) +! - *_table +! - fancy IO: time, split_window, get_mouse, streams, etc. +! - read, tokenise +! - save/restore? restart? +! - See TODO throughout the file for more stringent testing ideas +! Steal David Kinder's Unicode.inf? (Win2002 Examples dir) +! Steal etude stuff? +! Steal nitfol's crashme.inf, randomization print test? +!-------------------------------------------------------------------- +! More notes for writing tests: +! - In general, use assembly (@ commands) instead of Inform. We're testing +! how the Z-machine performs on the opcodes, not how Inform translates stuff +! E.g., Use @print instead of print so inform uses @print instead of +! @print_paddr even for long strings. +! And I never use (string) or (char), which load in a bunch of extra code. +! - Use assert whenever possible. Otherwise, call p() or f() +! after testing to increment the count of failed & passed tests +! Or call pt() for a print test, where the user needs to decide whether +! the test was successful. '.' is also printed for every call to p() or f() +! ("assert*()" appears to consistently map to @call_vn2.) +! - Certain things are done in a roundabout way to avoid using complex opcodes. +! This is especially true of assert* routines, which can be called from +! anywhere in the testing process. +! - This file is designed to require NO I/O. Other test files can test +! I/O stuff. We can still test opcodes like read/print by using streams. + +! Version-specific constants - Ifdef these to test only certain versions +! Someday, we'll need a IS_V6 here for V6-specific opcodes. +Iftrue #version_number >= 4; + Constant V4PLUS = 1; +Endif; +Iftrue #version_number >= 5; + Constant V5PLUS = 1; +Endif; + +! [Evin] couldn't figure out how to do negative numbers in inform assembly, so +! here's constants for the numbers I use +Constant n1 -1; +Constant n2 -2; +Constant n3 -3; +Constant n4 -4; +Constant n5 -5; +Constant n500 -500; +Constant n32768 -32768; + +! TODO I could test globals by confirming that g00 changes when I try to +! change the first Global I declare. + +! CAREFUL about declaring new globals! Declaration order matters, e.g. +! for "@load [i] -> j", where i refers to a Global var. +Global count; +Global Testnum; +Global Passed; +Global Failed; +Global Print_Tests; +Global Gtemp; +!Global Gtemp2; +Global Ga; Global Gb; ! hack used to get assert routines to work in v3 +!Global Standard; + +Abbreviate "xyzzy"; + +Array mytable -> 256; +!Array mysecond -> 256; + +! Make this sub the first in the test program, so that the string +! in it is the first string in high memory. +! TODO Don't know how to find first string's address, though! +![ make_a_string; +! print "^print_paddr: This long string should be printed.^"; +!]; + +! ---------------------------------------------------------------------- +! Assert Routines: did we get expected output? + +! Main assert function. +! desc is an optional arg which is a short string describing the exact +! test run. Note that the program already writes which opcode we're testing, +! so only use this for saying what *aspect* of that opcode is being tested. +! See calls in the code for examples. +[ assert0 actual expected desc; + if (expected ~= actual) { + print "^^ERROR [",Testnum,"] "; + ! Print description if we got one +#Ifdef V5PLUS; + @check_arg_count 3 ?~no_desc; +#Ifnot; ! fake a check_arg_count + @jz desc ?no_desc; +#Endif; + print "("; + @print_paddr desc; + print ")"; + + .no_desc; + f(); + print " Expected ", expected, "; got ", actual, "^^"; + !@quit; + } else { + p(); + } +]; + +! Problem: the "(string)" command requires Inform to pull in a whole +! bunch of code requiring a whole bunch of new ops, which I don't want +! to use for assert commands + +! Special assert for Unary ops +! TODO allow this to take an optional desc also, to give the test's REASON. +[ assert1 actual expected op a; + a = Ga; ! Hack so we can call with only 3 args for v3. + if (expected ~= actual) { + f(); + !print (string) op, a; + print "^^ERROR [", Testnum, "] ("; + @print_paddr op; + print " ", a, ")"; + print " Expected ", expected, "; got ", actual, "^"; + !@quit; + } else { + p(); + } +]; + +! Special assert for Binary ops +! TODO allow this to take an optional desc also, to give the test's REASON. +[ assert2 actual expected op a b; + a = Ga; b = Gb; ! Hack so we can call with only 3 args for v3. + if (expected ~= actual) { + f(); +! print a, (string) op, b; + print "^^[", Testnum, "] ("; + print a, " "; + @print_paddr op; + print " ", b, ")"; + print " Expected ", expected, "; got ", actual, "^"; + !@quit; + } else { + p(); + } +]; + +! For a print test, don't print out a dot & don't try and figure out +! if it was successful +[ pt; + Testnum++; + Print_Tests++; +]; + +! Passed a test +[ p; + @print "."; + Testnum++; + Passed++; +]; + +! Failed a test +[ f; + Testnum++; + Failed++; +]; + +! ---------------------------------------------------------------------- +! These subs run tests on a particular set of ops +! First argument is whether to skip the tests + +[ test_jumps skip i; + print "Jumps"; + @jz skip ?skipped; + print " skipped"; + rfalse; +.skipped; + print " [", Testnum+1, "]: "; + print "jump"; + jump j2; ! Using "@jump" with label name crashes + .j1; + print "bad!"; @quit; + .j2; p(); + + ! Note that some of these jumps are > 63 bytes away, some less, + ! so we'll test short and long form of branching. + print "je"; + ! TODO test "je sp a b c" to make sure not multi-popping stack, etc. + @je 5 5 ?~bad; p(); + @je 5 n5 ?bad; p(); + @je n5 5 ?bad; p(); + @je n5 n5 ?~bad; p(); + @je 32767 n32768 ?bad; p(); + @je n32768 n32768 ?~bad; p(); + @je 5 4 5 ?~bad; p(); + @je 5 4 3 5 ?~bad; p(); + @je 5 4 5 3 ?~bad; p(); + @je 5 4 3 2 ?bad; p(); + + print "jg"; + @jg 5 5 ?bad; p(); + @jg 1 0 ?~bad; p(); + @jg 0 1 ?bad; p(); + @jg n1 n2 ?~bad; p(); + @jg n2 n1 ?bad; p(); + @jg 1 n1 ?~bad; p(); + @jg n1 1 ?bad; p(); + + print "jl"; + @jl 5 5 ?bad; p(); + @jl 1 0 ?bad; p(); + @jl 0 1 ?~bad; p(); + @jl n1 n2 ?bad; p(); + @jl n2 n1 ?~bad; p(); + @jl 1 n1 ?bad; p(); + @jl n1 1 ?~bad; p(); + + print "jz"; + @jz 0 ?~bad; p(); + @jz 1 ?bad; p(); + @jz n4 ?bad; p(); + + print "offsets"; + i = do_jump_return(0); + assert0(i, 0, "branch 0"); + i = do_jump_return(1); + assert0(i, 1, "branch 1"); + rtrue; + +.bad; + print "^bad [", Testnum, "]!^"; + @print "Quitting tests because jumps don't work!"; + @quit; + +]; + +! Test that offset of 0/1 returns instead of branching. +! TODO in theory we should test all jump opcodes to make sure they can +! return false/true +[ do_jump_return i; + @je i 0 ?~j1; + @jz 0 ?rfalse; + return 97; + .j1; + @je i 1 ?~j2; + @jz 0 ?rtrue; + return 98; + .j2; + return 99; +]; + +! ---- VARIABLES ---------------------------------- +[ test_variables skip i n; + print "Variables"; + @jz skip ?skipped; + print " skipped"; + rfalse; +.skipped; + print " [", Testnum+1, "]: "; + + print "push/pull"; + @push 9; + @push 8; + @pull i; + assert0(i, 8, "pull to local"); + @pull Gtemp; + assert0(Gtemp, 9, "pull to global"); + +#Ifndef V5PLUS; + print "pop"; + @push 7; + @push 6; + @pop; ! popped value gets thrown away + @pull i; + assert0(i, 7); +#Endif; + + print "store"; + @store i 5; + assert0(i, 5); + print "load"; + n = 5; i = 6; + @load i sp; + @pull n; + assert0(i, n); + + print "dec"; + do_dec( 5, 4); + do_dec( 0, -1); + do_dec(-8, -9); + do_dec(-32768, 32767); + ! Should decrement top of stack and not pop it + @push 1; + @push 10; + @dec sp; + @pull n; + assert0(n, 9, "dec sp"); + @pull n; + assert0(n, 1, "dec sp"); + count = 3; + @dec count; + assert0(count, 2, "dec global"); + + print "inc"; + do_inc( 5, 6); + do_inc(-1, 0); + do_inc(-8, -7); + do_inc(32767, -32768); + @push 1; + @push 10; + @inc sp; + @pull n; + assert0(n, 11, "inc sp"); + @pull n; + assert0(n, 1, "inc sp"); + count = 3; + @inc count; + assert0(count, 4, "inc global"); + + print "^ dec_chk"; + n = 3; + @dec_chk n 1000 ?~bad1; p(); ! 2 + @dec_chk n 1 ?bad1; p(); ! 1 + @dec_chk n 1 ?~bad1; p(); ! 0 + @dec_chk n 0 ?~bad1; p(); ! -1 + @dec_chk n n2 ?bad1; p(); ! -2 + @dec_chk n n2 ?~bad1; p(); ! -3 + @dec_chk n 1000 ?~bad1; p(); ! -4 + @dec_chk n n500 ?bad1; p(); ! -5 + @push 1; + @push 10; + @dec_chk sp 5 ?bad1; p(); + @pull n; + assert0(n, 9, "dec_chk sp"); + @pull n; + assert0(n, 1, "dec_chk sp"); + jump not_bad1; +.bad1; + print "^bad [", Testnum, "]^"; + f(); +.not_bad1; + + print "inc_chk"; + n = -6; + @inc_chk n n500 ?~bad2; p(); ! -5 + @inc_chk n 1000 ?bad2; p(); ! -4 + @inc_chk n n3 ?bad2; p(); ! -3 + @inc_chk n n3 ?~bad2; p(); ! -2 + @inc_chk n 0 ?bad2; p(); ! -1 + @inc_chk n 1 ?bad2; p(); ! 0 + @inc_chk n 1 ?bad2; p(); ! 1 + @inc_chk n 1 ?~bad2; p(); ! 2 + @inc_chk n 1000 ?bad2; p(); ! 3 + jump not_bad2; +.bad2; + print "^bad [", Testnum, "]!^"; + f(); +.not_bad2; + + rtrue; +]; + +[ do_inc a expect; + Ga = a; + @inc a; + assert1(a, expect, "++"); +]; + +[ do_dec a expect; + Ga = a; + @dec a; + assert1(a, expect, "--"); +]; + +! ---- ARITH ---------------------------------- +[ test_arithmetic skip; + print "Arithmetic ops"; + @jz skip ?skipped; + print " skipped"; + rfalse; +.skipped; + print " [", Testnum+1, "]: "; + + print "add"; + do_add( 5, 3, 8); + do_add( 3, 5, 8); + do_add(-5, 3, -2); + do_add(-5, -3, -8); + do_add(-3, -5, -8); + do_add(-3, 5, 2); + do_add(32765, 6, -32765); + + print "sub"; + do_sub(8, 5, 3); + do_sub(8, 3, 5); + do_sub(-2, -5, 3); + do_sub(-8, -5, -3); + do_sub(-8, -3, -5); + do_sub(2, -3, 5); + do_sub(-32765, 32765, 6); + + print "^ mul"; + do_mul( 0, 123, 0); + do_mul(123, 0, 0); + do_mul( 8, 9, 72); + do_mul( 9, 8, 72); + do_mul( 11, -5, -55); + do_mul(-11, 5, -55); + do_mul(-11, -5, 55); + do_mul(-32768, -1, -32768); + + print "div"; + do_div(-11, 2, -5); + do_div(-11, -2, 5); + do_div( 11, -2, -5); + do_div( 5, 1, 5); + do_div( 5, 2, 2); + do_div( 5, 3, 1); + do_div( 5, 5, 1); + do_div( 5, 6, 0); + do_div(5, 32767, 0); + do_div(32767, -32768, 0); + do_div(-32768, 32767, -1); +! do_div(-32768, -1, -32768); + + print "mod"; + do_mod(-13, 5, -3); + do_mod( 13, -5, 3); + do_mod(-13, -5, -3); + do_mod( 5, 1, 0); + do_mod( 5, 2, 1); + do_mod( 5, 3, 2); + do_mod( 5, 5, 0); + do_mod( 5, 6, 5); + do_mod(5, 32767, 5); + do_mod(32767, -32768, 32767); + do_mod(-32768, 32767, -1); +! do_mod(-32768, -1, 0); + + rtrue; +]; + +[ do_add a b expect c; + @add a b -> c; Ga = a; Gb = b; + assert2(c, expect, "+"); +]; + +[ do_sub a b expect c; + @sub a b -> c; Ga = a; Gb = b; + assert2(c, expect, "-"); +]; + +[ do_mul a b expect c; + @mul a b -> c; Ga = a; Gb = b; + assert2(c, expect, "*"); +]; + +[ do_div a b expect c; + @div a b -> c; Ga = a; Gb = b; + assert2(c, expect, "/"); +]; + +[ do_mod a b expect c; + @mod a b -> c; Ga = a; Gb = b; + assert2(c, expect, "%"); +]; + +! ---- LOGICAL ---------------------------------- +[ test_logical skip; + print "Logical ops"; + @jz skip ?skipped; + print " skipped"; + rfalse; +.skipped; + print " [", Testnum+1, "]: "; + + print "not"; + do_not(0, ~0); + do_not(123, ~123); + do_not($5555, $aaaa); + do_not($aaaa, $5555); + + print "and"; + do_and( 5, 3, 1); + do_and( 3, 5, 1); + do_and(-3, -3, -3); + do_and(-3, 5, 5); + do_and(-3, -5, -7); + + print "or"; + do_or($1234, $4321, $5335); + do_or($4321, $1234, $5335); + do_or($1234, 0, $1234); + do_or($1030, $ffff, $ffff); + do_or($ffff, $0204, $ffff); + +#Ifdef V5PLUS; + print "art_shift"; + do_art( 0, 1, 0); + do_art( 0, -1, 0); + do_art( 1, 5, 32); + do_art( 1, -1, 0); + do_art(85, 1, 170); + do_art(85, -2, 21); + do_art(-9, 5, -288); + do_art(-9, -5, -1); + + print "log_shift"; + do_log( 0, 1, 0); + do_log( 0, -1, 0); + do_log( 1, 5, 32); + do_log( 1, -1, 0); + do_log(85, 1, 170); + do_log(85, -2, 21); + do_log(-9, 5, -288); + do_log(-9, -5, 2047); +#Endif; + + rtrue; +]; + +#Ifdef V5PLUS; +[ do_art a b expect c; + @art_shift a b -> c; Ga = a; Gb = b; + assert2(c, expect, "<<"); +]; + +[ do_log a b expect c; + @log_shift a b -> c; Ga = a; Gb = b; + assert2(c, expect, "<<"); +]; +#Endif; + +! Write 'not' instead of '~' so we can print with print_paddr +[ do_not a expect c; + !@"VAR:56S" a -> c; ! @not a -> c; (bug in inform) + @not a -> c; ! (No longer a bug in inform?) + Ga = a; + assert1(c, expect, "not"); +]; + +[ do_and a b expect c; + @and a b -> c; Ga = a; Gb = b; + assert2(c, expect, "&"); +]; + +[ do_or a b expect c; + @or a b -> c; Ga = a; Gb = b; + assert2(c, expect, "|"); +]; + +! ---- MEMORY ACCESS ---------------------------------- +[ test_memory skip i j k n; + print "Memory"; + @jz skip ?skipped; + print " skipped"; + rfalse; +.skipped; + print " [", Testnum+1, "]: "; + + print "loadw"; + ! Bytes 04-05 of file are beg. of high mem. + ! Bytes 06-07 are address of main. + ! main() is guaranteed to be first sub in Inform! + @loadw 0 2 -> i; + @loadw 0 3 -> j; + @add i 1 -> k; + assert0(j, k); + + print "loadb"; + @loadb 0 4 -> j; + @loadb 0 5 -> k; + @mul j 256 -> sp; + @add sp k -> k; + assert0(i, k); + @loadb mytable 0 -> n; + assert0(n, 0); + + print "storeb"; + @storeb mytable 0 123; + @loadb mytable 0 -> n; + assert0(n, 123); + @loadw mytable 0 -> n; + assert0(n, $7b00, "word from two bytes"); + print "storew"; + @storew mytable 5 $1234; + @loadw mytable 5 -> n; + assert0(n, $1234); + @loadb mytable 10 -> n; + assert0(n, $12, "first byte of stored word"); + @loadb mytable 11 -> n; + assert0(n, $34, "second byte of stored word"); + ! TODO load/store numbers > 32K + + rtrue; +]; + +! ---- PRINT opcodes ---------------------------------- +[ test_print skip i; + @print "^^^"; + print "Print opcodes"; + @jz skip ?skipped; + print " skipped"; + rfalse; +.skipped; + print " [", Testnum+1, "]: "; + + ! Note: pt()'s best location is after you print what should come out + ! and before you actually print it. But we may get some off-by-ones + @print "Tests should look like... '[Test] opcode (stuff): stuff'"; + @print "^print_num (0, 1, -1, 32767,-32768, -1): "; pt(); + @print_num 0; print ", "; + i = 1; + @print_num i; print ", "; pt(); + @print_num n1; print ", "; pt(); + @print_num 32767; print ", "; pt(); + @print_num n32768; print ", "; pt(); + i = 65535; + @print_num i; pt(); + print "^[", Testnum+1, "] "; + print "print_char (abcd): "; + @print_char 'a'; pt(); + @print_char 98; pt(); + i = 99; + @print_char i; pt(); + @push 100; pt(); + @print_char sp; + print "^[", Testnum+1, "] "; + print "new_line:^"; pt(); + @new_line; + @print "There should be an empty line above this line.^"; + i = do_print_ret(); pt(); ! test printing AND return + assert0(i, 1); + + ! TODO Once we have objects, print_addr of first word in dictionary. + + ! I could also write stuff to globalvars (as long as I knew what + ! offset they'd have) then load the address from 0->0c and print_addr. + @print "^print_addr (Hello.): "; pt(); + @storew mytable 0 $11aa; ! 4 13 10: Shift-He + @storew mytable 1 $4634; ! 17 17 20: llo + @storew mytable 2 $1645; ! 5 18 5: A2 . A2 + @storew mytable 3 $9ca5; ! 7 5 5: \n space-fill + ! FYI xyzzy is 77df ffc5 +! print mytable->1; + @print_addr mytable; + @print "^print_paddr (A long string that Inform will put in high memory):^"; + pt(); + print "A long string that Inform will put in high memory"; + ! Break up print statement to NOT use abbrev in parenthetical part + print "^Abbreviations (I love 'xyz"; print "zy' [two times]): "; pt(); + i = "I love 'xyzzy' "; + @print_paddr i; + pt(); + @print " I love 'xyzzy'^"; + ! TODO @print_paddr sp, global vars + ! TODO test word wrapping + + print "^[", Testnum+1, "] "; + @print "print_obj (Test Object #1Test Object #2): "; pt(); + @print_obj Obj1; pt(); + @print_obj Obj2; +! TODO long test object name + + ! TODO print many more complicated things, Unicode, whatever + ! TODO use unfinished abbreviations. + + rtrue; +]; + +! ---- SUBROUTINES ---------------------------------- +[ test_subroutines skip i n; + print "Subroutines"; + @jz skip ?skipped; + print " skipped"; + rfalse; +.skipped; + print " [", Testnum+1, "]: "; + + i = 0; + Gtemp = 0; +#Ifdef V4PLUS; + print "call_1s"; + Gtemp = 2; + @call_1s do_call_1s -> i; + assert0(Gtemp, 3); + print "call_2s"; + @call_2s do_call_2s 6 -> i; + assert0(i, 5); + + print "call_vs2"; + i = 0; + @call_vs2 do_call_vs2 1 2 3 4 5 6 7 ->i; + assert0(Gtemp, 9); + assert0(i, 5); + print "call_vs"; + i = 0; + @call_vs do_call 1 2 3 ->i; + assert0(i, 5); + +#Ifnot; ! v3 + print "call"; + @call do_call 1 2 3 ->i; +#Endif; + + ! Test results of call/call_vs, depending on game version + assert0(Gtemp, 7); + print "ret"; + assert0(i, 5); + ! TODO call_vs2 with fewer than 7 args. Make sure locals don't get set etc. + +#Ifdef V5PLUS; + print "^ call_1n"; + @call_1n do_call_1n; + assert0(Gtemp, 1); + print "call_2n"; + @call_2n do_call_2n 6; + assert0(Gtemp, 5); + print "call_vn"; + @call_vn do_call_vn 1 2 3; + assert0(Gtemp, 10); + print "call_vn2"; + @call_vn2 do_call_vn2 1 2 3 4 5 6 7; + assert0(Gtemp, 11); +#Endif; + + print "^ "; + print "rtrue"; + i = 2; + i = do_rtrue(); + assert0(i, 1); + i = 2; + print "rfalse"; + i = do_rfalse(); + assert0(i, 0); + i = do_ret_popped(); + assert0(i, 5, "return from ret_popped"); + + ! Computed calls + print "^ Computed call"; + i = 1; + n = do_computed_call1; +#Ifdef V4PLUS; @call_1s n -> i; #Ifnot; @call n -> i; #Endif; + assert0(i, 5); + @push 1; + @push do_computed_call2; +#Ifdef V4PLUS; @call_1s sp -> i; #Ifnot; @call sp -> i; #Endif; + assert0(i, 6); + @pull i; + assert0(i, 1); + ! TODO Spec14 describes @call_1s [i] syntax. Is that different than above? + + ! TODO test call_v's more extensively. call with variables (and stack?) + ! Make sure variables don't get changed! Call with too many args. + +#Ifdef V5PLUS; + print "^ check_arg_count"; + count = 0; do_check_check_arg_count(); + count = 1; do_check_check_arg_count(1); + count = 2; do_check_check_arg_count(2, 1); + count = 3; do_check_check_arg_count(3, 2, 1); + count = 4; do_check_check_arg_count(4, 3, 2, 1); + count = 5; do_check_check_arg_count(5, 4, 3, 2, 1); + count = 6; do_check_check_arg_count(6, 5, 4, 3, 2, 1); + count = 7; do_check_check_arg_count(7, 6, 5, 4, 3, 2, 1); +#Endif; + + rtrue; +]; ! end of test_subroutines + +#Ifdef V5PLUS; +[ do_check_check_arg_count a b c d e g h n; + for(n = 1: n <= count: n++) { + @check_arg_count n ?~bad; + } + p(); + for(: n <= 7: n++) { + @check_arg_count n ?bad; + } + p(); + a=b=c=d=e=h=g=0; ! make compiler happy + return; + + .bad; + f(); + + print "^[", Testnum, "] claimed argument ", n, " was "; + if(n <= count) + print "not given when it was.^"; + else + print "given when it was not.^"; + !@quit; +]; +#Endif; + +#Ifdef V5PLUS; +[ do_call_1n; + Gtemp = 1; +]; + +[ do_call_2n arg0; + assert0(arg0, 6); + Gtemp = 5; +]; + +[ do_call_vn a b c; + a=b; ! keep compiler quiet + assert0(c, 3); + Gtemp = 10; +]; + +[ do_call_vn2 a b c d e f g; + a=b=c=d=e=f; ! keep compiler quiet + assert0(g, 7); + Gtemp = 11; +]; +#Endif; + +#Ifdef V4PLUS; +[ do_call_1s; + Gtemp = 3; + @ret 5; +]; + +[ do_call_2s arg0; + assert0(arg0, 6); + @ret 5; +]; + +[ do_call_vs2 a b c d e f g; + a=b=c=d=e=f; ! keep compiler quiet + assert0(g, 7); + Gtemp = 9; + @ret 5; +]; + +#Endif; + +[ do_call i j k; ! called by call OR call_vs + assert0(i, 1); + assert0(j, 2); + assert0(k, 3); + Gtemp = 7; + @ret 5; +]; + +[ do_rtrue; + @rtrue; +]; + +[ do_rfalse; + @rfalse; +]; + +[ do_print_ret; + @print_ret "print_ret (should have newline after this)"; +]; + +[ do_ret_popped; + @push 5; + print "ret_popped"; + @ret_popped; +]; + +[ do_computed_call1; + @ret 5; +]; + +[ do_computed_call2; + @ret 6; +]; + +! ---- OBJECTS ---------------------------------- +Attribute attr1; +Attribute attr2; +Attribute attr3; +Attribute attr4; +Property propa 11; +Property propb 12; +Property propc 13; +Property propd 14; +Property prope 15; + +Object Obj1 "Test Object #1" + has attr1 attr2 + with propa 1, + propb 2, + propd 4 5 6; + +Object Obj2 "Test Object #2" Obj1 + has attr3 attr4 + with propa 2, + propd 4; + +Object Obj3 "Test Object #3" Obj1 + with propa 3, + propd 4; + +Object Obj4 "Test Object #4" Obj3 + with propa 4, + propd 4; + +#Ifdef V4PLUS; ! limit of 4-byte properties +! This object is only valid on standard 1.0 interpreters because of +! the 64 byte property. +Object Obj5 "" + with propa 1, + propb 1 2 3, + propc 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29, + prope 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32; +#Endif; + +Object Obj6 "test of an object with a shortname which is about as long as they get these days even though this one only uses the first alphabet which means this is destined to be a runon sentence since i am not using any punctuation or uppercase well i guess that means this is more boring than it need be but it makes the size calculation easier on me when i am writing this program and this mostly assumes your zmachine is capabable of outputting text with correct zscii decoding because after all if it could not then you probably would not even be running this program because it would definitely be too boring to run something which cannot even communicate its results to you when you really want to know what they are abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrs the end" + with prope 10000; + +[ test_objects skip; + print "Objects"; + @jz skip ?skipped; + print " skipped"; + rfalse; +.skipped; + print " [", Testnum+1, "]: "; + + ! TODO Copy tests from test.inf. + ! TODO Test object 0 + ! TODO object with no properties + ! TODO pass an optional desc - subs check_arg_count & pass desc to assert + ! LOTS OF STUFF!!! + print "get_parent"; + do_get_parent(Obj1, 0); + do_get_parent(Obj2, Obj1); + do_get_parent(Obj3, Obj1); + do_get_parent(Obj4, Obj3); + print "get_sibling"; + do_get_sibling(Obj1, 0); + do_get_sibling(Obj2, Obj3); + do_get_sibling(Obj3, 0); + do_get_sibling(Obj4, 0); + print "get_child"; + do_get_child(Obj1, Obj2); + do_get_child(Obj2, 0); + do_get_child(Obj3, Obj4); + do_get_child(Obj4, 0); + print "jin"; + do_jin(Obj1, Obj2, 0); + do_jin(Obj1, Obj1, 0); + do_jin(Obj2, Obj1, 1); + do_jin(Obj2, Obj3, 0); + do_jin(Obj3, Obj1, 1); + do_jin(Obj4, Obj3, 1); + do_jin(Obj4, Obj1, 0); ! must be *direct* parent + + print "^ test_attr"; + do_test_attr(Obj1, attr1, 1); + do_test_attr(Obj1, attr2, 1); + do_test_attr(Obj1, attr3, 0); + do_test_attr(Obj1, attr4, 0); + do_test_attr(Obj2, attr1, 0); + do_test_attr(Obj2, attr3, 1); + print "set_attr"; + do_set_attr(Obj1, attr3); + do_set_attr(Obj1, attr4); + do_set_attr(Obj1, attr1); ! test setting already set bit + do_set_attr(Obj1, attr2); + print "clear_attr"; + do_clear_attr(Obj2, attr3); + do_clear_attr(Obj2, attr4); + do_clear_attr(Obj2, attr1); ! test clearing already unset bit + do_clear_attr(Obj2, attr2); + print "set/clear/test_attr"; + do_big_attr_test(Obj3); + + print "^ get_next_prop"; + do_get_next_prop(Obj1, 0, propd); + do_get_next_prop(Obj1, propd, propb); + do_get_next_prop(Obj1, propb, propa); + do_get_next_prop(Obj1, propa, 0); + do_get_next_prop(Obj6, 0, prope); + do_get_next_prop(Obj6, prope, 0); + + ! TODO figure out how to get a one-byte property + ! Test stuffing a word into one-byte property. + print "get_prop_len/get_prop_addr"; + do_prop_len(Obj1, propa, 2); + do_prop_len(Obj1, propb, 2); + do_prop_len(Obj1, propd, 6); + do_prop_len(Obj6, prope, 2); + + print "^ get_prop"; + do_prop(Obj1, propa, 1); + do_prop(Obj1, propb, 2); + do_prop(Obj1, propc, 13); + do_prop(Obj2, propd, 4); + do_prop(Obj1, prope, 15); + do_prop(Obj6, propa, 11); + do_prop(Obj6, propb, 12); + do_prop(Obj6, propc, 13); + do_prop(Obj6, propd, 14); + do_prop(Obj6, prope, 10000); + + print "put_prop "; + @put_prop Obj1 propa 2; + do_prop(Obj1, propa, 2); + @put_prop Obj1 propb 4; + do_prop(Obj1, propb, 4); + @put_prop Obj2 propd 8; + do_prop(Obj2, propd, 8); + @put_prop Obj6 prope 5000; + do_prop(Obj6, prope, 5000); + ! Test other things didn't change + do_prop(Obj1, propc, 13); + do_prop(Obj1, prope, 15); + do_prop(Obj6, propa, 11); + do_prop(Obj6, propb, 12); + do_prop(Obj6, propc, 13); + do_prop(Obj6, propd, 14); + + print "^ remove"; + @remove_obj Obj3; + do_get_parent(Obj3, 0); + do_get_parent(Obj4, Obj3); ! confirm didn't change + print "insert"; + @insert_obj Obj4 Obj1; + do_get_parent(Obj4, Obj1); + do_get_sibling(Obj4, Obj2); + do_get_sibling(Obj2, 0); + do_get_child(Obj1, Obj4); + @insert_obj Obj3 Obj4; ! insert parentless object + do_get_child(Obj4, Obj3); + do_get_parent(Obj3, Obj4); + +#Ifdef V4PLUS; +! if(Standard >= 1) { + print "^ Spec1.0 length-64 props"; + do_get_next_prop(Obj5, 0, prope); + do_get_next_prop(Obj5, prope, propc); + do_get_next_prop(Obj5, propc, propb); + do_get_next_prop(Obj5, propb, propa); + do_get_next_prop(Obj5, propa, 0); + do_prop_len(Obj5, propa, 2); + do_prop_len(Obj5, propb, 6); + do_prop_len(Obj5, propc, 58); + do_prop_len(Obj5, prope, 64); + do_prop(Obj5, propa, 1); + @put_prop Obj5 propa 3; + do_prop(Obj5, propa, 3); +! } +#Endif; + + rtrue; +]; + +[ do_get_parent ch par i; + @get_parent ch -> i; + assert0(i, par); +]; + +[ do_get_sibling sib1 sib2 i; + @get_sibling sib1 -> i ?sib_label; + assert0(i, 0); ! make sure i only jumped if non-zero + .sib_label; + assert0(i, sib2); +]; + +[ do_get_child par ch i; + @get_child par -> i ?child_label; + assert0(i, 0); ! make sure i only jumped if non-zero + .child_label; + assert0(i, ch); +]; + +[ do_jin ch par expect; + @jin ch par ?is_in; + assert0(expect, 0); + return; + .is_in; + assert0(expect, 1); + return; +]; + +[ do_test_attr obj attr expect; + @test_attr obj attr ?test_attr_label; + assert0(expect, 0); ! make sure i only jumped if expect is non-zero + return; + .test_attr_label; + assert0(expect, 1); +]; + +! This does depend on test_attr working too. +[ do_set_attr obj attr; + @set_attr obj attr; + @test_attr obj attr ?set_attr_label; + assert0(0, 1); ! this should never happen! + return; + .set_attr_label; + p(); +]; + +! This does depend on test_attr working too. +[ do_clear_attr obj attr; + @clear_attr obj attr; + @test_attr obj attr ?~clear_attr_label; + assert0(1, 0); ! this should never happen! + return; + .clear_attr_label; + p(); +]; + +! Test that we can set/clear/test all attributes +[ do_big_attr_test obj i j k; +#Ifdef V4PLUS; + k = 48; +#Ifnot; + k = 32; +#Endif; + @store j 0; + for(i = 0: i < k: i++) { + @set_attr obj i; + @test_attr obj i ?good_set_label; + j++; ! number of failed sets + .good_set_label; + } + assert0(j,0, "set_attr/test_attr"); + @store j 0; + + for(i = 0: i < k: i++) { + @clear_attr obj i; + @test_attr obj i ?~good_clear_label; + j++; ! number of failed clears + .good_clear_label; + } + assert0(j,0, "clear_attr/test_attr"); + return; +]; + +[ do_prop obj prop expect i; + @get_prop obj prop -> i; Ga = obj; Gb = prop; + assert2(i, expect, "."); +]; + +[ do_get_next_prop obj prop next_prop i; + @get_next_prop obj prop -> i; Ga = obj; Gb = prop; + assert2(i, next_prop, "next"); +]; + +[ do_prop_len obj prop expect i j; + @get_prop_addr obj prop -> i; + @get_prop_len i -> j; Ga = obj; Gb = prop; + assert2(j, expect, ".#"); + !assert0(j, expect); +]; + +! ---- INDIRECT VARIABLES ---------------------------------- +! Indirect-able opcodes: inc, dec, inc_chk, dec_chk, store, pull, load +! Spec Version 1.1 (draft7): "an indirect reference to the stack +! pointer does not push or pull the top item of the stack - it is read +! or written in place." +! Based on my tests (see rec.arts.int-fiction 20031028), this seems to mean +! that, e.g., for load, you NEVER pop the stack, for all cases +! (a) load sp; (b) load [sp]; (c) i=0; load [i]; (d) sp=0; load [sp]; +[ test_indirect skip i; + print "Indirect Opcodes"; + @jz skip ?skipped; + print " skipped"; + rfalse; +.skipped; + print " [", Testnum+1, "]: "; + + ! We don't have 100 tests, but we skip a bunch of i's to allow + ! room for more tests. + for (i = 0: i < 100: i++) { + do_indirect(i); + } +]; + +! Run one indirect test. Push stuff onto stack, then do one command, +! see the result +! TODO add store, pull, inc, dec, inc_chk, dec_chk +! Overall rules: +! - Do NOT push/pop for "foo sp": write in place +! - DO pop for "foo [sp]". However, if top of stack is 0, only pop ONCE. +! - "bar = 0; foo [bar]" yields EXACTLY the same results as "foo sp" +! ("push 0; foo [sp] is also identical to "foo sp".) +[ do_indirect which result local2 spointer lpointer gpointer rpointer + top_of_stack which_str expectr expect1 expect2; + local2 = 51; + Gtemp = 61; + result = 71; + spointer = 0; ! stack + rpointer = 2; ! points to 'result' + lpointer = 3; ! local2 + gpointer = 21; ! '21' means 6th global, which is (hopefully!) Gtemp + expectr = 999; ! don't test 'result' unless we change this value + + @push 41; @push 42; @push 43; @push 44; @push 45; + switch (which) { + ! load -> result + 0: print "load"; + @load sp -> result; ! compiles as 'load 0 -> result' + expectr = 45; expect1 = 45; expect2 = 44; + which_str = "load sp -> result"; + 1: @load [spointer] -> result; + expectr = 45; expect1 = 45; expect2 = 44; + which_str = "load [spointer] -> result"; + 2: @push lpointer; @load [sp] -> result; + expectr = 51; expect1 = 45; expect2 = 44; + which_str = "load [sp=lpointer] -> result"; + 3: @push spointer; @load [sp] -> result; + expectr = 45; expect1 = 45; expect2 = 44; + which_str = "load [sp=spointer] -> result"; + + ! load -> sp + 4: @load sp -> sp; + expect1 = 45; expect2 = 45; + which_str = "load sp -> sp"; + 5: @push lpointer; @load [sp] -> sp; + expect1 = 51; expect2 = 45; + which_str = "load [sp=lpointer] -> sp"; + 6: @push spointer; @load [sp] -> sp; + expect1 = 45; expect2 = 45; + which_str = "load [sp=spointer] -> sp"; + + ! store + 10: print "store"; + @store sp 83; + expect1 = 83; expect2 = 44; + which_str = "store sp 83"; + 11: @store [spointer] 83; + expect1 = 83; expect2 = 44; + which_str = "store [spointer] 83"; + 12: @push spointer; @store [sp] 83; + expect1 = 83; expect2 = 44; + which_str = "store [sp=spointer] 83"; + + 13: @store [rpointer] 83; + expectr = 83; expect1 = 45; expect2 = 44; + which_str = "store [rpointer] 83"; + 14: @push rpointer; @store [sp] 83; + expectr = 83; expect1 = 45; expect2 = 44; + which_str = "store [sp=rpointer] 83"; + + 15: @store result sp; + expectr = 45; expect1 = 44; expect2 = 43; + which_str = "store result sp"; + 16: @store sp sp; + expect1 = 45; expect2 = 43; + which_str = "store sp sp"; + 17: @push spointer; @store [sp] sp; + expect1 = 45; expect2 = 43; + which_str = "store [sp=spointer] sp"; + + 18: @store [rpointer] sp; + expectr = 45; expect1 = 44; expect2 = 43; + which_str = "store [rpointer] sp"; + 19: @push rpointer; @store [sp] sp; + expectr = 45; expect1 = 44; expect2 = 43; + which_str = "store [sp=rpointer] sp"; + + ! pull + 20: print "^ pull"; + @pull result; + expectr = 45; expect1 = 44; expect2 = 43; + which_str = "pull result"; + 21: @pull [rpointer]; + expectr = 45; expect1 = 44; expect2 = 43; + which_str = "pull [rpointer]"; + 22: @push rpointer; @pull [sp]; + expectr = 45; expect1 = 44; expect2 = 43; + which_str = "pull [sp=rpointer]"; + + 23: @pull sp; + expect1 = 45; expect2 = 43; + which_str = "pull sp"; + 24: @push spointer; @pull [sp]; + expect1 = 45; expect2 = 43; + which_str = "pull [sp=spointer]"; + 25: @pull [spointer]; + expect1 = 45; expect2 = 43; + which_str = "pull [spointer]"; + + ! inc + 30: print "inc"; + @inc result; + expectr = 72; expect1 = 45; expect2 = 44; + which_str = "inc [rpointer]"; + 31: @inc [rpointer]; + expectr = 72; expect1 = 45; expect2 = 44; + which_str = "inc [rpointer]"; + 32: @push rpointer; @inc [sp]; + expectr = 72; expect1 = 45; expect2 = 44; + which_str = "inc [sp=rpointer]"; + + 33: @inc sp; + expect1 = 46; expect2 = 44; + which_str = "inc sp"; + 34: @inc [spointer]; + expect1 = 46; expect2 = 44; + which_str = "inc [spointer]"; + 35: @push spointer; @inc [sp]; + expect1 = 46; expect2 = 44; + which_str = "inc [sp=spointer]"; + + ! dec + 40: print "dec"; + @dec result; + expectr = 70; expect1 = 45; expect2 = 44; + which_str = "dec [rpointer]"; + 41: @dec [rpointer]; + expectr = 70; expect1 = 45; expect2 = 44; + which_str = "dec [rpointer]"; + 42: @push rpointer; @dec [sp]; + expectr = 70; expect1 = 45; expect2 = 44; + which_str = "dec [sp=rpointer]"; + + 43: @dec sp; + expect1 = 44; expect2 = 44; + which_str = "dec sp"; + 44: @dec [spointer]; + expect1 = 44; expect2 = 44; + which_str = "dec [spointer]"; + 45: @push spointer; @dec [sp]; + expect1 = 44; expect2 = 44; + which_str = "dec [sp=spointer]"; + + ! inc_chk + 50: print "^ inc_chk"; + which_str = "inc_chk [rpointer]"; + @inc_chk result 72 ?bad_indirect_inc; + expectr = 72; expect1 = 45; expect2 = 44; + 51: which_str = "inc_chk [rpointer]"; + @inc_chk [rpointer] 72 ?bad_indirect_inc; + expectr = 72; expect1 = 45; expect2 = 44; + 52: which_str = "inc_chk [sp=rpointer]"; + @push rpointer; @inc_chk [sp] 72 ?bad_indirect_inc; + expectr = 72; expect1 = 45; expect2 = 44; + + 53: which_str = "inc_chk sp"; + @inc_chk sp 46 ?bad_indirect_inc; + expect1 = 46; expect2 = 44; + 54: which_str = "inc_chk [spointer]"; + @inc_chk [spointer] 46 ?bad_indirect_inc; + expect1 = 46; expect2 = 44; + 55: which_str = "inc_chk [sp=spointer]"; + @push spointer; @inc_chk [sp] 46 ?bad_indirect_inc; + expect1 = 46; expect2 = 44; + + ! dec_chk + 60: print "dec_chk"; + which_str = "dec_chk [rpointer]"; + @dec_chk result 70 ?bad_indirect_inc; + expectr = 70; expect1 = 45; expect2 = 44; + 61: which_str = "dec_chk [rpointer]"; + @dec_chk [rpointer] 70 ?bad_indirect_inc; + expectr = 70; expect1 = 45; expect2 = 44; + 62: which_str = "dec_chk [sp=rpointer]"; + @push rpointer; @dec_chk [sp] 70 ?bad_indirect_inc; + expectr = 70; expect1 = 45; expect2 = 44; + + 63: which_str = "dec_chk sp"; + @dec_chk sp 44 ?bad_indirect_inc; + expect1 = 44; expect2 = 44; + 64: which_str = "dec_chk [spointer]"; + @dec_chk [spointer] 44 ?bad_indirect_inc; + expect1 = 44; expect2 = 44; + 65: which_str = "dec_chk [sp=spointer]"; + @push spointer; @dec_chk [sp] 44 ?bad_indirect_inc; + expect1 = 44; expect2 = 44; + + + default: rfalse; ! do nothing. + } + + ! Test results + @je expectr 999 ?skip_expectr; + assert0(result, expectr, which_str); + .skip_expectr; + @pull top_of_stack; + assert0(top_of_stack, expect1, which_str); + @pull top_of_stack; + assert0(top_of_stack, expect2, which_str); + !print which, " ", result, " ", top_of_stack, " "; + !print stack2, " ", stack3, " "; + !@print_paddr which_str; + !print "^"; + + ! TODO test "je sp a b c" to make sure not multi-popping stack, etc. + ! TODO Test globals here + + rtrue; + + ! If you got here, inc_chk/dec_chk broke + .bad_indirect_inc; + ! Assert will give silly numbers, but correct which_str + assert0(result, 123, which_str); + rfalse; +]; + +! ---- MISC stuff ---------------------------------- +[ test_misc skip i j; + print "Misc"; + @jz skip ?skipped; + print " skipped"; + rfalse; +.skipped; + print " [", Testnum+1, "]: "; + + print "test"; + @test $ffff $ffff ?~bad; p(); + @test $ffff 0 ?~bad; p(); + @test $1234 $4321 ?bad; p(); + jump good_test; + .bad; + f(); + print "^bad [", Testnum, "]!^"; + .good_test; + + ! TODO randomizer table from nitfol test? + print "random"; + @random -32000 -> i; + @random $100 -> i; + @random -32000 -> j; + @random $100 -> j; + assert0(i, j); + + ! I can't think of a way to test for a bad checksum... + print "verify"; + i = 0; + @verify ?good_verify; + i = 1; + .good_verify; + assert0(i, 0); + +#Ifdef V5PLUS; + print "piracy"; + i = 0; + @piracy ?good_piracy; + i = 1; + .good_piracy; + assert0(i, 0); +#Endif; + + rtrue; +]; + +! ---- Header ---------------------------------- + + +!Global standard; + +[ test_header skip flags i j; + print "Header"; + @jz skip ?skipped; + print " skipped"; + rfalse; +.skipped; + !print " [", Testnum+1, "]: "; + print " (No tests)"; +! standard = 0->50; + @loadb 0 50 -> i; + @loadb 0 51 -> j; + if(i || j) + print "^ standard ", i, ".", j, " "; + !print "interpreter ", 0->30, (char) 0->31; + @loadb 0 30 -> i; + print "^ interpreter ", i, " "; + @loadb 0 31 -> i; + @print_char i; + @loadb 0 30 -> i; + print " ("; say_platform(i); print ")"; + + for(i = 0: i < 2: i++) { + if(i == 0) + print "^ Flags on: "; + else + print "^ Flags off: "; + + @loadb 0 1 -> flags; +#Ifdef V4PLUS; + do_say_flags(i, flags & 1, "color"); + do_say_flags(i, flags & 2, "pictures"); + do_say_flags(i, flags & 4, "boldface"); + do_say_flags(i, flags & 8, "italic"); + do_say_flags(i, flags & 16, "fixed-space"); + do_say_flags(i, flags & 32, "sound"); + do_say_flags(i, flags & 128, "timer"); +#Ifnot; + do_say_flags(i, flags & 2, "time game"); + do_say_flags(i, flags & 4, "story file split"); + do_say_flags(i, flags & 16, "NO status"); + do_say_flags(i, flags & 32, "screen-splitting"); + do_say_flags(i, flags & 64, "variable-pitch-default"); +#Endif; + + !flags2 + @loadw 0 8 -> flags; + do_say_flags(i, flags & 1, "transcripting on"); + do_say_flags(i, flags & 2, "fixed-pitch on"); +#Ifdef V5PLUS; + ! TODO comment out v6 stuff if #version_number == 5 + do_say_flags(i, flags & 4, "redraw pending"); + do_say_flags(i, flags & 8, "using pictures"); + do_say_flags(i, flags & 16, "using undo"); + do_say_flags(i, flags & 32, "using mouse"); + do_say_flags(i, flags & 64, "using colors"); + do_say_flags(i, flags & 128, "using sound"); + do_say_flags(i, flags & 256, "using menus"); +#Endif; + } + +#Ifdef V4PLUS; + ! These are all width x height + print "^ Screen size: ", 0->33, "x", 0->32; +#Endif; +#Ifdef V5PLUS; + print "; in ", 0->38, "x", 0->39, " units: ", 0-->17, "x", 0-->18; + print "^ Default color: "; + say_color(0->45); print " on "; say_color(0->44); +#Endif; +! TODO v6 has font width/height switched + + @loadb 0 56 -> i; + if (i) { + print "^ User: "; + for(i = 56: i < 64: i++) + @loadb 0 i -> j; + @print_char j; + } +]; + +[ do_say_flags i cond text; + if((~~cond) == i) { + @print_paddr text; + print ", "; + } +]; + +#Ifdef V5PLUS; +[ say_color c; + switch(c) { + 0: print "current"; return; + 1: print "default"; return; + 2: print "black"; return; + 3: print "red"; return; + 4: print "green"; return; + 5: print "yellow"; return; + 6: print "blue"; return; + 7: print "magenta"; return; + 8: print "cyan"; return; + 9: print "white"; return; + 10: print "light grey"; return; + 11: print "medium grey"; return; + 12: print "dark grey"; return; + } + print "UNKNOWN"; +]; +#Endif; + +[ say_platform p; + switch(p) { + 1: print "DECSystem-20"; return; + 2: print "Apple IIe"; return; + 3: print "Macintosh"; return; + 4: print "Amiga"; return; + 5: print "Atari ST"; return; + 6: print "IBM PC"; return; + 7: print "Commodore 128"; return; + 8: print "Commodore 64"; return; + 9: print "Apple IIc"; return; + 10: print "Apple IIgs"; return; + 11: print "Tandy Color"; return; + } +]; + +! ---------------------------------------------------------------------- +! MAIN calls a bunch of subs. Each one runs a set of related tests. +!---------------------- MAIN + +[ Main; + + Testnum = 0; Passed = 0; Failed = 0; Print_Tests = 0; + @print "CZECH: the Comprehensive Z-machine Emulation CHecker, version "; + ! It's not entirely cool to be using print_paddr before testing. + ! So sue me. + @print_paddr TEST_VERSION; + @print "^Test numbers appear in [brackets].^"; + + pt(); + @print "^print works or you wouldn't be seeing this.^^"; + +! Standard = 0->50; +! if(0->50 || 0->51) +! print "Standard ", 0->50, ".", 0->51, " "; +! print "interpreter ", 0->30, (char) 0->31; + + ! If jumps don't work, we just give up. + + ! Now test sets of functionality. + ! Argument of 1 means SKIP tests, 0 means DON'T skip the tests + ! Note that there may be stack ops,e.g., in the arithmetic test, and + ! those won't get skipped just because you call test_stack with '1'. + ! MOST tests in earlier subs won't + ! depend on functionality tested in later subs, but simple + ! jump, stack, call, print functionality is needed for almost all tests. + test_jumps(0); @print "^"; + test_variables(0); @print "^"; + test_arithmetic(0); @print "^"; + test_logical(0); @print "^"; + test_memory(0); @print "^"; + test_subroutines(0); @print "^"; + test_objects(0); @print "^"; + test_indirect(0); @print "^"; + test_misc(0); @print "^"; + test_header(0); @print "^"; + test_print(0); @print "^"; + + print "^^Performed ", Testnum, " tests.^"; + print "Passed: ", Passed, ", Failed: ", Failed; + print ", Print tests: ", Print_Tests, "^"; + if (Passed + Failed + Print_Tests ~= Testnum) { + @print "^ERROR - Total number of tests should equal"; + @print " passed + failed + print tests!^^"; + } + print "Didn't crash: hooray!^"; + print "Last test: quit!^"; + @quit; + .bad_quit; + print "Quit didn't work!^"; + rtrue; +]; + +!! [Evin wrote that "Stock Inform has too many bugs to compile this." +!! but that seems not to be true with Inform 6.21.] + +! vim: tw=78 sw=3 diff --git a/tests/czech.z5 b/tests/czech.z5 new file mode 100644 index 0000000..e323a20 Binary files /dev/null and b/tests/czech.z5 differ diff --git a/tests/etude.z5 b/tests/etude.z5 new file mode 100644 index 0000000..9bb0e3f Binary files /dev/null and b/tests/etude.z5 differ diff --git a/tests/praxix.inf b/tests/praxix.inf new file mode 100644 index 0000000..c3e3afa --- /dev/null +++ b/tests/praxix.inf @@ -0,0 +1,2687 @@ +! Praxix - a Z-Machine unit test +! by Zarf and Dannii +! Public domain, but please share your changes so we can improve the tests + +! The indirect test is Copyright (C) 2003, Amir Karger + +! TODO: +! @encode_text +! @erase_line +! @get_cursor +! @set_font +! @call 0 +! @random - check it's a good distribution +! @print_table - check line breaks are only printed between lines +! Consider making this test suite non-interactive, and have another test suite for interactive tests +! Move too any tests which are manually confirmed by eye, so that all of Praxix can be summed up by "All tests passed" +! Maybe add tests for @loadw/@storew etc to check they are casting array+word correctly +! 1.1 spec unicode texts + +Constant Story "Praxix"; +Constant Headline "A Z-code interpreter unit test^"; +Release 1; + +! To compile this canonically, do "inform praxix.inf". No other +! options. + +Constant HDR_GAMERELEASE $02; ! word +Constant HDR_GAMEFLAGS $10; ! word +Constant HDR_GAMESERIAL $12; ! six ASCII characters +Constant HDR_SPECREVISION $32; ! word + +Array buffer -> 123; ! Buffer for parsing main line of input +Array parse buffer 63; ! Parse table mirroring it + +Global failures = 0; +Global total_failures = 0; + +[ Main ix; + ! deal with some compiler warnings + ix = PrintShortName; + + new_line; + Banner(); + new_line; + + LookSub(); + TestLoop(); + + print "^Goodbye.^"; +]; + +[ Keyboard; + while (true) { + print ">"; + buffer->0 = 120; + parse->0 = 15; + read buffer parse; + if (parse->1) + break; + } +]; + +[ Banner i; + if (Story ~= 0) { + #IfV5; style bold; #Endif; + print (string) Story; + #IfV5; style roman; #Endif; + } + if (Headline ~= 0) print ": ", (string) Headline; + print "Release ", (HDR_GAMERELEASE-->0) & $03ff, " / Serial number "; + for (i=0 : i<6 : i++) print (char) HDR_GAMESERIAL->i; + print " / Inform v"; inversion; + print ", compiler options "; + #Ifdef STRICT_MODE; + print "S"; + #Endif; ! STRICT_MODE + #Ifdef INFIX; + print "X"; + #Ifnot; + #Ifdef DEBUG; + print "D"; + #Endif; ! DEBUG + #Endif; ! INFIX + new_line; +]; + +[ Version; + ! Print the version number + print HDR_SPECREVISION->0, ".", HDR_SPECREVISION->1; +]; + +[ TestLoop wd paddr plen ix obj found; + while (true) { + new_line; + if (failures) { + print failures, " uncounted test failures!^^"; + failures = 0; + } + + Keyboard(); + wd = parse-->1; + + if (wd == 'quit' or 'q//') + return; + + found = nothing; + + objectloop (obj ofclass TestClass) { + paddr = obj.&name; + plen = obj.#name / WORDSIZE; + for (ix=0 : ixix == wd) { + found = obj; + break; + } + } + if (found) + break; + } + + if (~~found) { + print "I don't understand that command.^"; + continue; + } + + found.testfunc(); + } +]; + +Attribute meta; + +Class TestClass + with + short_name 0, + testfunc TestNothing, + fail_count; + +[ PrintShortName obj addr; + if (obj provides short_name && obj.short_name) { + print (string) obj.short_name; + rtrue; + } + if (obj ofclass TestClass) { + addr = obj.&name; + print (address) (addr-->0); + rtrue; + } + print (object) obj; +]; + +! Print out in base 16 a byte or word +[ Hex val byte nibble i; + print "$"; + for (i=0 : i<2 : i++) + { + @log_shift val (-8) -> byte; + @log_shift val (8) -> val; + if (byte == 0 && i == 0) + continue; + nibble = byte & $0F; + @log_shift byte (-4) -> byte; + if (byte <= 9) + print (char) (byte+'0'); + else + print (char) (byte-10+'A'); + if (nibble <= 9) + print (char) (nibble+'0'); + else + print (char) (nibble-10+'A'); + } +]; + +[ check val wanted; + if (val == wanted) { + print val; + rtrue; + } + failures++; + print val, " (should be ", wanted, " FAIL)"; + rfalse; +]; + +[ check_unspecified val wanted; + if (val == wanted) { + print val, " (Unspecified)"; + rtrue; + } + print val, " (Unspecified but ", wanted, " is suggested)"; + rfalse; +]; + +[ check_arr_3 arr v0 v1 v2; + if (arr->0 == v0 && arr->1 == v1 && arr->2 == v2) { + print v0, " ", v1, " ", v2; + rtrue; + } + failures++; + print arr->0, " ", arr->1, " ", arr->2; + print " (should be ", v0, " ", v1, " ", v2, " FAIL)"; + rfalse; +]; + +[ check_hex val wanted; + if (val == wanted) { + print (Hex) val; + rtrue; + } + failures++; + print (Hex) val, " (should be ", (Hex) wanted, " FAIL)"; + rfalse; +]; + +[ check_hex_unspecified val wanted; + if (val == wanted) { + print (Hex) val, " (Unspecified)"; + rtrue; + } + print (Hex) val, " (Unspecified but ", wanted, " is suggested)"; + rfalse; +]; + +[ check_hex_min val min; + if (val >= min) { + print (Hex) val; + rtrue; + } + failures++; + print (Hex) val, " (should be >= ", (Hex) min, " FAIL)"; + rfalse; +]; + +[ check_array test gold len func + ix testch goldch; + for (ix=0 : ixix; + testch = test->ix; + if (testch ~= goldch) { + func(goldch, ix); + check(testch, goldch); + new_line; + } + } +]; + +[ count_failures val; + print "^"; + if (failures) { + val = failures; + total_failures = total_failures + failures; + failures = 0; + print_ret val, " tests failed."; + } + else { + "Passed."; + } +]; + +TestClass LookAction + with name 'look' 'l//' 'help' '?//', + testfunc LookSub, + has meta; + +TestClass AllAction + with name 'all', + testfunc [ obj startfail res ix; + print "All tests:^"; + startfail = total_failures; + objectloop (obj ofclass TestClass) { + if (obj has meta) + continue; + + res = total_failures; + print "^"; + obj.testfunc(); + obj.fail_count = total_failures - res; + } + res = total_failures - startfail; + if (res == 0) { + "^All tests passed."; + } + else { + print "^", res, " tests failed overall: "; + ix = 0; + objectloop (obj ofclass TestClass) { + if (obj.fail_count) { + if (ix) + print ", "; + print (name) obj, " (", obj.fail_count, ")"; + ix++; + } + } + "."; + } + ], + has meta; + +[ TestNothing; + "Nothing happens."; +]; + +[ LookSub obj ix; + print "A voice booooms out: Welcome to the test chamber.^^"; + print "Type ~help~ to repeat this message, ~quit~ to exit, + ~all~ to run all tests, or one of the following test options: "; + + ix = 0; + objectloop (obj ofclass TestClass) { + if (obj has meta) + continue; + if (ix) print ", "; + print "~", (name) obj, "~"; + ix++; + } + print "."; + + print "^(Some tests check unspecified behaviour, and their results will be marked by (Unspecified).)^"; + + new_line; + if (total_failures) { + print "^", total_failures, " tests have failed so far in this run.^"; + } +]; + +Global testglobal; +Global testglobal2; + +TestClass OperandTest + with name 'operand', + testfunc [ ix val; + print "Basic operand values:^^"; + + testglobal = 1; + ix = 1; + val = (ix == testglobal); + print "(1==1)="; check(val, 1); print ", "; + val = (1 == testglobal); + print "(1==1)="; check(val, 1); print ", "; + val = (1 == ix); + print "(1==1)="; check(val, 1); print ", "; + @push 1; + val = 1; + @je 1 sp ?jump1; + val = 0; + .jump1; + print "(1==1)="; check(val, 1); print "^"; + + testglobal = -2; + ix = -2; + val = (ix == testglobal); + print "(-2==-2)="; check(val, 1); print ", "; + val = (-2 == testglobal); + print "(-2==-2)="; check(val, 1); print ", "; + val = (-2 == ix); + print "(-2==-2)="; check(val, 1); print ", "; + @push (-2); + val = 1; + @je (-2) sp ?jump2; + val = 0; + .jump2; + print "(-2==-2)="; check(val, 1); print "^"; + + count_failures(); + ]; + + +TestClass ArithTest + with name 'arith', + testfunc [ val; + print "Integer arithmetic:^^"; + + @add 2 2 val; + print "2+2="; check(val, 4); print ", "; + @add (-2) (-3) val; + print "-2+-3="; check(val, -5); print ", "; + @add 3 (-4) val; + print "3+-4="; check(val, -1); print ", "; + @add (-4) 5 val; + print "-4+5="; check(val, 1); print ", "; + @add $7FFF $7FFE val; + print "$7FFF+$7FFE="; check(val, -3); print ", "; + @add $8000 $8000 val; + print "$8000+$8000="; check(val, 0); print "^"; + testglobal = 6; testglobal2 = 8; + @add testglobal testglobal2 val; + print "Globals 6+8="; check(val, 14); print ", "; + testglobal = $7FFE; testglobal2 = $7FFD; + @add testglobal testglobal2 val; + print "$7FFE+$7FFD="; check(val, -5); print "^"; + + @sub 2 2 val; + print "2-2="; check(val, 0); print ", "; + @sub (-2) 3 val; + print "-2-3="; check(val, -5); print ", "; + @sub 3 4 val; + print "3-4="; check(val, -1); print ", "; + @sub (-4) (-5) val; + print "-4-(-5)="; check(val, 1); print ", "; + @sub $7FFF $7FFE val; + print "$7FFF-$7FFE="; check(val, 1); print ", "; + @sub $8000 $8001 val; + print "$8000-$8001="; check(val, -1); print ", "; + @sub $7FFF $8001 val; + print "$7FFF-$8001="; check(val, -2); print "^"; + testglobal = 6; testglobal2 = 8; + @sub testglobal testglobal2 val; + print "Globals 6-8="; check(val, -2); print ", "; + testglobal = $7FFD; testglobal2 = $7FFE; + @sub testglobal testglobal2 val; + print "$7FFD-$7FFE="; check(val, -1); print "^"; + + @mul 2 2 val; + print "2*2="; check(val, 4); print ", "; + @mul (-2) (-3) val; + print "-2*-3="; check(val, 6); print ", "; + @mul 3 (-4) val; + print "3*-4="; check(val, -12); print ", "; + @mul (-4) 5 val; + print "-4*5="; check(val, -20); print ", "; + @mul $100 $100 val; + print "$100*$100 (trunc)="; check(val, 0); print ", "; + @mul 311 373 val; + print "311*373 (trunc)="; check_hex(val, -15069); print "^"; + testglobal = -6; testglobal2 = -8; + @mul testglobal testglobal2 val; + print "Globals -6*-8="; check(val, 48); print ", "; + testglobal = -311; testglobal2 = 373; + @mul testglobal testglobal2 val; + print "Globals -311*373="; check(val, 15069); print "^"; + + @div 12 3 val; + print "12/3="; check(val, 4); print ", "; + @div 11 2 val; + print "11/2="; check(val, 5); print ", "; + @div (-11) 2 val; + print "-11/2="; check(val, -5); print ", "; + @div 11 (-2) val; + print "11/-2="; check(val, -5); print ", "; + @div (-11) (-2) val; + print "-11/-2="; check(val, 5); print ", "; + @div $7fff 2 val; + print "$7fff/2="; check_hex(val, $3fff); print ", "; + @div $7fff (-2) val; + print "$7fff/-2="; check_hex(val, -$3fff); print ", "; + @div (-$7fff) 2 val; + print "-$7fff/2="; check_hex(val, -$3fff); print ", "; + @div (-$7fff) (-2) val; + print "-$7fff/-2="; check_hex(val, $3fff); print ", "; + @div $8000 2 val; + print "$8000/2="; check_hex(val, $C000); print ", "; + @div $8000 (-2) val; + print "$8000/(-2)="; check_hex(val, $4000); print ", "; + @div $8000 1 val; + print "$8000/1="; check_hex(val, $8000); print "^"; + + testglobal = -48; testglobal2 = -8; + @div testglobal testglobal2 val; + print "Globals -48/-8="; check(val, 6); print ", "; + testglobal = 48; testglobal2 = 7; + @div testglobal testglobal2 val; + print "48/7="; check(val, 6); print ", "; + testglobal = 48; testglobal2 = -7; + @div testglobal testglobal2 val; + print "48/-7="; check(val, -6); print ", "; + testglobal = -48; testglobal2 = 7; + @div testglobal testglobal2 val; + print "-48/7="; check(val, -6); print ", "; + testglobal = -48; testglobal2 = -7; + @div testglobal testglobal2 val; + print "-48/-7="; check(val, 6); print "^"; + + @mod 12 3 val; + print "12%3="; check(val, 0); print ", "; + @mod 13 5 val; + print "13%5="; check(val, 3); print ", "; + @mod (-13) 5 val; + print "-13%5="; check(val, -3); print ", "; + @mod 13 (-5) val; + print "13%-5="; check(val, 3); print ", "; + @mod (-13) (-5) val; + print "-13%-5="; check(val, -3); print ", "; + @mod $7fff 11 val; + print "$7fff%11="; check(val, 9); print ", "; + @mod (-$7fff) 11 val; + print "-$7fff%11="; check(val, -9); print ", "; + @mod $7fff (-11) val; + print "$7fff%-11="; check(val, 9); print ", "; + @mod (-$7fff) (-11) val; + print "-$7fff%-11="; check(val, -9); print ", "; + @mod $8000 7 val; + print "$8000%7="; check(val, -1); print ", "; + @mod $8000 (-7) val; + print "$8000%-7="; check(val, -1); print ", "; + @mod $8000 2 val; + print "$8000%2="; check(val, 0); print ", "; + @mod $8000 (-2) val; + print "$8000%-2="; check(val, 0); print ", "; + @mod $8000 1 val; + print "$8000%1="; check(val, 0); print "^"; + + testglobal = 49; testglobal2 = 8; + @mod testglobal testglobal2 val; + print "Globals 49%8="; check(val, 1); print ", "; + testglobal = 49; testglobal2 = -8; + @mod testglobal testglobal2 val; + print "49%-8="; check(val, 1); print ", "; + testglobal = -49; testglobal2 = 8; + @mod testglobal testglobal2 val; + print "-49%8="; check(val, -1); print ", "; + testglobal = -49; testglobal2 = -8; + @mod testglobal testglobal2 val; + print "-49%-8="; check(val, -1); print "^"; + + count_failures(); + ]; + +TestClass CompoundArithTest + with name 'comarith' 'comparith', + testfunc [ val xloc yloc zloc; + print "Compound arithmetic expressions:^^"; + + testglobal = 7; + yloc = 2; + zloc = -4; + val = (testglobal + yloc) * zloc; + print "(7+2)*-4="; check(val, -36); print "^"; + + xloc = $7FFF; + yloc = 2; + zloc = 16; + val = (xloc + yloc) / zloc; + print "($7FFF+2)/16="; check(val, -$7FF); print "^"; + + xloc = -$7FFF; + yloc = -2; + zloc = 16; + val = (xloc + yloc) / zloc; + print "(-$7FFF+-2)/16="; check(val, $7FF); print "^"; + + xloc = -26103; + yloc = -32647; + val = (xloc + yloc) / 9; + print "(-26103+-32647)/9="; check(val, 754); print "^"; + + xloc = -$7FFF; + yloc = 2; + zloc = 16; + val = (xloc - yloc) / zloc; + print "(-$7FFF-2)/16="; check(val, $7FF); print "^"; + + xloc = $7FFF; + yloc = -2; + zloc = 16; + val = (xloc - yloc) / zloc; + print "($7FFF--2)/16="; check(val, -$7FF); print "^"; + + xloc = -26103; + yloc = 32647; + val = (xloc - yloc) / 9; + print "(-26103-32647)/9="; check(val, 754); print "^"; + + xloc = $100; + yloc = $100; + zloc = 16; + val = (xloc * yloc) / zloc + 1; + print "($100*$100)/16+1="; check(val, 1); print "^"; + + xloc = 311; + yloc = 373; + zloc = 16; + val = (xloc * yloc) / zloc; + print "(311*373)/16="; check(val, -941); print "^"; + + xloc = 311; + zloc = 16; + val = (xloc * -373) / zloc; + print "(311*-373)/16="; check(val, 941); print "^"; + + yloc = 373; + val = (111 * yloc) / 16; + print "(111*373)/16="; check(val, -1508); print "^"; + + yloc = -373; + val = (111 * yloc) / 16; + print "(111*-373)/16="; check(val, 1508); print "^"; + + count_failures(); + ]; + +TestClass BitwiseTest + with name 'bitwise' 'bits' 'bit', + testfunc [ val; + print "Bitwise arithmetic:^^"; + + @and 0 0 val; + print "0&0="; check_hex(val, 0); print ", "; + @and $FFFF 0 val; + print "$FFFF&0="; check_hex(val, 0); print ", "; + @and $FFFF $FFFF val; + print "$FFFF&$FFFF="; check_hex(val, $FFFF); print ", "; + @and $013F $F310 val; + print "$013F&$F310="; check_hex(val, $0110); print ", "; + @and $F731 $137F val; + print "$F731&$137F="; check_hex(val, $1331); print ", "; + @and $35 $56 val; + print "$35&56="; check_hex(val, $14); print "^"; + + @or 0 0 val; + print "0|0="; check_hex(val, 0); print ", "; + @or $FFFF 0 val; + print "$FFFF|0="; check_hex(val, $FFFF); print ", "; + @or $FFFF $FFFF val; + print "$FFFF|$FFFF="; check_hex(val, $FFFF); print ", "; + @or $3700 $0012 val; + print "$3700|$0012="; check_hex(val, $3712); print ", "; + @or $35 $56 val; + print "$35|56="; check_hex(val, $77); print "^"; + + @not 0 val; + print "!0="; check_hex(val, $FFFF); print ", "; + @not 1 val; + print "!1="; check_hex(val, $FFFE); print ", "; + @not $F val; + print "!$F="; check_hex(val, $FFF0); print ", "; + @not $7FFF val; + print "!$7FFF="; check_hex(val, $8000); print ", "; + @not $8000 val; + print "!$8000="; check_hex(val, $7FFF); print ", "; + @not $FFFD val; + print "!$FFFD="; check_hex(val, $2); print "^"; + + count_failures(); + ]; + +TestClass ShiftTest + with name 'shift', + testfunc [ val res ix; + print "Bit shifts:^^"; + + @log_shift $11 0 val; + print "$11u<<0="; check_hex(val, $11); print ", "; + @log_shift $11 1 val; + print "$11u<<1="; check_hex(val, $22); print ", "; + @log_shift $11 4 val; + print "$11u<<4="; check_hex(val, $110); print ", "; + @log_shift $11 10 val; + print "$11u<<10="; check_hex(val, $4400); print ", "; + @log_shift $11 15 val; + print "$11u<<15="; check_hex(val, $8000); print ", "; + @log_shift $11 16 val; + print "$11u<<16="; check_hex_unspecified(val, 0); print ", "; + @log_shift (-2) 0 val; + print "-2u<<0="; check(val, -2); print ", "; + @log_shift (-2) 1 val; + print "-2u<<1="; check(val, -4); print ", "; + @log_shift (-2) 7 val; + print "-2u<<7="; check(val, -256); print ", "; + @log_shift (-2) 15 val; + print "-2u<<15="; check(val, 0); print "^"; + + testglobal = 1; + res = 1; + for (ix=0 : ix<16 : ix++) { + @log_shift testglobal ix val; + print "1u<<", ix, "="; check_hex(val, res); print ", "; + res = res+res; + } + @log_shift testglobal ix val; + print "1u<<", ix, "="; check_hex_unspecified(val, 0); print "^"; + + @log_shift $4001 (0) val; + print "$4001u>>-0="; check_hex(val, $4001); print ", "; + @log_shift $4001 (-1) val; + print "$4001u>>-1="; check_hex(val, $2000); print ", "; + @log_shift $4001 (-6) val; + print "$4001u>>-6="; check_hex(val, $100); print ", "; + @log_shift $4001 (-11) val; + print "$4001u>>-11="; check_hex(val, $8); print ", "; + @log_shift $4001 (-15) val; + print "$4001u>>-15="; check_hex(val, $0); print ", "; + @log_shift $4001 (-16) val; + print "$4001u>>-16="; check_hex_unspecified(val, $0); print "^"; + + @log_shift $7FFF (0) val; + print "$7FFFu>>-0="; check_hex(val, $7FFF); print ", "; + @log_shift $7FFF (-1) val; + print "$7FFFu>>-1="; check_hex(val, $3FFF); print ", "; + @log_shift $7FFF (-2) val; + print "$7FFFu>>-2="; check_hex(val, $1FFF); print ", "; + @log_shift $7FFF (-6) val; + print "$7FFFu>>-6="; check_hex(val, $1FF); print ", "; + @log_shift $7FFF (-12) val; + print "$7FFFu>>-12="; check_hex(val, $7); print ", "; + @log_shift $7FFF (-15) val; + print "$7FFFu>>-15="; check_hex(val, $0); print ", "; + @log_shift $7FFF (-16) val; + print "$7FFFu>>-16="; check_hex_unspecified(val, $0); print "^"; + + @log_shift (-1) (0) val; + print "-1u>>-0="; check_hex(val, -1); print ", "; + @log_shift (-1) (-1) val; + print "-1u>>-1="; check_hex(val, $7FFF); print ", "; + @log_shift (-1) (-2) val; + print "-1u>>-2="; check_hex(val, $3FFF); print ", "; + @log_shift (-1) (-6) val; + print "-1u>>-6="; check_hex(val, $3FF); print ", "; + @log_shift (-1) (-12) val; + print "-1u>>-12="; check_hex(val, $F); print ", "; + @log_shift (-1) (-13) val; + print "-1u>>-13="; check_hex(val, $7); print ", "; + @log_shift (-1) (-15) val; + print "-1u>>-15="; check_hex(val, $1); print ", "; + @log_shift (-1) (-16) val; + print "-1u>>-16="; check_hex_unspecified(val, $0); print ", "; + @log_shift (-1) (-17) val; + print "-1u>>-17="; check_hex_unspecified(val, $0); print "^"; + + testglobal = -1; + res = $7fff; + for (ix=-1 : ix>-16 : ix--) { + @log_shift testglobal ix val; + print "-1u>>", ix, "="; check_hex(val, res); print ", "; + res = res / 2; + } + @log_shift testglobal ix val; + print "-1u>>", ix, "="; check_hex_unspecified(val, 0); print "^"; + + @art_shift $11 0 val; + print "$11s<<0="; check_hex(val, $11); print ", "; + @art_shift $11 1 val; + print "$11s<<1="; check_hex(val, $22); print ", "; + @art_shift $11 4 val; + print "$11s<<4="; check_hex(val, $110); print ", "; + @art_shift $11 10 val; + print "$11s<<10="; check_hex(val, $4400); print ", "; + @art_shift $11 15 val; + print "$11s<<15="; check_hex(val, $8000); print ", "; + @art_shift $11 16 val; + print "$11s<<16="; check_hex_unspecified(val, 0); print ", "; + @art_shift (-2) 0 val; + print "-2s<<0="; check(val, -2); print ", "; + @art_shift (-2) 1 val; + print "-2s<<1="; check(val, -4); print ", "; + @art_shift (-2) 7 val; + print "-2s<<7="; check(val, -256); print ", "; + @art_shift (-2) 15 val; + print "-2s<<15="; check(val, 0); print "^"; + + testglobal = 1; + res = 1; + for (ix=0 : ix<16 : ix++) { + @art_shift testglobal ix val; + print "1s<<", ix, "="; check_hex(val, res); print ", "; + res = res+res; + } + @art_shift testglobal ix val; + print "1s<<", ix, "="; check_hex_unspecified(val, 0); print "^"; + + @art_shift $4001 (0) val; + print "$4001s>>-0="; check_hex(val, $4001); print ", "; + @art_shift $4001 (-1) val; + print "$4001s>>-1="; check_hex(val, $2000); print ", "; + @art_shift $4001 (-6) val; + print "$4001s>>-6="; check_hex(val, $100); print ", "; + @art_shift $4001 (-11) val; + print "$4001s>>-11="; check_hex(val, $8); print ", "; + @art_shift $4001 (-15) val; + print "$4001s>>-15="; check_hex(val, $0); print ", "; + @art_shift $4001 (-16) val; + print "$4001s>>-16="; check_hex_unspecified(val, $0); print "^"; + + @art_shift $7FFF (0) val; + print "$7FFFs>>-0="; check_hex(val, $7FFF); print ", "; + @art_shift $7FFF (-1) val; + print "$7FFFs>>-1="; check_hex(val, $3FFF); print ", "; + @art_shift $7FFF (-2) val; + print "$7FFFs>>-2="; check_hex(val, $1FFF); print ", "; + @art_shift $7FFF (-6) val; + print "$7FFFs>>-6="; check_hex(val, $1FF); print ", "; + @art_shift $7FFF (-12) val; + print "$7FFFs>>-12="; check_hex(val, $7); print ", "; + @art_shift $7FFF (-13) val; + print "$7FFFs>>-13="; check_hex(val, $3); print ", "; + @art_shift $7FFF (-14) val; + print "$7FFFs>>-14="; check_hex(val, $1); print ", "; + @art_shift $7FFF (-15) val; + print "$7FFFs>>-15="; check_hex(val, $0); print ", "; + @art_shift $7FFF (-16) val; + print "$7FFFs>>-16="; check_hex_unspecified(val, $0); print "^"; + + @art_shift (-1) (0) val; + print "-1s>>-0="; check(val, -1); print ", "; + @art_shift (-1) (-1) val; + print "-1s>>-1="; check(val, -1); print ", "; + @art_shift (-1) (-15) val; + print "-1s>>-15="; check(val, -1); print ", "; + @art_shift (-1) (-16) val; + print "-1s>>-16="; check_hex_unspecified(val, -1); print ", "; + @art_shift (-1) (-17) val; + print "-1s>>-17="; check_hex_unspecified(val, -1); print "^"; + + @art_shift (-1000) (0) val; + print "-1000s>>-0="; check(val, -1000); print ", "; + @art_shift (-1000) (-1) val; + print "-1000s>>-1="; check(val, -500); print ", "; + @art_shift (-1000) (-2) val; + print "-1000s>>-2="; check(val, -250); print ", "; + @art_shift (-1000) (-4) val; + print "-1000s>>-4="; check(val, -63); print ", "; + @art_shift (-1000) (-6) val; + print "-1000s>>-6="; check(val, -16); print ", "; + @art_shift (-1000) (-9) val; + print "-1000s>>-9="; check(val, -2); print ", "; + @art_shift (-1000) (-15) val; + print "-1000s>>-15="; check(val, -1); print ", "; + @art_shift (-1000) (-16) val; + print "-1000s>>-16="; check_hex_unspecified(val, -1); print ", "; + @art_shift (-1000) (-17) val; + print "-1000s>>-17="; check_hex_unspecified(val, -1); print "^"; + + testglobal = -1; + for (ix=0 : ix>-16 : ix--) { + @art_shift testglobal ix val; + print "-1s>>", ix, "="; check(val, -1); print ", "; + } + @art_shift testglobal ix val; + print "-1s>>", ix, "="; check_hex_unspecified(val, -1); print "^"; + + count_failures(); + ]; + +TestClass IncrementTest + with name 'inc' 'dec' 'increment' 'decrement', + testfunc [ val; + print "Increment/decrement:^^"; + + val = 0; + @inc val; + print "0++="; check(val, 1); print ", "; + val = 1; + @inc val; + print "1++="; check(val, 2); print ", "; + val = -1; + @inc val; + print "-1++="; check(val, 0); print ", "; + val = -10; + @inc val; + print "-10++="; check(val, -9); print ", "; + val = $7FFF; + @inc val; + print "$7FFF++="; check_hex(val, $8000); print ", "; + val = $C000; + @inc val; + print "$C000++="; check_hex(val, $C001); print "^"; + + testglobal = 0; + @inc testglobal; + print "0++="; check(testglobal, 1); print ", "; + testglobal = 1; + @inc testglobal; + print "1++="; check(testglobal, 2); print ", "; + testglobal = -1; + @inc testglobal; + print "-1++="; check(testglobal, 0); print ", "; + testglobal = -10; + @inc testglobal; + print "-10++="; check(testglobal, -9); print ", "; + testglobal = $7FFF; + @inc testglobal; + print "$7FFF++="; check_hex(testglobal, $8000); print ", "; + testglobal = $C000; + @inc testglobal; + print "$C000++="; check_hex(testglobal, $C001); print "^"; + + @push 0; + @inc sp; + @pull val; + print "0++="; check(val, 1); print ", "; + @push 1; + @inc sp; + @pull val; + print "1++="; check(val, 2); print ", "; + @push -1; + @inc sp; + @pull val; + print "-1++="; check(val, 0); print ", "; + @push -10; + @inc sp; + @pull val; + print "-10++="; check(val, -9); print ", "; + @push $7FFF; + @inc sp; + @pull val; + print "$7FFF++="; check_hex(val, $8000); print ", "; + @push $C000; + @inc sp; + @pull val; + print "$C000++="; check_hex(val, $C001); print "^"; + + val = 0; + @dec val; + print "0--="; check(val, -1); print ", "; + val = 1; + @dec val; + print "1--="; check(val, 0); print ", "; + val = -1; + @dec val; + print "-1--="; check(val, -2); print ", "; + val = 10; + @dec val; + print "10--="; check(val, 9); print ", "; + val = $8000; + @dec val; + print "$8000--="; check_hex(val, $7FFF); print ", "; + val = $C000; + @dec val; + print "$C000--="; check_hex(val, $BFFF); print "^"; + + testglobal = 0; + @dec testglobal; + print "0--="; check(testglobal, -1); print ", "; + testglobal = 1; + @dec testglobal; + print "1--="; check(testglobal, 0); print ", "; + testglobal = -1; + @dec testglobal; + print "-1--="; check(testglobal, -2); print ", "; + testglobal = 10; + @dec testglobal; + print "10--="; check(testglobal, 9); print ", "; + testglobal = $8000; + @dec testglobal; + print "$8000--="; check_hex(testglobal, $7FFF); print ", "; + testglobal = $C000; + @dec testglobal; + print "$C000--="; check_hex(testglobal, $BFFF); print "^"; + + @push 0; + @dec sp; + @pull val; + print "0--="; check(val, -1); print ", "; + @push 1; + @dec sp; + @pull val; + print "1--="; check(val, 0); print ", "; + @push -1; + @dec sp; + @pull val; + print "-1--="; check(val, -2); print ", "; + @push 10; + @dec sp; + @pull val; + print "10--="; check(val, 9); print ", "; + @push $8000; + @dec sp; + @pull val; + print "$8000--="; check_hex(val, $7FFF); print ", "; + @push $C000; + @dec sp; + @pull val; + print "$C000--="; check_hex(val, $BFFF); print "^"; + + count_failures(); + ]; + +TestClass IncrementBranchTest + with name 'incchk' 'decchk' 'inccheck' 'deccheck', + testfunc [ val res; + print "Increment/decrement and branch:^^"; + + res = 0; + val = 1; + @inc_chk res 0 ?jump1a; + val = 0; + .jump1a; + print "++0="; check(res, 1); print ","; check(val, 1); print ", "; + + res = 1; + val = 1; + @inc_chk res 0 ?jump1b; + val = 0; + .jump1b; + print "++1="; check(res, 2); print ","; check(val, 1); print ", "; + + res = -1; + val = 1; + @inc_chk res 0 ?jump1c; + val = 0; + .jump1c; + print "++-1="; check(res, 0); print ","; check(val, 0); print ", "; + + res = 100; + val = 1; + @inc_chk res 0 ?jump1d; + val = 0; + .jump1d; + print "++100="; check(res, 101); print ","; check(val, 1); print ", "; + + res = -10; + val = 1; + @inc_chk res 0 ?jump1e; + val = 0; + .jump1e; + print "++-10="; check(res, -9); print ","; check(val, 0); print ", "; + + res = $7FFF; + val = 1; + @inc_chk res 0 ?jump1f; + val = 0; + .jump1f; + print "++$7FFF="; check_hex(res, $8000); print ","; check(val, 0); print ", "; + + res = $C000; + val = 1; + @inc_chk res 0 ?jump1g; + val = 0; + .jump1g; + print "++$C000="; check_hex(res, $C001); print ","; check(val, 0); print "^"; + + + testglobal2 = 0; + testglobal = 1; + @inc_chk testglobal2 0 ?jump2a; + testglobal = 0; + .jump2a; + print "++0="; check(testglobal2, 1); print ","; check(testglobal, 1); print ", "; + + testglobal2 = 1; + testglobal = 1; + @inc_chk testglobal2 0 ?jump2b; + testglobal = 0; + .jump2b; + print "++1="; check(testglobal2, 2); print ","; check(testglobal, 1); print ", "; + + testglobal2 = -1; + testglobal = 1; + @inc_chk testglobal2 0 ?jump2c; + testglobal = 0; + .jump2c; + print "++-1="; check(testglobal2, 0); print ","; check(testglobal, 0); print ", "; + + testglobal2 = 100; + testglobal = 1; + @inc_chk testglobal2 0 ?jump2d; + testglobal = 0; + .jump2d; + print "++100="; check(testglobal2, 101); print ","; check(testglobal, 1); print ", "; + + testglobal2 = -10; + testglobal = 1; + @inc_chk testglobal2 0 ?jump2e; + testglobal = 0; + .jump2e; + print "++-10="; check(testglobal2, -9); print ","; check(testglobal, 0); print ", "; + + testglobal2 = $7FFF; + testglobal = 1; + @inc_chk testglobal2 0 ?jump2f; + testglobal = 0; + .jump2f; + print "++$7FFF="; check_hex(testglobal2, $8000); print ","; check(testglobal, 0); print ", "; + + testglobal2 = $C000; + testglobal = 1; + @inc_chk testglobal2 0 ?jump2g; + testglobal = 0; + .jump2g; + print "++$C000="; check_hex(testglobal2, $C001); print ","; check(testglobal, 0); print "^"; + + + @push 0; + val = 1; + @inc_chk sp 0 ?jump3a; + val = 0; + .jump3a; + @pull res; + print "++0="; check(res, 1); print ","; check(val, 1); print ", "; + + @push 1; + val = 1; + @inc_chk sp 0 ?jump3b; + val = 0; + .jump3b; + @pull res; + print "++1="; check(res, 2); print ","; check(val, 1); print ", "; + + @push -1; + val = 1; + @inc_chk sp 0 ?jump3c; + val = 0; + .jump3c; + @pull res; + print "++-1="; check(res, 0); print ","; check(val, 0); print ", "; + + @push 100; + val = 1; + @inc_chk sp 0 ?jump3d; + val = 0; + .jump3d; + @pull res; + print "++100="; check(res, 101); print ","; check(val, 1); print ", "; + + @push -10; + val = 1; + @inc_chk sp 0 ?jump3e; + val = 0; + .jump3e; + @pull res; + print "++-10="; check(res, -9); print ","; check(val, 0); print ", "; + + @push $7FFF; + val = 1; + @inc_chk sp 0 ?jump3f; + val = 0; + .jump3f; + @pull res; + print "++$7FFF="; check_hex(res, $8000); print ","; check(val, 0); print ", "; + + @push $C000; + val = 1; + @inc_chk sp 0 ?jump3g; + val = 0; + .jump3g; + @pull res; + print "++$C000="; check_hex(res, $C001); print ","; check(val, 0); print "^"; + + + res = 0; + val = 1; + @dec_chk res 0 ?jump4a; + val = 0; + .jump4a; + print "--0="; check(res, -1); print ","; check(val, 1); print ", "; + + res = 1; + val = 1; + @dec_chk res 0 ?jump4b; + val = 0; + .jump4b; + print "--1="; check(res, 0); print ","; check(val, 0); print ", "; + + res = -1; + val = 1; + @dec_chk res 0 ?jump4c; + val = 0; + .jump4c; + print "---1="; check(res, -2); print ","; check(val, 1); print ", "; + + res = 100; + val = 1; + @dec_chk res 0 ?jump4d; + val = 0; + .jump4d; + print "--100="; check(res, 99); print ","; check(val, 0); print ", "; + + res = -10; + val = 1; + @dec_chk res 0 ?jump4e; + val = 0; + .jump4e; + print "---10="; check(res, -11); print ","; check(val, 1); print ", "; + + res = $8000; + val = 1; + @dec_chk res 0 ?jump4f; + val = 0; + .jump4f; + print "--$8000="; check_hex(res, $7FFF); print ","; check(val, 0); print ", "; + + res = $C000; + val = 1; + @dec_chk res 0 ?jump4g; + val = 0; + .jump4g; + print "--$C000="; check_hex(res, $BFFF); print ","; check(val, 1); print "^"; + + + testglobal2 = 0; + testglobal = 1; + @dec_chk testglobal2 0 ?jump5a; + testglobal = 0; + .jump5a; + print "--0="; check(testglobal2, -1); print ","; check(testglobal, 1); print ", "; + + testglobal2 = 1; + testglobal = 1; + @dec_chk testglobal2 0 ?jump5b; + testglobal = 0; + .jump5b; + print "--1="; check(testglobal2, 0); print ","; check(testglobal, 0); print ", "; + + testglobal2 = -1; + testglobal = 1; + @dec_chk testglobal2 0 ?jump5c; + testglobal = 0; + .jump5c; + print "---1="; check(testglobal2, -2); print ","; check(testglobal, 1); print ", "; + + testglobal2 = 100; + testglobal = 1; + @dec_chk testglobal2 0 ?jump5d; + testglobal = 0; + .jump5d; + print "--100="; check(testglobal2, 99); print ","; check(testglobal, 0); print ", "; + + testglobal2 = -10; + testglobal = 1; + @dec_chk testglobal2 0 ?jump5e; + testglobal = 0; + .jump5e; + print "---10="; check(testglobal2, -11); print ","; check(testglobal, 1); print ", "; + + testglobal2 = $8000; + testglobal = 1; + @dec_chk testglobal2 0 ?jump5f; + testglobal = 0; + .jump5f; + print "--$8000="; check_hex(testglobal2, $7FFF); print ","; check(testglobal, 0); print ", "; + + testglobal2 = $C000; + testglobal = 1; + @dec_chk testglobal2 0 ?jump5g; + testglobal = 0; + .jump5g; + print "--$C000="; check_hex(testglobal2, $BFFF); print ","; check(testglobal, 1); print "^"; + + + @push 0; + val = 1; + @dec_chk sp 0 ?jump6a; + val = 0; + .jump6a; + @pull res; + print "--0="; check(res, -1); print ","; check(val, 1); print ", "; + + @push 1; + val = 1; + @dec_chk sp 0 ?jump6b; + val = 0; + .jump6b; + @pull res; + print "--1="; check(res, 0); print ","; check(val, 0); print ", "; + + @push -1; + val = 1; + @dec_chk sp 0 ?jump6c; + val = 0; + .jump6c; + @pull res; + print "---1="; check(res, -2); print ","; check(val, 1); print ", "; + + @push 100; + val = 1; + @dec_chk sp 0 ?jump6d; + val = 0; + .jump6d; + @pull res; + print "--100="; check(res, 99); print ","; check(val, 0); print ", "; + + @push -10; + val = 1; + @dec_chk sp 0 ?jump6e; + val = 0; + .jump6e; + @pull res; + print "---10="; check(res, -11); print ","; check(val, 1); print ", "; + + @push $8000; + val = 1; + @dec_chk sp 0 ?jump6f; + val = 0; + .jump6f; + @pull res; + print "--$8000="; check_hex(res, $7FFF); print ","; check(val, 0); print ", "; + + @push $C000; + val = 1; + @dec_chk sp 0 ?jump6g; + val = 0; + .jump6g; + @pull res; + print "--$C000="; check_hex(res, $BFFF); print ","; check(val, 1); print "^"; + + + res = 50; + val = 1; + @inc_chk res 60 ?jumpxa; + val = 0; + .jumpxa; + print "++50="; check(res, 51); print ","; check(val, 0); print ", "; + + res = 70; + val = 1; + @inc_chk res 60 ?jumpxb; + val = 0; + .jumpxb; + print "++70="; check(res, 71); print ","; check(val, 1); print ", "; + + res = -50; + val = 1; + @inc_chk res (-60) ?jumpxc; + val = 0; + .jumpxc; + print "++-50="; check(res, -49); print ","; check(val, 1); print ", "; + + res = -70; + val = 1; + @inc_chk res (-60) ?jumpxd; + val = 0; + .jumpxd; + print "++-70="; check(res, -69); print ","; check(val, 0); print ", "; + + res = -50; + val = 1; + @inc_chk res 60 ?jumpxe; + val = 0; + .jumpxe; + print "++-50="; check(res, -49); print ","; check(val, 0); print ", "; + + res = 50; + val = 1; + @inc_chk res (-60) ?jumpxf; + val = 0; + .jumpxf; + print "++50="; check(res, 51); print ","; check(val, 1); print "^"; + + + res = 50; + val = 1; + @dec_chk res 60 ?jumpya; + val = 0; + .jumpya; + print "--50="; check(res, 49); print ","; check(val, 1); print ", "; + + res = 70; + val = 1; + @dec_chk res 60 ?jumpyb; + val = 0; + .jumpyb; + print "--70="; check(res, 69); print ","; check(val, 0); print ", "; + + res = -50; + val = 1; + @dec_chk res (-60) ?jumpyc; + val = 0; + .jumpyc; + print "---50="; check(res, -51); print ","; check(val, 0); print ", "; + + res = -70; + val = 1; + @dec_chk res (-60) ?jumpyd; + val = 0; + .jumpyd; + print "---70="; check(res, -71); print ","; check(val, 1); print ", "; + + res = -50; + val = 1; + @dec_chk res 60 ?jumpye; + val = 0; + .jumpye; + print "---50="; check(res, -51); print ","; check(val, 1); print ", "; + + res = 50; + val = 1; + @dec_chk res (-60) ?jumpyf; + val = 0; + .jumpyf; + print "--50="; check(res, 49); print ","; check(val, 0); print "^"; + + + count_failures(); + ]; + +Array array1 --> $1357 $FDB9 $0011 $FFEE; +Array array2 --> 4; + +TestClass ArrayTest + with name 'array' 'loadw' 'loadb' 'storew' 'storeb', + testfunc [ val ix addr; + print "Array loads and stores:^^"; + + addr = array1; + @loadw array1 0 -> val; + print "a-->0="; check_hex(val, $1357); print ", "; + @loadw addr 0 -> val; + print "a-->0="; check_hex(val, $1357); print ", "; + + ix = 1; + @loadw array1 ix -> val; + print "a-->1="; check_hex(val, $FDB9); print ", "; + @loadw addr ix -> val; + print "a-->1="; check_hex(val, $FDB9); print ", "; + + testglobal = 2; + @loadw array1 testglobal -> val; + print "a-->2="; check_hex(val, $0011); print ", "; + @loadw addr testglobal -> val; + print "a-->2="; check_hex(val, $0011); print ", "; + + @push 3; + @loadw array1 sp -> val; + print "a-->3="; check_hex(val, $FFEE); print ", "; + @push 3; + @loadw addr sp -> val; + print "a-->3="; check_hex(val, $FFEE); print "^"; + + addr = array1+3; + @loadw addr (-1) -> val; + print "a+3-->-1="; check_hex(val, $57FD); print ", "; + @loadw addr 0 -> val; + print "a+3-->0="; check_hex(val, $B900); print ", "; + @loadw addr 1 -> val; + print "a+3-->1="; check_hex(val, $11FF); print ", "; + testglobal = array1+3; + @loadw testglobal (-1) -> val; + print "a+3-->-1="; check_hex(val, $57FD); print ", "; + @loadw testglobal 0 -> val; + print "a+3-->0="; check_hex(val, $B900); print ", "; + @loadw testglobal 1 -> val; + print "a+3-->1="; check_hex(val, $11FF); print "^"; + + + addr = array1; + @loadb array1 0 -> val; + print "a->0="; check_hex(val, $13); print ", "; + @loadb addr 0 -> val; + print "a->0="; check_hex(val, $13); print ", "; + + ix = 1; + @loadb array1 ix -> val; + print "a->1="; check_hex(val, $57); print ", "; + @loadb addr ix -> val; + print "a->1="; check_hex(val, $57); print ", "; + + testglobal = 2; + @loadb array1 testglobal -> val; + print "a->2="; check_hex(val, $FD); print ", "; + @loadb addr testglobal -> val; + print "a->2="; check_hex(val, $FD); print ", "; + + @push 3; + @loadb array1 sp -> val; + print "a->3="; check_hex(val, $B9); print ", "; + @push 3; + @loadb addr sp -> val; + print "a->3="; check_hex(val, $B9); print "^"; + + addr = array1+3; + @loadb addr (-1) -> val; + print "a+3->-1="; check_hex(val, $FD); print ", "; + @loadb addr 0 -> val; + print "a+3->0="; check_hex(val, $B9); print ", "; + @loadb addr 1 -> val; + print "a+3->1="; check_hex(val, $00); print ", "; + testglobal = array1+3; + @loadb testglobal (-1) -> val; + print "a+3->-1="; check_hex(val, $FD); print ", "; + @loadb testglobal 0 -> val; + print "a+3->0="; check_hex(val, $B9); print ", "; + @loadb testglobal 1 -> val; + print "a+3->1="; check_hex(val, $00); print "^"; + + + addr = array2; + @storew array2 0 $1201; + @loadw array2 0 -> val; + print "a-->0="; check_hex(val, $1201); print ", "; + @storew addr 0 $2302; + @loadw array2 0 -> val; + print "a-->0="; check_hex(val, $2302); print ", "; + + ix = 1; + @storew array2 ix $3403; + @loadw array2 1 -> val; + print "a-->1="; check_hex(val, $3403); print ", "; + @storew addr ix $4504; + @loadw array2 1 -> val; + print "a-->1="; check_hex(val, $4504); print ", "; + + testglobal = 2; + @storew array2 testglobal $5605; + @loadw array2 2 -> val; + print "a-->2="; check_hex(val, $5605); print ", "; + @storew addr testglobal $6706; + @loadw array2 2 -> val; + print "a-->2="; check_hex(val, $6706); print ", "; + + @push 3; + @storew array2 sp $7807; + @loadw array2 3 -> val; + print "a-->3="; check_hex(val, $7807); print ", "; + @push 3; + @storew addr sp $8908; + @loadw array2 3 -> val; + print "a-->3="; check_hex(val, $8908); print "^"; + + addr = array2+4; + @storew addr (-1) $AB0A; + @loadw array2 1 -> val; + print "a-->-1="; check_hex(val, $AB0A); print ", "; + @storew addr 0 $BC0B; + @loadw array2 2 -> val; + print "a-->0="; check_hex(val, $BC0B); print ", "; + @storew addr 1 $CD0C; + @loadw array2 3 -> val; + print "a-->1="; check_hex(val, $CD0C); print ", "; + + testglobal = array2+4; + @storew testglobal (-1) $BA1B; + @loadw array2 1 -> val; + print "a-->-1="; check_hex(val, $BA1B); print ", "; + @storew testglobal 0 $CB1C; + @loadw array2 2 -> val; + print "a-->0="; check_hex(val, $CB1C); print ", "; + @storew testglobal 1 $DC1D; + @loadw array2 3 -> val; + print "a-->1="; check_hex(val, $DC1D); print "^"; + + + addr = array2; + @storeb array2 0 $12; + @loadb array2 0 -> val; + print "a->0="; check_hex(val, $12); print ", "; + @storeb addr 0 $23; + @loadb array2 0 -> val; + print "a->0="; check_hex(val, $23); print ", "; + + ix = 1; + @storeb array2 ix $34; + @loadb array2 1 -> val; + print "a->1="; check_hex(val, $34); print ", "; + @storeb addr ix $45; + @loadb array2 1 -> val; + print "a->1="; check_hex(val, $45); print ", "; + + testglobal = 2; + @storeb array2 testglobal $56; + @loadb array2 2 -> val; + print "a->2="; check_hex(val, $56); print ", "; + @storeb addr testglobal $67; + @loadb array2 2 -> val; + print "a->2="; check_hex(val, $67); print ", "; + + @push 3; + @storeb array2 sp $78; + @loadb array2 3 -> val; + print "a->3="; check_hex(val, $78); print ", "; + @push 3; + @storeb addr sp $89; + @loadb array2 3 -> val; + print "a->3="; check_hex(val, $89); print "^"; + + addr = array2+4; + @storeb addr (-1) $AB; + @loadb array2 3 -> val; + print "a->-1="; check_hex(val, $AB); print ", "; + @storeb addr 0 $BC; + @loadb array2 4 -> val; + print "a->0="; check_hex(val, $BC); print ", "; + @storeb addr 1 $CD; + @loadb array2 5 -> val; + print "a->1="; check_hex(val, $CD); print ", "; + + testglobal = array2+4; + @storeb testglobal (-1) $BA; + @loadb array2 3 -> val; + print "a->-1="; check_hex(val, $BA); print ", "; + @storeb testglobal 0 $CB; + @loadb array2 4 -> val; + print "a->0="; check_hex(val, $CB); print ", "; + @storeb testglobal 1 $DC; + @loadb array2 5 -> val; + print "a->1="; check_hex(val, $DC); print "^"; + + ix = $F1; + @storeb array2 0 ix; + ix = $E2; + @storeb array2 1 ix; + @loadw array2 0 -> val; + print "$F1 concat $E2 = "; check_hex(val, $F1E2); print "^"; + + ix = $9876; + @storew array2 1 ix; + @loadb array2 2 -> val; + print "$9876 = "; check_hex(val, $98); print " "; + @loadb array2 3 -> val; + print "concat "; check_hex(val, $76); print "^"; + + count_failures(); + ]; + +TestClass UndoTest + with name 'undo', + testfunc [ val loc; + print "Undo:^^"; + + val = HDR_GAMEFLAGS-->0; ! "Flags 2" byte + if (val & 16) + print "Interpreter claims to support undo.^^"; + else + print "Interpreter claims to not support undo. (Continuing test anyway...)^^"; + + print "Using a local variable for @@64save_undo result:^"; + loc = 99; + testglobal = 999; + @save_undo val; + if (val == -1) { + print "Undo is not available on this interpreter.^"; + count_failures(); + return; + } + if (val == 0) { + print "@@64save_undo failed!^"; + failures++; + count_failures(); + return; + } + if (val == 1) { + print "Undo saved...^"; + ! The following changes will be undone. + loc = 77; + testglobal = 777; + failures++; + print "Restoring undo...^"; + @restore_undo val; + if (val == 0) { + print "@@64restore_undo failed (value 0)!^"; + } + else { + print "@@64restore_undo failed with unknown return value: ", val, "^"; + } + failures++; + count_failures(); + return; + } + else if (val ~= 2) { + print "Unknown @@64save_undo return value: ", val, "^"; + failures++; + count_failures(); + return; + } + print "Undo succeeded, return value "; check(val, 2); print ".^"; + print "loc="; check(loc, 99); print " glob="; check(testglobal, 999); print "^"; + + print "Using a global variable for @@64save_undo result:^"; + loc = 98; + testglobal = 998; + @save_undo testglobal2; + if (testglobal2 == -1) { + print "Undo is not available on this interpreter.^"; + count_failures(); + return; + } + if (testglobal2 == 0) { + print "@@64save_undo failed!^"; + failures++; + count_failures(); + return; + } + if (testglobal2 == 1) { + print "Undo saved...^"; + ! The following changes will be undone. + loc = 77; + testglobal = 777; + failures++; + print "Restoring undo...^"; + @restore_undo testglobal2; + if (testglobal2 == 0) { + print "@@64restore_undo failed (value 0)!^"; + } + else { + print "@@64restore_undo failed with unknown return value: ", testglobal2, "^"; + } + failures++; + count_failures(); + return; + } + else if (testglobal2 ~= 2) { + print "Unknown @@64save_undo return value: ", testglobal2, "^"; + failures++; + count_failures(); + return; + } + print "Undo succeeded, return value "; check(testglobal2, 2); print ".^"; + print "loc="; check(loc, 98); print " glob="; check(testglobal, 998); print "^"; + + print "Calling @@64save_undo within a function or two:^"; + loc = 97; + testglobal = 997; + val = undo_depth_check(); + if (val == -1) { + print "Undo is not available on this interpreter.^"; + count_failures(); + return; + } + if (val == 0) { + print "@@64save_undo failed!^"; + failures++; + count_failures(); + return; + } + if (val == 1) { + print "Undo saved...^"; + ! The following changes will be undone. + loc = 77; + testglobal = 777; + failures++; + print "Restoring undo...^"; + @restore_undo val; + if (val == 0) { + print "@@64restore_undo failed (value 0)!^"; + } + else { + print "@@64restore_undo failed with unknown return value: ", val, "^"; + } + failures++; + count_failures(); + return; + } + else if (val ~= 2) { + print "Unknown @@64save_undo return value: ", val, "^"; + failures++; + count_failures(); + return; + } + print "Undo succeeded, return value "; check(val, 2); print ".^"; + print "loc="; check(loc, 97); print " glob="; check(testglobal, 997); print "^"; + @check_arg_count 3 ?~ok; + print "Error: test method wrongly got argument 3!^"; + failures++; + .ok; + + print "Using the stack for @@64save_undo result:^"; + loc = 98; + testglobal = 998; + testglobal2 = -99; + @save_undo sp; + @pull testglobal2; + if (testglobal2 == -1) { + print "Undo is not available on this interpreter.^"; + count_failures(); + return; + } + if (testglobal2 == 0) { + print "@@64save_undo failed!^"; + failures++; + count_failures(); + return; + } + if (testglobal2 == 1) { + print "Undo saved...^"; + ! The following changes will be undone. + loc = 77; + testglobal = 777; + testglobal2 = -99; + failures++; + print "Restoring undo...^"; + @restore_undo sp; + @pull testglobal2; + if (testglobal2 == 0) { + print "@@64restore_undo failed (value 0)!^"; + } + else { + print "@@64restore_undo failed with unknown return value: ", testglobal2, "^"; + } + failures++; + count_failures(); + return; + } + else if (testglobal2 ~= 2) { + print "Unknown @@64save_undo return value: ", testglobal2, "^"; + failures++; + count_failures(); + return; + } + print "Undo succeeded, return value "; check(testglobal2, 2); print ".^"; + print "loc="; check(loc, 98); print " glob="; check(testglobal, 998); print "^"; + + print "Checking @@64save_undo saves the stack correctly:^"; + @push 9; + loc = 99; + testglobal = 999; + testglobal2 = -999; + @save_undo val; + if (val == -1) { + print "Undo is not available on this interpreter.^"; + count_failures(); + return; + } + if (val == 0) { + print "@@64save_undo failed!^"; + failures++; + count_failures(); + return; + } + if (val == 1) { + print "Undo saved...^"; + ! The following changes will be undone. + loc = 77; + testglobal = 777; + testglobal2 = -777; + @pull val; + print "guard="; check(val, 9); print "^"; + val = 7; + failures++; + print "Restoring undo...^"; + @restore_undo testglobal2; + if (testglobal2 == 0) { + print "@@64restore_undo failed (value 0)!^"; + } + else { + print "@@64restore_undo failed with unknown return value: ", testglobal2, "^"; + } + failures++; + count_failures(); + return; + } + else if (val ~= 2) { + print "Unknown @@64save_undo return value: ", val, "^"; + failures++; + count_failures(); + return; + } + print "Undo succeeded, return value "; check(val, 2); print ".^"; + print "loc="; check(loc, 99); print " glob="; check(testglobal, 999); print " glob2="; check(testglobal2, -999); print "^"; + + @pull val; + print "guard="; check(val, 9); print "^"; + + count_failures(); + ]; + +[ undo_depth_check; + return undo_depth_check2(11, 22, 33); +]; + +[ undo_depth_check2 foo bar baz val; + bar = 1; + foo = bar; + baz = foo; + @save_undo val; + @check_arg_count 3 ?ok; + print "Error: undo_depth_check2 did not get argument 3!^"; + failures++; + .ok; + return val; +]; + +TestClass MultiUndoTest + with name 'multiundo', + testfunc [ val loc; + print "Multi-level undo:^(Note: this capability is not required by the spec.)^^"; + + val = HDR_GAMEFLAGS-->0; ! "Flags 2" byte + if (val & 16) + print "Interpreter claims to support undo.^^"; + else + print "Interpreter claims to not support undo. (Continuing test anyway...)^^"; + + loc = 99; + testglobal = 999; + @save_undo val; + if (val == -1) { + print "Undo is not available on this interpreter.^"; + count_failures(); + return; + } + if (val == 0) { + print "First @@64save_undo failed!^"; + failures++; + count_failures(); + return; + } + if (val == 1) { + print "Undo 1 saved...^"; + ! The following changes will be undone. + loc = 77; + testglobal = 777; + failures++; + + @save_undo val; + if (val == -1) { + print "Undo returned ~unavailable~, even though it was available the first time.^"; + count_failures(); + return; + } + if (val == 0) { + print "Second @@64save_undo failed! This interpreter apparently doesn't support multi-level undo. This should not be considered a bug.^"; + failures--; ! cancel the previous failure + count_failures(); + return; + } + if (val == 1) { + print "Undo 2 saved...^"; + ! The following changes will be undone. + loc = 55; + testglobal = 555; + failures++; + + print "Restoring undo 2...^"; + @restore_undo val; + if (val == 0) { + print "Second @@64restore_undo failed (value 0)!^"; + } + else { + print "Second @@64restore_undo failed with unknown return value: ", val, "^"; + } + failures++; + count_failures(); + return; + } + else if (val ~= 2) { + print "Unknown @@64save_undo return value: ", val, "^"; + failures++; + count_failures(); + return; + } + + print "Undo 2 succeeded, return value "; check(val, 2); print ".^"; + print "loc="; check(loc, 77); print " glob="; check(testglobal, 777); print "^"; + + print "Restoring undo 1...^"; + @restore_undo val; + if (val == 0) { + print "First @@64restore_undo failed (value 0)!^"; + } + else { + print "First @@64restore_undo failed with unknown return value: ", val, "^"; + } + failures++; + count_failures(); + return; + } + else if (val ~= 2) { + print "Unknown @@64save_undo return value: ", val, "^"; + failures++; + count_failures(); + return; + } + print "Undo 1 succeeded, return value "; check(val, 2); print ".^"; + print "loc="; check(loc, 99); print " glob="; check(testglobal, 999); print "^"; + + count_failures(); + ]; + +! The Indirect test is copied more-or-less whole from czech.inf +! (as of Oct 1 2010). Comments copied also: +! +! Indirect-able opcodes: inc, dec, inc_chk, dec_chk, store, pull, load +! Spec Version 1.1 (draft7): "an indirect reference to the stack +! pointer does not push or pull the top item of the stack - it is read +! or written in place." +! Based on my tests (see rec.arts.int-fiction 20031028), this seems to mean +! that, e.g., for load, you NEVER pop the stack, for all cases +! (a) load sp; (b) load [sp]; (c) i=0; load [i]; (d) sp=0; load [sp]; +! +! Overall rules: +! - Do NOT push/pop for "foo sp": write in place +! - DO pop for "foo [sp]". However, if top of stack is 0, only pop ONCE. +! - "bar = 0; foo [bar]" yields EXACTLY the same results as "foo sp" +! ("push 0; foo [sp] is also identical to "foo sp".) +! +TestClass IndirectTest + with name 'indirect', + testfunc [ ix; + print "Indirect opcodes:^^"; + + for (ix = 0: ix < 100: ix++) { + do_indirect_test(ix); + } + + count_failures(); + ]; + +[ do_indirect_test which + result local2 spointer lpointer rpointer + top_of_stack which_str expectr expect1 expect2; + + ! First, set up everything we're going to need. + + local2 = 51; + ! Gtemp = 61; + result = 71; + spointer = 0; ! stack + rpointer = 2; ! points to 'result' + lpointer = 3; ! local2 + ! gpointer = 21; ! '21' means 6th global, which is (hopefully!) Gtemp + expectr = 999; ! don't test 'result' unless we change this value + + @push 41; @push 42; @push 43; @push 44; @push 45; + switch (which) { + + ! load -> result + 0: + @load sp -> result; ! compiles as 'load 0 -> result' + expectr = 45; expect1 = 45; expect2 = 44; + which_str = "load sp -> result"; + 1: + @load [spointer] -> result; + expectr = 45; expect1 = 45; expect2 = 44; + which_str = "load [spointer] -> result"; + 2: + @push lpointer; @load [sp] -> result; + expectr = 51; expect1 = 45; expect2 = 44; + which_str = "load [sp=lpointer] -> result"; + 3: + @push spointer; @load [sp] -> result; + expectr = 45; expect1 = 45; expect2 = 44; + which_str = "load [sp=spointer] -> result"; + + ! load -> sp + 4: + @load sp -> sp; + expect1 = 45; expect2 = 45; + which_str = "load sp -> sp"; + 5: + @push lpointer; @load [sp] -> sp; + expect1 = 51; expect2 = 45; + which_str = "load [sp=lpointer] -> sp"; + 6: + @push spointer; @load [sp] -> sp; + expect1 = 45; expect2 = 45; + which_str = "load [sp=spointer] -> sp"; + + ! store + 10: + @store sp 83; + expect1 = 83; expect2 = 44; + which_str = "store sp 83"; + 11: + @store [spointer] 83; + expect1 = 83; expect2 = 44; + which_str = "store [spointer] 83"; + 12: + @push spointer; @store [sp] 83; + expect1 = 83; expect2 = 44; + which_str = "store [sp=spointer] 83"; + + 13: + @store [rpointer] 83; + expectr = 83; expect1 = 45; expect2 = 44; + which_str = "store [rpointer] 83"; + 14: + @push rpointer; @store [sp] 83; + expectr = 83; expect1 = 45; expect2 = 44; + which_str = "store [sp=rpointer] 83"; + + 15: + @store result sp; + expectr = 45; expect1 = 44; expect2 = 43; + which_str = "store result sp"; + 16: + @store sp sp; + expect1 = 45; expect2 = 43; + which_str = "store sp sp"; + 17: + @push spointer; @store [sp] sp; + expect1 = 45; expect2 = 43; + which_str = "store [sp=spointer] sp"; + + 18: + @store [rpointer] sp; + expectr = 45; expect1 = 44; expect2 = 43; + which_str = "store [rpointer] sp"; + 19: + @push rpointer; @store [sp] sp; + expectr = 45; expect1 = 44; expect2 = 43; + which_str = "store [sp=rpointer] sp"; + + ! pull + 20: + @pull result; + expectr = 45; expect1 = 44; expect2 = 43; + which_str = "pull result"; + 21: + @pull [rpointer]; + expectr = 45; expect1 = 44; expect2 = 43; + which_str = "pull [rpointer]"; + 22: + @push rpointer; @pull [sp]; + expectr = 45; expect1 = 44; expect2 = 43; + which_str = "pull [sp=rpointer]"; + + 23: + @pull sp; + expect1 = 45; expect2 = 43; + which_str = "pull sp"; + 24: + @push spointer; @pull [sp]; + expect1 = 45; expect2 = 43; + which_str = "pull [sp=spointer]"; + 25: + @pull [spointer]; + expect1 = 45; expect2 = 43; + which_str = "pull [spointer]"; + + ! inc + 30: + @inc result; + expectr = 72; expect1 = 45; expect2 = 44; + which_str = "inc result"; + 31: + @inc [rpointer]; + expectr = 72; expect1 = 45; expect2 = 44; + which_str = "inc [rpointer]"; + 32: + @push rpointer; @inc [sp]; + expectr = 72; expect1 = 45; expect2 = 44; + which_str = "inc [sp=rpointer]"; + + 33: + @inc sp; + expect1 = 46; expect2 = 44; + which_str = "inc sp"; + 34: + @inc [spointer]; + expect1 = 46; expect2 = 44; + which_str = "inc [spointer]"; + 35: + @push spointer; @inc [sp]; + expect1 = 46; expect2 = 44; + which_str = "inc [sp=spointer]"; + + ! dec + 40: + @dec result; + expectr = 70; expect1 = 45; expect2 = 44; + which_str = "dec result"; + 41: + @dec [rpointer]; + expectr = 70; expect1 = 45; expect2 = 44; + which_str = "dec [rpointer]"; + 42: + @push rpointer; @dec [sp]; + expectr = 70; expect1 = 45; expect2 = 44; + which_str = "dec [sp=rpointer]"; + + 43: + @dec sp; + expect1 = 44; expect2 = 44; + which_str = "dec sp"; + 44: + @dec [spointer]; + expect1 = 44; expect2 = 44; + which_str = "dec [spointer]"; + 45: + @push spointer; @dec [sp]; + expect1 = 44; expect2 = 44; + which_str = "dec [sp=spointer]"; + + ! inc_chk + 50: + which_str = "inc_chk result"; + @inc_chk result 72 ?bad_indirect_inc; + expectr = 72; expect1 = 45; expect2 = 44; + 51: + which_str = "inc_chk [rpointer]"; + @inc_chk [rpointer] 72 ?bad_indirect_inc; + expectr = 72; expect1 = 45; expect2 = 44; + 52: + which_str = "inc_chk [sp=rpointer]"; + @push rpointer; @inc_chk [sp] 72 ?bad_indirect_inc; + expectr = 72; expect1 = 45; expect2 = 44; + + 53: + which_str = "inc_chk sp"; + @inc_chk sp 46 ?bad_indirect_inc; + expect1 = 46; expect2 = 44; + 54: + which_str = "inc_chk [spointer]"; + @inc_chk [spointer] 46 ?bad_indirect_inc; + expect1 = 46; expect2 = 44; + 55: + which_str = "inc_chk [sp=spointer]"; + @push spointer; @inc_chk [sp] 46 ?bad_indirect_inc; + expect1 = 46; expect2 = 44; + + ! dec_chk + 60: + which_str = "dec_chk result"; + @dec_chk result 70 ?bad_indirect_inc; + expectr = 70; expect1 = 45; expect2 = 44; + 61: + which_str = "dec_chk [rpointer]"; + @dec_chk [rpointer] 70 ?bad_indirect_inc; + expectr = 70; expect1 = 45; expect2 = 44; + 62: + which_str = "dec_chk [sp=rpointer]"; + @push rpointer; @dec_chk [sp] 70 ?bad_indirect_inc; + expectr = 70; expect1 = 45; expect2 = 44; + + 63: + which_str = "dec_chk sp"; + @dec_chk sp 44 ?bad_indirect_inc; + expect1 = 44; expect2 = 44; + 64: + which_str = "dec_chk [spointer]"; + @dec_chk [spointer] 44 ?bad_indirect_inc; + expect1 = 44; expect2 = 44; + 65: + which_str = "dec_chk [sp=spointer]"; + @push spointer; @dec_chk [sp] 44 ?bad_indirect_inc; + expect1 = 44; expect2 = 44; + + default: + rfalse; ! no test here; do nothing. + } + + ! Test results + print (string) which_str, ": "; + @je expectr 999 ?skip_expectr; + check(result, expectr); print ", "; + .skip_expectr; + @pull top_of_stack; + check(top_of_stack, expect1); print ", "; + @pull top_of_stack; + check(top_of_stack, expect2); + + new_line; + rtrue; + + ! If you got here, inc_chk/dec_chk broke + .bad_indirect_inc; + print (string) which_str, ": "; + check(result, 123); + new_line; + rfalse; +]; + +! The lengths here must exceed the number of characters printed (below) +! by at least 3. +Array streambuf -> 170; +Array streambufcmp -> 170; + +! The StreamTrip test sends every legal, printable ZSCII character to +! a memory stream, and then reads them back. They should all survive +! the journey unscathed. +! +! Note that character 9 (tab) and 10 (unix newline) are not legal for +! output. (Despite the fact that Zork 1 uses tabs for indenting +! the temple book's text.) (Tab is legal in V6, but this test is for +! v5/8.) +! +! Printing character 0 is legal, but doesn't generate output. It should +! not count towards the stream count either. (See 3.8.2.1.) +! +TestClass StreamTripTest + with name 'streamtrip', + short_name "streamtrip", + testfunc [ ix len pos; + print "Memory stream round-trip:^^"; + + @output_stream 3 streambuf; + pos = 0; + @print_char 13; ! newline + streambufcmp->pos = 13; pos++; + for (ix=32 : ix <= 126 : ix++) { + streambufcmp->pos = ix; pos++; + @print_char ix; + } + for (ix=155 : ix <= 223 : ix++) { + streambufcmp->pos = ix; pos++; + @print_char ix; + } + ! no streambufcmp output for the no-op + @print_char 0; ! no-op + @print_char 64; ! @-sign + streambufcmp->pos = 64; pos++; + @output_stream -3; + + ix = streambuf; + len = ix-->0; + print "Number of characters written: "; check(pos, 166); new_line; + print "Number of characters read: "; check(len, 166); new_line; + + check_array( streambuf+2, streambufcmp, len, Streamtripprint ); + + count_failures(); + ]; + +[ Streamtripprint ch; + print "Mismatch for ", ch, " '"; + @print_char ch; + print "': "; +]; + +TestClass StreamOpTest + with name 'streamop', + short_name "streamop", + testfunc [ len; + print "Memory stream opcodes:^^"; + + @output_stream 3 streambuf; + @print_paddr "abc"; + @output_stream -3; + + len = (streambuf+0)-->0; + print "@@64print_paddr: "; + check(len, 3); print " characters written: "; + check_arr_3(streambuf+2, 'a', 'b', 'c'); new_line; + + @output_stream 3 streambuf; + @print_num 789; + @output_stream -3; + + len = (streambuf+0)-->0; + print "@@64print_num: "; + check(len, 3); print " characters written: "; + check_arr_3(streambuf+2, '7', '8', '9'); new_line; + + @output_stream 3 streambuf; + @print_char 'x'; + @output_stream -3; + + len = (streambuf+0)-->0; + print "@@64print_char: "; + check(len, 1); print " characters written: "; + check_arr_3(streambuf+2, 'x', '8', '9'); new_line; + + count_failures(); + ]; + +TestClass Throwcatch + with name 'throwcatch' 'throw' 'catch', + short_name "throwcatch", + testfunc [ val; + print "@@64throw/@@64catch:^^"; + + testglobal = 0; + testglobal2 = 0; + + val = Throwfunc1(); + + print "The function with @@64catch will be returned with the value of @@64throw: "; check(val, 1); print "^"; + print "Intermediate functions should not set their storers.^testglobal="; check(testglobal, 0); print "^"; + print "testglobal2="; check(testglobal2, 0); print "^"; + + count_failures(); + ]; + +[ Throwfunc1 val; + print "Throwfunc1^"; + val = Throwfunc2(); + print "Returning from Throwfunc1^^"; + return val; +]; + +[ Throwfunc2 val; + print "Throwfunc2^"; + @catch -> val; + val = Throwfunc3(val); + print "Returning from Throwfunc2^"; + return 2; +]; + +[ Throwfunc3 val; + print "Throwfunc3^"; + testglobal = Throwfunc4(val); + print "Returning from Throwfunc3^"; + return 3; +]; + +[ Throwfunc4 val; + print "Throwfunc4^"; + testglobal2 = Throwfunc5(val); + print "Returning from Throwfunc4^"; + return 4; +]; + +[ Throwfunc5 val; + print "Throwfunc5^About to @@64throw - should then return from Throwfunc1^"; + @throw 1 val; + print "Returning from Throwfunc5^"; + return 5; +]; + +Array tables_data -> 256; +Array copy_table_reference -> +$00 $01 $02 $03 $04 $05 $06 $07 $08 $09 $0a $0b $0c $0d $0e $0f +$00 $01 $02 $03 $04 $05 $06 $07 $18 $19 $1a $1b $1c $1d $1e $1f +$30 $31 $32 $33 $34 $35 $36 $37 $28 $29 $2a $2b $2c $2d $2e $2f +$30 $31 $32 $33 $34 $35 $36 $37 $38 $39 $3a $3b $3c $3d $3e $3f +$40 $41 $42 $43 $40 $41 $42 $43 $44 $45 $46 $47 $4c $4d $4e $4f +$54 $55 $56 $57 $58 $59 $5a $5b $58 $59 $5a $5b $5c $5d $5e $5f +$60 $61 $62 $63 $60 $61 $62 $63 $60 $61 $62 $63 $6c $6d $6e $6f +$00 $00 $00 $00 $00 $00 $00 $00 $78 $79 $7a $7b $7c $7d $7e $7f; + +TestClass Tables + with name 'tables' 'table', + testfunc [ val val2 ix; + print "*_table tests:^^"; + + for (ix=0 : ix<256 : ix++) { + tables_data->ix = ix; + } + + print "@@64print_table - should print the alphabet in upper then lower case:^"; + val = tables_data + $41; + @print_table val 26 2 6; + + print "^^@@64scan_table:"; + print "^Default form, first word: "; + @scan_table $0001 tables_data 128 -> val ?~bad_scan_table; + check(val, tables_data); + print "^Default form, another word: "; + @scan_table $8081 tables_data 128 -> val ?~bad_scan_table; + check(val, tables_data + $80); + print "^Manually specified default form: "; + @scan_table $8081 tables_data 128 $82 -> val ?~bad_scan_table; + check(val, tables_data + $80); + print "^Default form, nonexistent word: "; + @scan_table $0102 tables_data 128 -> val ?bad_scan_table; + check(val, 0); + + print "^Byte form, first byte: "; + @scan_table $00 tables_data 256 $01 -> val ?~bad_scan_table; + check(val, tables_data); + print "^Byte form, another byte: "; + @scan_table $80 tables_data 256 $01 -> val ?~bad_scan_table; + check(val, tables_data + $80); + print "^Byte form, nonexistent byte: "; + @scan_table $100 tables_data 256 $01 -> val ?bad_scan_table; + check(val, 0); + + print "^Longer form, first word: "; + @scan_table $0001 tables_data 64 $84 -> val ?~bad_scan_table; + check(val, tables_data); + print "^Longer form, another word: "; + @scan_table $8081 tables_data 64 $84 -> val ?~bad_scan_table; + check(val, tables_data + $80); + print "^Longer form, a word which will be skipped: "; + @scan_table $0203 tables_data 64 $84 -> val ?bad_scan_table; + check(val, 0); + + print "^Longer byte form, first byte: "; + @scan_table $00 tables_data 64 $04 -> val ?~bad_scan_table; + check(val, tables_data); + print "^Longer byte form, another byte: "; + @scan_table $80 tables_data 64 $04 -> val ?~bad_scan_table; + check(val, tables_data + $80); + print "^Longer byte form, a byte which will be skipped: "; + @scan_table $02 tables_data 64 $04 -> val ?bad_scan_table; + check(val, 0); + + print "^Default form, word after length of table: "; + @scan_table $8081 tables_data 63 -> val ?bad_scan_table; + check(val, 0); + print "^Longer form, word after length of table: "; + @scan_table $8081 tables_data 31 $84 -> val ?bad_scan_table; + check(val, 0); + + .copy_table; + print "^^@@64copy_table:^"; + print "Copying forward, non-overlapping.^"; + val = tables_data + $10; + @copy_table tables_data val 8; + val2 = copy_table_reference + $10; + check_array( val, val2, 16, Copytableprint ); + + print "Copying backwards, non-overlapping.^"; + val = tables_data + $20; + val2 = tables_data + $30; + @copy_table val2 val 8; + val2 = copy_table_reference + $20; + check_array( val, val2, 16, Copytableprint ); + + print "Copying forward, overlapping, non-corrupting.^"; + val = tables_data + $40; + val2 = tables_data + $44; + @copy_table val val2 8; + val2 = copy_table_reference + $40; + check_array( val, val2, 16, Copytableprint ); + + print "Copying backward, overlapping, non-corrupting.^"; + val = tables_data + $50; + val2 = tables_data + $54; + @copy_table val2 val 8; + val2 = copy_table_reference + $50; + check_array( val, val2, 16, Copytableprint ); + + print "Copying forward, overlapping, corrupting.^"; + val = tables_data + $60; + val2 = tables_data + $64; + @copy_table val val2 (-8); + val2 = copy_table_reference + $60; + check_array( val, val2, 16, Copytableprint ); + + print "Using @@64copy_table to zero out an array.^"; + val = tables_data + $70; + @copy_table val 0 8; + val2 = copy_table_reference + $70; + check_array( val, val2, 16, Copytableprint ); + + val = failures; + + print "Checking final table (failures are not counted twice).^"; + check_array( tables_data, copy_table_reference, 128, Copytableprint ); + + failures = val; + count_failures(); + return; + + .bad_scan_table; + print "^Bad @@64scan_table branch."; + failures++; + jump copy_table; + ]; + +[ Copytableprint ch ix; + print "Mismatch for index ", ix, ": "; +]; + +TestClass specfixes + with name 'specfixes' 'fixes', + testfunc [ val ; + print "Z-Machine 1.1 Updates/Clarifications:^^"; + + ! Operand evalution + ! Opcode operands are always evaluated from first to last + print "Operand evalution: "; + @push 2; + @push 4; + @sub sp sp -> val; + print "4-2="; check(val, 2); print "^"; + + ! Indirect variable references + ! An indirect reference to the stack pointer does not push or pull the top item of the stack - it is read or written in place. + print "Indirect variable references:^"; + @push 9; + @push 5; + @dec sp; + @pull val; + @pull val; + print "@@64dec: guard="; check(val, 9); print "^"; + @push 9; + @push 7; + @dec_chk sp 2 ?jumpfail; + @pull val; + @pull val; + print "@@64dec_chk: guard="; check(val, 9); print "^"; + @push 9; + @push 5; + @inc sp; + @pull val; + @pull val; + print "@@64inc: guard="; check(val, 9); print "^"; + @push 9; + @push 2; + @inc_chk sp 7 ?jumpfail; + @pull val; + @pull val; + print "@@64inc_chk: guard="; check(val, 9); print "^"; + ! Push an extra value in case @load fails - we don't want a stack underflow + @push 1; + @push 9; + @load sp -> val; + @pull val; + print "@@64load: guard="; check(val, 9); print "^"; + @push 9; + @pull sp; + @pull val; + print "@@64pull: guard="; check(val, 9); print "^"; + @push 9; + @push 1; + @store sp 2; + @pull val; + @pull val; + print "@@64store: guard="; check(val, 9); print "^"; + + ! @je + ! @je can take between 2 and 4 operands. + print "@@64je operands: "; + val = 1; + @je 1 0 1 ?je1; + val = 0; + .je1; + print "3: "; check(val, 1); + val = 1; + @je 1 0 0 1 ?je2; + val = 0; + .je2; + print ", 4: "; check(val, 1); print "^"; + + ! @get_prop_len + ! @get_prop_len 0 must return 0. + val = 1; + print "@@64get_prop_len 0: "; + @get_prop_len 0 -> val; + check(val, 0); print "^"; + + !### @set_cursor + !### @output_stream + !### Mouse + !### Sound + + count_failures(); + return; + + .jumpfail; + failures++; + count_failures(); + ]; + +Array basic_color_set --> $0000 $001D $0340 $03BD $59A0 $7C1F $77A0 $7FFF $5AD6 $4631 $2D6B; + +Array rainbow_set --> $001f $007f $00bf $00ff $013f $019f $01df $023f $027f $02bf $02ff $035f $039f $03df $03fd $03fb $03f9 $03f6 $03f4 $03f2 $03ef $03ed $03eb $03e8 $03e6 $03e4 $03e1 $07e0 $0fe0 $1be0 $23e0 $2be0 $33e0 $3fe0 $47e0 $53e0 $5be0 $63e0 $6be0 $77e0 $7fe0 $7f80 $7f40 $7f00 $7ec0 $7e60 $7e20 $7dc0 $7d80 $7d40 $7d00 $7ca0 $7c60 $7c00 $7c01 $7c04 $7c06 $7c09 $7c0b $7c0d $7c0f $7c12 $7c14 $7c17 $7c19 $7c1b $7c1d $781f $701f $641f $5c1f $541f $4c1f $401f $381f $2c1f $241f $1c1f $141f $081f; + +TestClass spec11 + with name 'spec11', + testfunc [ i val; + print "Z-Machine 1.1 tests:^^"; + + ! Check we're in a 1.1 version interpreter + val = HDR_SPECREVISION-->0; + if (val < $0101) + { + print "Stopping, interpreter is only version "; Version(); print ".^"; + return; + } + + print "Ok, interpreter is version "; Version(); print ".^^"; + + ! Test @set_true_colour by printing a rainbow + print "Checking @@64set_true_colour by printing a pretty rainbow (ultimate prettiness of rainbow depends on the observer's tastes):^^"; + + @set_text_style 8; + for (i=0 : i<80 : i++) + { + val = rainbow_set-->i; + @"EXT:13" -1 val; + print " "; + } + @set_colour 1 1; + @set_text_style 0; + print "^^"; + + ! Check the recommended colour set + print "Checking if the basic colour set uses the recommended true colours:^^"; + + @set_text_style 8; + print "Recommended: "; + for (i=0 : i<11 : i++) + { + val = basic_color_set-->i; + @"EXT:13" -1 val; + print " "; + } + @set_colour 1 1; + print "^Interpreter: "; + for (i=2 : i<13 : i++) + { + @set_colour 1 i; + print " "; + } + @set_colour 1 1; + @set_text_style 0; + print "^"; + + !count_failures(); + return; + ]; + +TestClass gestalt + with name 'spec12' 'gestalt', + testfunc [ val ; + print "Z-Machine 1.2 (@@64gestalt):^^"; + + ! Check we're in a 1.2 version interpreter + val = HDR_SPECREVISION-->0; + if (val < $0102) + { + print "Stopping, interpreter is only version "; Version(); print ".^"; + return; + } + + print "Ok, interpreter is version "; Version(); print ".^^"; + + ! Checking non-existant selector + @"EXT:30S" 0 0 -> val; + print "Selector 0 (non-existant): 0="; check(val, 0); print "^"; + + ! Checking Standard Revision selector + @"EXT:30S" 1 0 -> val; + print "Selector 1 (Standard Revision): $0102<= "; check_hex_min(val, $0102); print "^"; + + count_failures(); + return; + ]; diff --git a/tests/praxix.z5 b/tests/praxix.z5 new file mode 100644 index 0000000..87f83a7 Binary files /dev/null and b/tests/praxix.z5 differ diff --git a/tests/unicode.inf b/tests/unicode.inf new file mode 100644 index 0000000..2f49ba7 --- /dev/null +++ b/tests/unicode.inf @@ -0,0 +1,123 @@ +! Unicode Test v1.0 +! +! David Kinder, 2002. +! + +Switches xv5; +Release 1; + +Zcharacter table + '@{a9}' '@{2122}' '@{20ac}'; + +[ main; + + print "^Unicode Test v1.0, by David Kinder^"; + new_line; + + print "Testing the Unicode table. This sentence should end with Euro, copyright and trademark symbols @{20ac} @{a9} @{2122}^"; + new_line; + + print "Now, testing print_unicode()...^"; + charsets(); + new_line; + + print "Now, testing input (ESC to quit)...^"; + input_unicode(); +]; + +[ input_unicode key; + + print "Try inputing a character. Since the Euro symbol is declared in this file's Zcharacter table, "; + print "it can be input even though it is not part of ISO Latin-1.^"; + while (1) + { + @read_char 1 -> key; + + if (key == $1b) + quit; + + font off; + print "ZSCII $", (hex) key, " = "; + font on; + + switch (key) + { + 8: print "delete"; + 13: print "return"; + 129: print "cursor up"; + 130: print "cursor down"; + 131: print "cursor left"; + 132: print "cursor right"; + 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144: print "function key ", key-132; + 145, 146, 147, 148, 149, 150, 151, 152, 153, 154: print "keypad key ", key-145; + 252: print "menu click"; + 253: print "mouse double-click"; + 254: print "mouse single-click"; + default: print (char) key; + } + new_line; + } +]; + +[ charsets; + + charset("Basic Latin",$0020,3); + charset("Latin-1 Supplement",$00a0,3); + charset("Latin Extended-A",$0100,4); + charset("Greek and Coptic",$0360,5); + charset("Cyrillic",$0400,8); + charset("Arabic",$0600,8); +]; + +[ charset title start lines i; + + font off; + new_line; + print (string) title; + new_line; + + for (i = 0: i < lines: i++) + charrow(start+(i*32)); + font on; +]; + +[ charrow start i; + + print (hex) start, " : "; + for (i = 0: i < 32: i++) + charout(start+i); + new_line; +]; + +[ charout c exist; + + @"EXT:12S" c -> exist; + if (exist & 1) + @"EXT:11" c; + else + print (char) ' '; +]; + +[ hex x y; + + y = (x & $7f00) / $100; + if (x < 0) + y = y + $80; + x = x & $ff; + print (hexdigit) y/$10, (hexdigit) y, (hexdigit) x/$10, (hexdigit) x; +]; + +[ hexdigit x; + + x = x % $10; + switch (x) + { + 0 to 9: print x; + 10: print "a"; + 11: print "b"; + 12: print "c"; + 13: print "d"; + 14: print "e"; + 15: print "f"; + } +]; + diff --git a/tests/unicode.z5 b/tests/unicode.z5 new file mode 100644 index 0000000..8f60e05 Binary files /dev/null and b/tests/unicode.z5 differ