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