Annotation of gforth/test/coretest.fs, revision 1.2

1.1       anton       1: \ From: John Hayes S1I
                      2: \ Subject: core.fr
                      3: \ Date: Mon, 27 Nov 95 13:10
                      4: 
                      5: \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
                      6: \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
                      7: \ VERSION 1.2
                      8: \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
                      9: \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
                     10: \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
                     11: \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
                     12: \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
                     13: \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
                     14: 
1.2     ! anton      15: \ modified by Anton Ertl to produce output that is independent of type sizes
        !            16: 
1.1       anton      17: TESTING CORE WORDS
                     18: HEX
                     19: 
                     20: \ ------------------------------------------------------------------------
                     21: TESTING BASIC ASSUMPTIONS
                     22: 
                     23: { -> }                                 \ START WITH CLEAN SLATE
                     24: ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
                     25: { : BITSSET? IF 0 0 ELSE 0 THEN ; -> }
                     26: {  0 BITSSET? -> 0 }           ( ZERO IS ALL BITS CLEAR )
                     27: {  1 BITSSET? -> 0 0 }         ( OTHER NUMBER HAVE AT LEAST ONE BIT )
                     28: { -1 BITSSET? -> 0 0 }
                     29: 
                     30: \ ------------------------------------------------------------------------
                     31: TESTING BOOLEANS: INVERT AND OR XOR
                     32: 
                     33: { 0 0 AND -> 0 }
                     34: { 0 1 AND -> 0 }
                     35: { 1 0 AND -> 0 }
                     36: { 1 1 AND -> 1 }
                     37: 
                     38: { 0 INVERT 1 AND -> 1 }
                     39: { 1 INVERT 1 AND -> 0 }
                     40: 
                     41: 0       CONSTANT 0S
                     42: 0 INVERT CONSTANT 1S
                     43: 
                     44: { 0S INVERT -> 1S }
                     45: { 1S INVERT -> 0S }
                     46: 
                     47: { 0S 0S AND -> 0S }
                     48: { 0S 1S AND -> 0S }
                     49: { 1S 0S AND -> 0S }
                     50: { 1S 1S AND -> 1S }
                     51: 
                     52: { 0S 0S OR -> 0S }
                     53: { 0S 1S OR -> 1S }
                     54: { 1S 0S OR -> 1S }
                     55: { 1S 1S OR -> 1S }
                     56: 
                     57: { 0S 0S XOR -> 0S }
                     58: { 0S 1S XOR -> 1S }
                     59: { 1S 0S XOR -> 1S }
                     60: { 1S 1S XOR -> 0S }
                     61: 
                     62: \ ------------------------------------------------------------------------
                     63: TESTING 2* 2/ LSHIFT RSHIFT
                     64: 
                     65: ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
                     66: 1S 1 RSHIFT INVERT CONSTANT MSB
                     67: { MSB BITSSET? -> 0 0 }
                     68: 
                     69: { 0S 2* -> 0S }
                     70: { 1 2* -> 2 }
                     71: { 4000 2* -> 8000 }
                     72: { 1S 2* 1 XOR -> 1S }
                     73: { MSB 2* -> 0S }
                     74: 
                     75: { 0S 2/ -> 0S }
                     76: { 1 2/ -> 0 }
                     77: { 4000 2/ -> 2000 }
                     78: { 1S 2/ -> 1S }                                \ MSB PROPOGATED
                     79: { 1S 1 XOR 2/ -> 1S }
                     80: { MSB 2/ MSB AND -> MSB }
                     81: 
                     82: { 1 0 LSHIFT -> 1 }
                     83: { 1 1 LSHIFT -> 2 }
                     84: { 1 2 LSHIFT -> 4 }
                     85: { 1 F LSHIFT -> 8000 }                 \ BIGGEST GUARANTEED SHIFT
                     86: { 1S 1 LSHIFT 1 XOR -> 1S }
                     87: { MSB 1 LSHIFT -> 0 }
                     88: 
                     89: { 1 0 RSHIFT -> 1 }
                     90: { 1 1 RSHIFT -> 0 }
                     91: { 2 1 RSHIFT -> 1 }
                     92: { 4 2 RSHIFT -> 1 }
                     93: { 8000 F RSHIFT -> 1 }                 \ BIGGEST
                     94: { MSB 1 RSHIFT MSB AND -> 0 }          \ RSHIFT ZERO FILLS MSBS
                     95: { MSB 1 RSHIFT 2* -> MSB }
                     96: 
                     97: \ ------------------------------------------------------------------------
                     98: TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
                     99: 0 INVERT                       CONSTANT MAX-UINT
                    100: 0 INVERT 1 RSHIFT              CONSTANT MAX-INT
                    101: 0 INVERT 1 RSHIFT INVERT       CONSTANT MIN-INT
                    102: 0 INVERT 1 RSHIFT              CONSTANT MID-UINT
                    103: 0 INVERT 1 RSHIFT INVERT       CONSTANT MID-UINT+1
                    104: 
                    105: 0S CONSTANT <FALSE>
                    106: 1S CONSTANT <TRUE>
                    107: 
                    108: { 0 0= -> <TRUE> }
                    109: { 1 0= -> <FALSE> }
                    110: { 2 0= -> <FALSE> }
                    111: { -1 0= -> <FALSE> }
                    112: { MAX-UINT 0= -> <FALSE> }
                    113: { MIN-INT 0= -> <FALSE> }
                    114: { MAX-INT 0= -> <FALSE> }
                    115: 
                    116: { 0 0 = -> <TRUE> }
                    117: { 1 1 = -> <TRUE> }
                    118: { -1 -1 = -> <TRUE> }
                    119: { 1 0 = -> <FALSE> }
                    120: { -1 0 = -> <FALSE> }
                    121: { 0 1 = -> <FALSE> }
                    122: { 0 -1 = -> <FALSE> }
                    123: 
                    124: { 0 0< -> <FALSE> }
                    125: { -1 0< -> <TRUE> }
                    126: { MIN-INT 0< -> <TRUE> }
                    127: { 1 0< -> <FALSE> }
                    128: { MAX-INT 0< -> <FALSE> }
                    129: 
                    130: { 0 1 < -> <TRUE> }
                    131: { 1 2 < -> <TRUE> }
                    132: { -1 0 < -> <TRUE> }
                    133: { -1 1 < -> <TRUE> }
                    134: { MIN-INT 0 < -> <TRUE> }
                    135: { MIN-INT MAX-INT < -> <TRUE> }
                    136: { 0 MAX-INT < -> <TRUE> }
                    137: { 0 0 < -> <FALSE> }
                    138: { 1 1 < -> <FALSE> }
                    139: { 1 0 < -> <FALSE> }
                    140: { 2 1 < -> <FALSE> }
                    141: { 0 -1 < -> <FALSE> }
                    142: { 1 -1 < -> <FALSE> }
                    143: { 0 MIN-INT < -> <FALSE> }
                    144: { MAX-INT MIN-INT < -> <FALSE> }
                    145: { MAX-INT 0 < -> <FALSE> }
                    146: 
                    147: { 0 1 > -> <FALSE> }
                    148: { 1 2 > -> <FALSE> }
                    149: { -1 0 > -> <FALSE> }
                    150: { -1 1 > -> <FALSE> }
                    151: { MIN-INT 0 > -> <FALSE> }
                    152: { MIN-INT MAX-INT > -> <FALSE> }
                    153: { 0 MAX-INT > -> <FALSE> }
                    154: { 0 0 > -> <FALSE> }
                    155: { 1 1 > -> <FALSE> }
                    156: { 1 0 > -> <TRUE> }
                    157: { 2 1 > -> <TRUE> }
                    158: { 0 -1 > -> <TRUE> }
                    159: { 1 -1 > -> <TRUE> }
                    160: { 0 MIN-INT > -> <TRUE> }
                    161: { MAX-INT MIN-INT > -> <TRUE> }
                    162: { MAX-INT 0 > -> <TRUE> }
                    163: 
                    164: { 0 1 U< -> <TRUE> }
                    165: { 1 2 U< -> <TRUE> }
                    166: { 0 MID-UINT U< -> <TRUE> }
                    167: { 0 MAX-UINT U< -> <TRUE> }
                    168: { MID-UINT MAX-UINT U< -> <TRUE> }
                    169: { 0 0 U< -> <FALSE> }
                    170: { 1 1 U< -> <FALSE> }
                    171: { 1 0 U< -> <FALSE> }
                    172: { 2 1 U< -> <FALSE> }
                    173: { MID-UINT 0 U< -> <FALSE> }
                    174: { MAX-UINT 0 U< -> <FALSE> }
                    175: { MAX-UINT MID-UINT U< -> <FALSE> }
                    176: 
                    177: { 0 1 MIN -> 0 }
                    178: { 1 2 MIN -> 1 }
                    179: { -1 0 MIN -> -1 }
                    180: { -1 1 MIN -> -1 }
                    181: { MIN-INT 0 MIN -> MIN-INT }
                    182: { MIN-INT MAX-INT MIN -> MIN-INT }
                    183: { 0 MAX-INT MIN -> 0 }
                    184: { 0 0 MIN -> 0 }
                    185: { 1 1 MIN -> 1 }
                    186: { 1 0 MIN -> 0 }
                    187: { 2 1 MIN -> 1 }
                    188: { 0 -1 MIN -> -1 }
                    189: { 1 -1 MIN -> -1 }
                    190: { 0 MIN-INT MIN -> MIN-INT }
                    191: { MAX-INT MIN-INT MIN -> MIN-INT }
                    192: { MAX-INT 0 MIN -> 0 }
                    193: 
                    194: { 0 1 MAX -> 1 }
                    195: { 1 2 MAX -> 2 }
                    196: { -1 0 MAX -> 0 }
                    197: { -1 1 MAX -> 1 }
                    198: { MIN-INT 0 MAX -> 0 }
                    199: { MIN-INT MAX-INT MAX -> MAX-INT }
                    200: { 0 MAX-INT MAX -> MAX-INT }
                    201: { 0 0 MAX -> 0 }
                    202: { 1 1 MAX -> 1 }
                    203: { 1 0 MAX -> 1 }
                    204: { 2 1 MAX -> 2 }
                    205: { 0 -1 MAX -> 0 }
                    206: { 1 -1 MAX -> 1 }
                    207: { 0 MIN-INT MAX -> 0 }
                    208: { MAX-INT MIN-INT MAX -> MAX-INT }
                    209: { MAX-INT 0 MAX -> MAX-INT }
                    210: 
                    211: \ ------------------------------------------------------------------------
                    212: TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
                    213: 
                    214: { 1 2 2DROP -> }
                    215: { 1 2 2DUP -> 1 2 1 2 }
                    216: { 1 2 3 4 2OVER -> 1 2 3 4 1 2 }
                    217: { 1 2 3 4 2SWAP -> 3 4 1 2 }
                    218: { 0 ?DUP -> 0 }
                    219: { 1 ?DUP -> 1 1 }
                    220: { -1 ?DUP -> -1 -1 }
                    221: { DEPTH -> 0 }
                    222: { 0 DEPTH -> 0 1 }
                    223: { 0 1 DEPTH -> 0 1 2 }
                    224: { 0 DROP -> }
                    225: { 1 2 DROP -> 1 }
                    226: { 1 DUP -> 1 1 }
                    227: { 1 2 OVER -> 1 2 1 }
                    228: { 1 2 3 ROT -> 2 3 1 }
                    229: { 1 2 SWAP -> 2 1 }
                    230: 
                    231: \ ------------------------------------------------------------------------
                    232: TESTING >R R> R@
                    233: 
                    234: { : GR1 >R R> ; -> }
                    235: { : GR2 >R R@ R> DROP ; -> }
                    236: { 123 GR1 -> 123 }
                    237: { 123 GR2 -> 123 }
                    238: { 1S GR1 -> 1S }   ( RETURN STACK HOLDS CELLS )
                    239: 
                    240: \ ------------------------------------------------------------------------
                    241: TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
                    242: 
                    243: { 0 5 + -> 5 }
                    244: { 5 0 + -> 5 }
                    245: { 0 -5 + -> -5 }
                    246: { -5 0 + -> -5 }
                    247: { 1 2 + -> 3 }
                    248: { 1 -2 + -> -1 }
                    249: { -1 2 + -> 1 }
                    250: { -1 -2 + -> -3 }
                    251: { -1 1 + -> 0 }
                    252: { MID-UINT 1 + -> MID-UINT+1 }
                    253: 
                    254: { 0 5 - -> -5 }
                    255: { 5 0 - -> 5 }
                    256: { 0 -5 - -> 5 }
                    257: { -5 0 - -> -5 }
                    258: { 1 2 - -> -1 }
                    259: { 1 -2 - -> 3 }
                    260: { -1 2 - -> -3 }
                    261: { -1 -2 - -> 1 }
                    262: { 0 1 - -> -1 }
                    263: { MID-UINT+1 1 - -> MID-UINT }
                    264: 
                    265: { 0 1+ -> 1 }
                    266: { -1 1+ -> 0 }
                    267: { 1 1+ -> 2 }
                    268: { MID-UINT 1+ -> MID-UINT+1 }
                    269: 
                    270: { 2 1- -> 1 }
                    271: { 1 1- -> 0 }
                    272: { 0 1- -> -1 }
                    273: { MID-UINT+1 1- -> MID-UINT }
                    274: 
                    275: { 0 NEGATE -> 0 }
                    276: { 1 NEGATE -> -1 }
                    277: { -1 NEGATE -> 1 }
                    278: { 2 NEGATE -> -2 }
                    279: { -2 NEGATE -> 2 }
                    280: 
                    281: { 0 ABS -> 0 }
                    282: { 1 ABS -> 1 }
                    283: { -1 ABS -> 1 }
                    284: { MIN-INT ABS -> MID-UINT+1 }
                    285: 
                    286: \ ------------------------------------------------------------------------
                    287: TESTING MULTIPLY: S>D * M* UM*
                    288: 
                    289: { 0 S>D -> 0 0 }
                    290: { 1 S>D -> 1 0 }
                    291: { 2 S>D -> 2 0 }
                    292: { -1 S>D -> -1 -1 }
                    293: { -2 S>D -> -2 -1 }
                    294: { MIN-INT S>D -> MIN-INT -1 }
                    295: { MAX-INT S>D -> MAX-INT 0 }
                    296: 
                    297: { 0 0 M* -> 0 S>D }
                    298: { 0 1 M* -> 0 S>D }
                    299: { 1 0 M* -> 0 S>D }
                    300: { 1 2 M* -> 2 S>D }
                    301: { 2 1 M* -> 2 S>D }
                    302: { 3 3 M* -> 9 S>D }
                    303: { -3 3 M* -> -9 S>D }
                    304: { 3 -3 M* -> -9 S>D }
                    305: { -3 -3 M* -> 9 S>D }
                    306: { 0 MIN-INT M* -> 0 S>D }
                    307: { 1 MIN-INT M* -> MIN-INT S>D }
                    308: { 2 MIN-INT M* -> 0 1S }
                    309: { 0 MAX-INT M* -> 0 S>D }
                    310: { 1 MAX-INT M* -> MAX-INT S>D }
                    311: { 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }
                    312: { MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }
                    313: { MAX-INT MIN-INT M* -> MSB MSB 2/ }
                    314: { MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }
                    315: 
                    316: { 0 0 * -> 0 }                         \ TEST IDENTITIES
                    317: { 0 1 * -> 0 }
                    318: { 1 0 * -> 0 }
                    319: { 1 2 * -> 2 }
                    320: { 2 1 * -> 2 }
                    321: { 3 3 * -> 9 }
                    322: { -3 3 * -> -9 }
                    323: { 3 -3 * -> -9 }
                    324: { -3 -3 * -> 9 }
                    325: 
                    326: { MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }
                    327: { MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }
                    328: { MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }
                    329: 
                    330: { 0 0 UM* -> 0 0 }
                    331: { 0 1 UM* -> 0 0 }
                    332: { 1 0 UM* -> 0 0 }
                    333: { 1 2 UM* -> 2 0 }
                    334: { 2 1 UM* -> 2 0 }
                    335: { 3 3 UM* -> 9 0 }
                    336: 
                    337: { MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }
                    338: { MID-UINT+1 2 UM* -> 0 1 }
                    339: { MID-UINT+1 4 UM* -> 0 2 }
                    340: { 1S 2 UM* -> 1S 1 LSHIFT 1 }
                    341: { MAX-UINT MAX-UINT UM* -> 1 1 INVERT }
                    342: 
                    343: \ ------------------------------------------------------------------------
                    344: TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
                    345: 
                    346: { 0 S>D 1 FM/MOD -> 0 0 }
                    347: { 1 S>D 1 FM/MOD -> 0 1 }
                    348: { 2 S>D 1 FM/MOD -> 0 2 }
                    349: { -1 S>D 1 FM/MOD -> 0 -1 }
                    350: { -2 S>D 1 FM/MOD -> 0 -2 }
                    351: { 0 S>D -1 FM/MOD -> 0 0 }
                    352: { 1 S>D -1 FM/MOD -> 0 -1 }
                    353: { 2 S>D -1 FM/MOD -> 0 -2 }
                    354: { -1 S>D -1 FM/MOD -> 0 1 }
                    355: { -2 S>D -1 FM/MOD -> 0 2 }
                    356: { 2 S>D 2 FM/MOD -> 0 1 }
                    357: { -1 S>D -1 FM/MOD -> 0 1 }
                    358: { -2 S>D -2 FM/MOD -> 0 1 }
                    359: {  7 S>D  3 FM/MOD -> 1 2 }
                    360: {  7 S>D -3 FM/MOD -> -2 -3 }
                    361: { -7 S>D  3 FM/MOD -> 2 -3 }
                    362: { -7 S>D -3 FM/MOD -> -1 2 }
                    363: { MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }
                    364: { MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }
                    365: { MAX-INT S>D MAX-INT FM/MOD -> 0 1 }
                    366: { MIN-INT S>D MIN-INT FM/MOD -> 0 1 }
                    367: { 1S 1 4 FM/MOD -> 3 MAX-INT }
                    368: { 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }
                    369: { 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }
                    370: { 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }
                    371: { 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }
                    372: { 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }
                    373: { 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }
                    374: { 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }
                    375: { 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }
                    376: { MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }
                    377: { MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }
                    378: { MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }
                    379: { MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }
                    380: 
                    381: { 0 S>D 1 SM/REM -> 0 0 }
                    382: { 1 S>D 1 SM/REM -> 0 1 }
                    383: { 2 S>D 1 SM/REM -> 0 2 }
                    384: { -1 S>D 1 SM/REM -> 0 -1 }
                    385: { -2 S>D 1 SM/REM -> 0 -2 }
                    386: { 0 S>D -1 SM/REM -> 0 0 }
                    387: { 1 S>D -1 SM/REM -> 0 -1 }
                    388: { 2 S>D -1 SM/REM -> 0 -2 }
                    389: { -1 S>D -1 SM/REM -> 0 1 }
                    390: { -2 S>D -1 SM/REM -> 0 2 }
                    391: { 2 S>D 2 SM/REM -> 0 1 }
                    392: { -1 S>D -1 SM/REM -> 0 1 }
                    393: { -2 S>D -2 SM/REM -> 0 1 }
                    394: {  7 S>D  3 SM/REM -> 1 2 }
                    395: {  7 S>D -3 SM/REM -> 1 -2 }
                    396: { -7 S>D  3 SM/REM -> -1 -2 }
                    397: { -7 S>D -3 SM/REM -> -1 2 }
                    398: { MAX-INT S>D 1 SM/REM -> 0 MAX-INT }
                    399: { MIN-INT S>D 1 SM/REM -> 0 MIN-INT }
                    400: { MAX-INT S>D MAX-INT SM/REM -> 0 1 }
                    401: { MIN-INT S>D MIN-INT SM/REM -> 0 1 }
                    402: { 1S 1 4 SM/REM -> 3 MAX-INT }
                    403: { 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }
                    404: { 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }
                    405: { 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }
                    406: { 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }
                    407: { MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }
                    408: { MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }
                    409: { MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }
                    410: { MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }
                    411: 
                    412: { 0 0 1 UM/MOD -> 0 0 }
                    413: { 1 0 1 UM/MOD -> 0 1 }
                    414: { 1 0 2 UM/MOD -> 1 0 }
                    415: { 3 0 2 UM/MOD -> 1 1 }
                    416: { MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }
                    417: { MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }
                    418: { MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }
                    419: 
                    420: : IFFLOORED
                    421:    [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
                    422: : IFSYM
                    423:    [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
                    424: 
                    425: \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
                    426: \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
                    427: IFFLOORED : T/MOD  >R S>D R> FM/MOD ;
                    428: IFFLOORED : T/     T/MOD SWAP DROP ;
                    429: IFFLOORED : TMOD   T/MOD DROP ;
                    430: IFFLOORED : T*/MOD >R M* R> FM/MOD ;
                    431: IFFLOORED : T*/    T*/MOD SWAP DROP ;
                    432: IFSYM     : T/MOD  >R S>D R> SM/REM ;
                    433: IFSYM     : T/     T/MOD SWAP DROP ;
                    434: IFSYM     : TMOD   T/MOD DROP ;
                    435: IFSYM     : T*/MOD >R M* R> SM/REM ;
                    436: IFSYM     : T*/    T*/MOD SWAP DROP ;
                    437: 
                    438: { 0 1 /MOD -> 0 1 T/MOD }
                    439: { 1 1 /MOD -> 1 1 T/MOD }
                    440: { 2 1 /MOD -> 2 1 T/MOD }
                    441: { -1 1 /MOD -> -1 1 T/MOD }
                    442: { -2 1 /MOD -> -2 1 T/MOD }
                    443: { 0 -1 /MOD -> 0 -1 T/MOD }
                    444: { 1 -1 /MOD -> 1 -1 T/MOD }
                    445: { 2 -1 /MOD -> 2 -1 T/MOD }
                    446: { -1 -1 /MOD -> -1 -1 T/MOD }
                    447: { -2 -1 /MOD -> -2 -1 T/MOD }
                    448: { 2 2 /MOD -> 2 2 T/MOD }
                    449: { -1 -1 /MOD -> -1 -1 T/MOD }
                    450: { -2 -2 /MOD -> -2 -2 T/MOD }
                    451: { 7 3 /MOD -> 7 3 T/MOD }
                    452: { 7 -3 /MOD -> 7 -3 T/MOD }
                    453: { -7 3 /MOD -> -7 3 T/MOD }
                    454: { -7 -3 /MOD -> -7 -3 T/MOD }
                    455: { MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }
                    456: { MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }
                    457: { MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }
                    458: { MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }
                    459: 
                    460: { 0 1 / -> 0 1 T/ }
                    461: { 1 1 / -> 1 1 T/ }
                    462: { 2 1 / -> 2 1 T/ }
                    463: { -1 1 / -> -1 1 T/ }
                    464: { -2 1 / -> -2 1 T/ }
                    465: { 0 -1 / -> 0 -1 T/ }
                    466: { 1 -1 / -> 1 -1 T/ }
                    467: { 2 -1 / -> 2 -1 T/ }
                    468: { -1 -1 / -> -1 -1 T/ }
                    469: { -2 -1 / -> -2 -1 T/ }
                    470: { 2 2 / -> 2 2 T/ }
                    471: { -1 -1 / -> -1 -1 T/ }
                    472: { -2 -2 / -> -2 -2 T/ }
                    473: { 7 3 / -> 7 3 T/ }
                    474: { 7 -3 / -> 7 -3 T/ }
                    475: { -7 3 / -> -7 3 T/ }
                    476: { -7 -3 / -> -7 -3 T/ }
                    477: { MAX-INT 1 / -> MAX-INT 1 T/ }
                    478: { MIN-INT 1 / -> MIN-INT 1 T/ }
                    479: { MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }
                    480: { MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }
                    481: 
                    482: { 0 1 MOD -> 0 1 TMOD }
                    483: { 1 1 MOD -> 1 1 TMOD }
                    484: { 2 1 MOD -> 2 1 TMOD }
                    485: { -1 1 MOD -> -1 1 TMOD }
                    486: { -2 1 MOD -> -2 1 TMOD }
                    487: { 0 -1 MOD -> 0 -1 TMOD }
                    488: { 1 -1 MOD -> 1 -1 TMOD }
                    489: { 2 -1 MOD -> 2 -1 TMOD }
                    490: { -1 -1 MOD -> -1 -1 TMOD }
                    491: { -2 -1 MOD -> -2 -1 TMOD }
                    492: { 2 2 MOD -> 2 2 TMOD }
                    493: { -1 -1 MOD -> -1 -1 TMOD }
                    494: { -2 -2 MOD -> -2 -2 TMOD }
                    495: { 7 3 MOD -> 7 3 TMOD }
                    496: { 7 -3 MOD -> 7 -3 TMOD }
                    497: { -7 3 MOD -> -7 3 TMOD }
                    498: { -7 -3 MOD -> -7 -3 TMOD }
                    499: { MAX-INT 1 MOD -> MAX-INT 1 TMOD }
                    500: { MIN-INT 1 MOD -> MIN-INT 1 TMOD }
                    501: { MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }
                    502: { MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }
                    503: 
                    504: { 0 2 1 */ -> 0 2 1 T*/ }
                    505: { 1 2 1 */ -> 1 2 1 T*/ }
                    506: { 2 2 1 */ -> 2 2 1 T*/ }
                    507: { -1 2 1 */ -> -1 2 1 T*/ }
                    508: { -2 2 1 */ -> -2 2 1 T*/ }
                    509: { 0 2 -1 */ -> 0 2 -1 T*/ }
                    510: { 1 2 -1 */ -> 1 2 -1 T*/ }
                    511: { 2 2 -1 */ -> 2 2 -1 T*/ }
                    512: { -1 2 -1 */ -> -1 2 -1 T*/ }
                    513: { -2 2 -1 */ -> -2 2 -1 T*/ }
                    514: { 2 2 2 */ -> 2 2 2 T*/ }
                    515: { -1 2 -1 */ -> -1 2 -1 T*/ }
                    516: { -2 2 -2 */ -> -2 2 -2 T*/ }
                    517: { 7 2 3 */ -> 7 2 3 T*/ }
                    518: { 7 2 -3 */ -> 7 2 -3 T*/ }
                    519: { -7 2 3 */ -> -7 2 3 T*/ }
                    520: { -7 2 -3 */ -> -7 2 -3 T*/ }
                    521: { MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }
                    522: { MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }
                    523: 
                    524: { 0 2 1 */MOD -> 0 2 1 T*/MOD }
                    525: { 1 2 1 */MOD -> 1 2 1 T*/MOD }
                    526: { 2 2 1 */MOD -> 2 2 1 T*/MOD }
                    527: { -1 2 1 */MOD -> -1 2 1 T*/MOD }
                    528: { -2 2 1 */MOD -> -2 2 1 T*/MOD }
                    529: { 0 2 -1 */MOD -> 0 2 -1 T*/MOD }
                    530: { 1 2 -1 */MOD -> 1 2 -1 T*/MOD }
                    531: { 2 2 -1 */MOD -> 2 2 -1 T*/MOD }
                    532: { -1 2 -1 */MOD -> -1 2 -1 T*/MOD }
                    533: { -2 2 -1 */MOD -> -2 2 -1 T*/MOD }
                    534: { 2 2 2 */MOD -> 2 2 2 T*/MOD }
                    535: { -1 2 -1 */MOD -> -1 2 -1 T*/MOD }
                    536: { -2 2 -2 */MOD -> -2 2 -2 T*/MOD }
                    537: { 7 2 3 */MOD -> 7 2 3 T*/MOD }
                    538: { 7 2 -3 */MOD -> 7 2 -3 T*/MOD }
                    539: { -7 2 3 */MOD -> -7 2 3 T*/MOD }
                    540: { -7 2 -3 */MOD -> -7 2 -3 T*/MOD }
                    541: { MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }
                    542: { MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }
                    543: 
                    544: \ ------------------------------------------------------------------------
                    545: TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
                    546: 
                    547: HERE 1 ALLOT
                    548: HERE
                    549: CONSTANT 2NDA
                    550: CONSTANT 1STA
                    551: { 1STA 2NDA U< -> <TRUE> }             \ HERE MUST GROW WITH ALLOT
                    552: { 1STA 1+ -> 2NDA }                    \ ... BY ONE ADDRESS UNIT
                    553: ( MISSING TEST: NEGATIVE ALLOT )
                    554: 
                    555: HERE 1 ,
                    556: HERE 2 ,
                    557: CONSTANT 2ND
                    558: CONSTANT 1ST
                    559: { 1ST 2ND U< -> <TRUE> }                       \ HERE MUST GROW WITH ALLOT
                    560: { 1ST CELL+ -> 2ND }                   \ ... BY ONE CELL
                    561: { 1ST 1 CELLS + -> 2ND }
                    562: { 1ST @ 2ND @ -> 1 2 }
                    563: { 5 1ST ! -> }
                    564: { 1ST @ 2ND @ -> 5 2 }
                    565: { 6 2ND ! -> }
                    566: { 1ST @ 2ND @ -> 5 6 }
                    567: { 1ST 2@ -> 6 5 }
                    568: { 2 1 1ST 2! -> }
                    569: { 1ST 2@ -> 2 1 }
                    570: { 1S 1ST !  1ST @ -> 1S }              \ CAN STORE CELL-WIDE VALUE
                    571: 
                    572: HERE 1 C,
                    573: HERE 2 C,
                    574: CONSTANT 2NDC
                    575: CONSTANT 1STC
                    576: { 1STC 2NDC U< -> <TRUE> }             \ HERE MUST GROW WITH ALLOT
                    577: { 1STC CHAR+ -> 2NDC }                 \ ... BY ONE CHAR
                    578: { 1STC 1 CHARS + -> 2NDC }
                    579: { 1STC C@ 2NDC C@ -> 1 2 }
                    580: { 3 1STC C! -> }
                    581: { 1STC C@ 2NDC C@ -> 3 2 }
                    582: { 4 2NDC C! -> }
                    583: { 1STC C@ 2NDC C@ -> 3 4 }
                    584: 
                    585: ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
                    586: CONSTANT A-ADDR  CONSTANT UA-ADDR
                    587: { UA-ADDR ALIGNED -> A-ADDR }
                    588: {    1 A-ADDR C!  A-ADDR C@ ->    1 }
                    589: { 1234 A-ADDR  !  A-ADDR  @ -> 1234 }
                    590: { 123 456 A-ADDR 2!  A-ADDR 2@ -> 123 456 }
                    591: { 2 A-ADDR CHAR+ C!  A-ADDR CHAR+ C@ -> 2 }
                    592: { 3 A-ADDR CELL+ C!  A-ADDR CELL+ C@ -> 3 }
                    593: { 1234 A-ADDR CELL+ !  A-ADDR CELL+ @ -> 1234 }
                    594: { 123 456 A-ADDR CELL+ 2!  A-ADDR CELL+ 2@ -> 123 456 }
                    595: 
                    596: : BITS ( X -- U )
                    597:    0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
                    598: ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
                    599: { 1 CHARS 1 < -> <FALSE> }
                    600: { 1 CHARS 1 CELLS > -> <FALSE> }
                    601: ( TBD: HOW TO FIND NUMBER OF BITS? )
                    602: 
                    603: ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
                    604: { 1 CELLS 1 < -> <FALSE> }
                    605: { 1 CELLS 1 CHARS MOD -> 0 }
                    606: { 1S BITS 10 < -> <FALSE> }
                    607: 
                    608: { 0 1ST ! -> }
                    609: { 1 1ST +! -> }
                    610: { 1ST @ -> 1 }
                    611: { -1 1ST +! 1ST @ -> 0 }
                    612: 
                    613: \ ------------------------------------------------------------------------
                    614: TESTING CHAR [CHAR] [ ] BL S"
                    615: 
                    616: { BL -> 20 }
                    617: { CHAR X -> 58 }
                    618: { CHAR HELLO -> 48 }
                    619: { : GC1 [CHAR] X ; -> }
                    620: { : GC2 [CHAR] HELLO ; -> }
                    621: { GC1 -> 58 }
                    622: { GC2 -> 48 }
                    623: { : GC3 [ GC1 ] LITERAL ; -> }
                    624: { GC3 -> 58 }
                    625: { : GC4 S" XY" ; -> }
                    626: { GC4 SWAP DROP -> 2 }
                    627: { GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }
                    628: 
                    629: \ ------------------------------------------------------------------------
                    630: TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
                    631: 
                    632: { : GT1 123 ; -> }
                    633: { ' GT1 EXECUTE -> 123 }
                    634: { : GT2 ['] GT1 ; IMMEDIATE -> }
                    635: { GT2 EXECUTE -> 123 }
                    636: HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
                    637: HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
                    638: { GT1STRING FIND -> ' GT1 -1 }
                    639: { GT2STRING FIND -> ' GT2 1 }
                    640: ( HOW TO SEARCH FOR NON-EXISTENT WORD? )
                    641: { : GT3 GT2 LITERAL ; -> }
                    642: { GT3 -> ' GT1 }
                    643: { GT1STRING COUNT -> GT1STRING CHAR+ 3 }
                    644: 
                    645: { : GT4 POSTPONE GT1 ; IMMEDIATE -> }
                    646: { : GT5 GT4 ; -> }
                    647: { GT5 -> 123 }
                    648: { : GT6 345 ; IMMEDIATE -> }
                    649: { : GT7 POSTPONE GT6 ; -> }
                    650: { GT7 -> 345 }
                    651: 
                    652: { : GT8 STATE @ ; IMMEDIATE -> }
                    653: { GT8 -> 0 }
                    654: { : GT9 GT8 LITERAL ; -> }
                    655: { GT9 0= -> <FALSE> }
                    656: 
                    657: \ ------------------------------------------------------------------------
                    658: TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
                    659: 
                    660: { : GI1 IF 123 THEN ; -> }
                    661: { : GI2 IF 123 ELSE 234 THEN ; -> }
                    662: { 0 GI1 -> }
                    663: { 1 GI1 -> 123 }
                    664: { -1 GI1 -> 123 }
                    665: { 0 GI2 -> 234 }
                    666: { 1 GI2 -> 123 }
                    667: { -1 GI1 -> 123 }
                    668: 
                    669: { : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }
                    670: { 0 GI3 -> 0 1 2 3 4 5 }
                    671: { 4 GI3 -> 4 5 }
                    672: { 5 GI3 -> 5 }
                    673: { 6 GI3 -> 6 }
                    674: 
                    675: { : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }
                    676: { 3 GI4 -> 3 4 5 6 }
                    677: { 5 GI4 -> 5 6 }
                    678: { 6 GI4 -> 6 7 }
                    679: 
                    680: { : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }
                    681: { 1 GI5 -> 1 345 }
                    682: { 2 GI5 -> 2 345 }
                    683: { 3 GI5 -> 3 4 5 123 }
                    684: { 4 GI5 -> 4 5 123 }
                    685: { 5 GI5 -> 5 123 }
                    686: 
                    687: { : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }
                    688: { 0 GI6 -> 0 }
                    689: { 1 GI6 -> 0 1 }
                    690: { 2 GI6 -> 0 1 2 }
                    691: { 3 GI6 -> 0 1 2 3 }
                    692: { 4 GI6 -> 0 1 2 3 4 }
                    693: 
                    694: \ ------------------------------------------------------------------------
                    695: TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
                    696: 
                    697: { : GD1 DO I LOOP ; -> }
                    698: { 4 1 GD1 -> 1 2 3 }
                    699: { 2 -1 GD1 -> -1 0 1 }
                    700: { MID-UINT+1 MID-UINT GD1 -> MID-UINT }
                    701: 
                    702: { : GD2 DO I -1 +LOOP ; -> }
                    703: { 1 4 GD2 -> 4 3 2 1 }
                    704: { -1 2 GD2 -> 2 1 0 -1 }
                    705: { MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }
                    706: 
                    707: { : GD3 DO 1 0 DO J LOOP LOOP ; -> }
                    708: { 4 1 GD3 -> 1 2 3 }
                    709: { 2 -1 GD3 -> -1 0 1 }
                    710: { MID-UINT+1 MID-UINT GD3 -> MID-UINT }
                    711: 
                    712: { : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }
                    713: { 1 4 GD4 -> 4 3 2 1 }
                    714: { -1 2 GD4 -> 2 1 0 -1 }
                    715: { MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }
                    716: 
                    717: { : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }
                    718: { 1 GD5 -> 123 }
                    719: { 5 GD5 -> 123 }
                    720: { 6 GD5 -> 234 }
                    721: 
                    722: { : GD6  ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} )
                    723:    0 SWAP 0 DO
                    724:       I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
                    725:     LOOP ; -> }
                    726: { 1 GD6 -> 1 }
                    727: { 2 GD6 -> 3 }
                    728: { 3 GD6 -> 4 1 2 }
                    729: 
                    730: \ ------------------------------------------------------------------------
                    731: TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
                    732: 
                    733: { 123 CONSTANT X123 -> }
                    734: { X123 -> 123 }
                    735: { : EQU CONSTANT ; -> }
                    736: { X123 EQU Y123 -> }
                    737: { Y123 -> 123 }
                    738: 
                    739: { VARIABLE V1 -> }
                    740: { 123 V1 ! -> }
                    741: { V1 @ -> 123 }
                    742: 
                    743: { : NOP : POSTPONE ; ; -> }
                    744: { NOP NOP1 NOP NOP2 -> }
                    745: { NOP1 -> }
                    746: { NOP2 -> }
                    747: 
                    748: { : DOES1 DOES> @ 1 + ; -> }
                    749: { : DOES2 DOES> @ 2 + ; -> }
                    750: { CREATE CR1 -> }
                    751: { CR1 -> HERE }
                    752: { ' CR1 >BODY -> HERE }
                    753: { 1 , -> }
                    754: { CR1 @ -> 1 }
                    755: { DOES1 -> }
                    756: { CR1 -> 2 }
                    757: { DOES2 -> }
                    758: { CR1 -> 3 }
                    759: 
                    760: { : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }
                    761: { WEIRD: W1 -> }
                    762: { ' W1 >BODY -> HERE }
                    763: { W1 -> HERE 1 + }
                    764: { W1 -> HERE 2 + }
                    765: 
                    766: \ ------------------------------------------------------------------------
                    767: TESTING EVALUATE
                    768: 
                    769: : GE1 S" 123" ; IMMEDIATE
                    770: : GE2 S" 123 1+" ; IMMEDIATE
                    771: : GE3 S" : GE4 345 ;" ;
                    772: : GE5 EVALUATE ; IMMEDIATE
                    773: 
                    774: { GE1 EVALUATE -> 123 }                        ( TEST EVALUATE IN INTERP. STATE )
                    775: { GE2 EVALUATE -> 124 }
                    776: { GE3 EVALUATE -> }
                    777: { GE4 -> 345 }
                    778: 
                    779: { : GE6 GE1 GE5 ; -> }                 ( TEST EVALUATE IN COMPILE STATE )
                    780: { GE6 -> 123 }
                    781: { : GE7 GE2 GE5 ; -> }
                    782: { GE7 -> 124 }
                    783: 
                    784: \ ------------------------------------------------------------------------
                    785: TESTING SOURCE >IN WORD
                    786: 
                    787: : GS1 S" SOURCE" 2DUP EVALUATE
                    788:        >R SWAP >R = R> R> = ;
                    789: { GS1 -> <TRUE> <TRUE> }
                    790: 
                    791: VARIABLE SCANS
                    792: : RESCAN?  -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
                    793: 
                    794: { 2 SCANS !
                    795: 345 RESCAN?
                    796: -> 345 345 }
                    797: 
                    798: : GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
                    799: { GS2 -> 123 123 123 123 123 }
                    800: 
                    801: : GS3 WORD COUNT SWAP C@ ;
                    802: { BL GS3 HELLO -> 5 CHAR H }
                    803: { CHAR " GS3 GOODBYE" -> 7 CHAR G }
                    804: { BL GS3
                    805: DROP -> 0 }                            \ BLANK LINE RETURN ZERO-LENGTH STRING
                    806: 
                    807: : GS4 SOURCE >IN ! DROP ;
                    808: { GS4 123 456
                    809: -> }
                    810: 
                    811: \ ------------------------------------------------------------------------
                    812: TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
                    813: 
                    814: : S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
                    815:    >R SWAP R@ = IF                     \ MAKE SURE STRINGS HAVE SAME LENGTH
                    816:       R> ?DUP IF                       \ IF NON-EMPTY STRINGS
                    817:         0 DO
                    818:            OVER C@ OVER C@ - IF 2DROP <FALSE> UNLOOP EXIT THEN
                    819:            SWAP CHAR+ SWAP CHAR+
                    820:          LOOP
                    821:       THEN
                    822:       2DROP <TRUE>                     \ IF WE GET HERE, STRINGS MATCH
                    823:    ELSE
                    824:       R> DROP 2DROP <FALSE>            \ LENGTHS MISMATCH
                    825:    THEN ;
                    826: 
                    827: : GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
                    828: { GP1 -> <TRUE> }
                    829: 
                    830: : GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
                    831: { GP2 -> <TRUE> }
                    832: 
                    833: : GP3  <# 1 0 # # #> S" 01" S= ;
                    834: { GP3 -> <TRUE> }
                    835: 
                    836: : GP4  <# 1 0 #S #> S" 1" S= ;
                    837: { GP4 -> <TRUE> }
                    838: 
                    839: 24 CONSTANT MAX-BASE                   \ BASE 2 .. 36
                    840: : COUNT-BITS
                    841:    0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
                    842: COUNT-BITS 2* CONSTANT #BITS-UD                \ NUMBER OF BITS IN UD
                    843: 
                    844: : GP5
                    845:    BASE @ <TRUE>
                    846:    MAX-BASE 1+ 2 DO                    \ FOR EACH POSSIBLE BASE
                    847:       I BASE !                         \ TBD: ASSUMES BASE WORKS
                    848:       I 0 <# #S #> S" 10" S= AND
                    849:    LOOP
                    850:    SWAP BASE ! ;
                    851: { GP5 -> <TRUE> }
                    852: 
                    853: : GP6
                    854:    BASE @ >R  2 BASE !
                    855:    MAX-UINT MAX-UINT <# #S #>          \ MAXIMUM UD TO BINARY
                    856:    R> BASE !                           \ S: C-ADDR U
                    857:    DUP #BITS-UD = SWAP
                    858:    0 DO                                        \ S: C-ADDR FLAG
                    859:       OVER C@ [CHAR] 1 = AND           \ ALL ONES
                    860:       >R CHAR+ R>
                    861:    LOOP SWAP DROP ;
                    862: { GP6 -> <TRUE> }
                    863: 
                    864: : GP7
                    865:    BASE @ >R    MAX-BASE BASE !
                    866:    <TRUE>
                    867:    A 0 DO
                    868:       I 0 <# #S #>
                    869:       1 = SWAP C@ I 30 + = AND AND
                    870:    LOOP
                    871:    MAX-BASE A DO
                    872:       I 0 <# #S #>
                    873:       1 = SWAP C@ 41 I A - + = AND AND
                    874:    LOOP
                    875:    R> BASE ! ;
                    876: 
                    877: { GP7 -> <TRUE> }
                    878: 
                    879: \ >NUMBER TESTS
                    880: CREATE GN-BUF 0 C,
                    881: : GN-STRING    GN-BUF 1 ;
                    882: : GN-CONSUMED  GN-BUF CHAR+ 0 ;
                    883: : GN'          [CHAR] ' WORD CHAR+ C@ GN-BUF C!  GN-STRING ;
                    884: 
                    885: { 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }
                    886: { 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }
                    887: { 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }
                    888: { 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }        \ SHOULD FAIL TO CONVERT THESE
                    889: { 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }
                    890: { 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }
                    891: 
                    892: : >NUMBER-BASED
                    893:    BASE @ >R BASE ! >NUMBER R> BASE ! ;
                    894: 
                    895: { 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }
                    896: { 0 0 GN' 2'  2 >NUMBER-BASED -> 0 0 GN-STRING }
                    897: { 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }
                    898: { 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }
                    899: { 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }
                    900: { 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }
                    901: 
                    902: : GN1  \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
                    903:    BASE @ >R BASE !
                    904:    <# #S #>
                    905:    0 0 2SWAP >NUMBER SWAP DROP         \ RETURN LENGTH ONLY
                    906:    R> BASE ! ;
                    907: { 0 0 2 GN1 -> 0 0 0 }
                    908: { MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }
                    909: { MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }
                    910: { 0 0 MAX-BASE GN1 -> 0 0 0 }
                    911: { MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }
                    912: { MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }
                    913: 
                    914: : GN2  \ ( -- 16 10 )
                    915:    BASE @ >R  HEX BASE @  DECIMAL BASE @  R> BASE ! ;
                    916: { GN2 -> 10 A }
                    917: 
                    918: \ ------------------------------------------------------------------------
                    919: TESTING FILL MOVE
                    920: 
                    921: CREATE FBUF 00 C, 00 C, 00 C,
                    922: CREATE SBUF 12 C, 34 C, 56 C,
                    923: : SEEBUF FBUF C@  FBUF CHAR+ C@  FBUF CHAR+ CHAR+ C@ ;
                    924: 
                    925: { FBUF 0 20 FILL -> }
                    926: { SEEBUF -> 00 00 00 }
                    927: 
                    928: { FBUF 1 20 FILL -> }
                    929: { SEEBUF -> 20 00 00 }
                    930: 
                    931: { FBUF 3 20 FILL -> }
                    932: { SEEBUF -> 20 20 20 }
                    933: 
                    934: { FBUF FBUF 3 CHARS MOVE -> }          \ BIZARRE SPECIAL CASE
                    935: { SEEBUF -> 20 20 20 }
                    936: 
                    937: { SBUF FBUF 0 CHARS MOVE -> }
                    938: { SEEBUF -> 20 20 20 }
                    939: 
                    940: { SBUF FBUF 1 CHARS MOVE -> }
                    941: { SEEBUF -> 12 20 20 }
                    942: 
                    943: { SBUF FBUF 3 CHARS MOVE -> }
                    944: { SEEBUF -> 12 34 56 }
                    945: 
                    946: { FBUF FBUF CHAR+ 2 CHARS MOVE -> }
                    947: { SEEBUF -> 12 12 34 }
                    948: 
                    949: { FBUF CHAR+ FBUF 2 CHARS MOVE -> }
                    950: { SEEBUF -> 12 34 34 }
                    951: 
                    952: \ ------------------------------------------------------------------------
                    953: TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
                    954: 
                    955: : OUTPUT-TEST
                    956:    ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
                    957:    41 BL DO I EMIT LOOP CR
                    958:    61 41 DO I EMIT LOOP CR
                    959:    7F 61 DO I EMIT LOOP CR
                    960:    ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
                    961:    9 1+ 0 DO I . LOOP CR
                    962:    ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
                    963:    [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
                    964:    ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
                    965:    [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
                    966:    ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
                    967:    5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
                    968:    ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
                    969:    S" LINE 1" TYPE CR S" LINE 2" TYPE CR
1.2     ! anton     970: \   ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
        !           971: \   ."   SIGNED: " MIN-INT . MAX-INT . CR
        !           972: \   ." UNSIGNED: " 0 U. MAX-UINT U. CR
1.1       anton     973: ;
                    974: 
                    975: { OUTPUT-TEST -> }
1.2     ! anton     976: 
        !           977: \ the lower case stuff is not restricted to core words - anton
        !           978: { min-int s>d tuck dabs <# #s rot sign #>
        !           979:   S" -8000000000000000" drop 2 cells 1+ compare -> 0 }
        !           980: { max-int s>d tuck dabs <# #s rot sign #>
        !           981:   S" 7FFFFFFFFFFFFFFF" drop 2 cells compare -> 0 }
        !           982: { max-uint 0 <# #s #>
        !           983:   S" FFFFFFFFFFFFFFFF" drop 2 cells compare -> 0 }
1.1       anton     984: 
                    985: \ ------------------------------------------------------------------------
                    986: \ commented out to allow batch testing -anton
                    987: \ TESTING INPUT: ACCEPT
                    988: 
                    989: CREATE ABUF 80 CHARS ALLOT
                    990: 
                    991: : ACCEPT-TEST
                    992:    CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
                    993:    ABUF 80 ACCEPT
                    994:    CR ." RECEIVED: " [CHAR] " EMIT
                    995:    ABUF SWAP TYPE [CHAR] " EMIT CR
                    996: ;
                    997: 
                    998: \ { ACCEPT-TEST -> }
                    999: 
                   1000: \ ------------------------------------------------------------------------
                   1001: TESTING DICTIONARY SEARCH RULES
                   1002: 
                   1003: { : GDX   123 ; : GDX   GDX 234 ; -> }
                   1004: 
                   1005: { GDX -> 123 234 }
                   1006: 
                   1007: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>