--- /dev/null
+! 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 : ix<plen : ix++) {
+ if (paddr-->ix == 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 : ix<len : ix++) {
+ goldch = gold->ix;
+ 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;
+ ];
Scope-eye.net Git Repository / liskon_frotz.git / commitdiff