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 9HEX 10 11\ switch output of hex values to capital letters 12true 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 18VARIABLE 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 34VARIABLE ACTUAL-DEPTH \ STACK RECORD 35CREATE 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 80TESTING CORE WORDS 81HEX 82 83\ ------------------------------------------------------------------------ 84TESTING 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\ ------------------------------------------------------------------------ 94TESTING 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 1040 CONSTANT 0S 1050 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\ ------------------------------------------------------------------------ 126TESTING 2* 2/ LSHIFT RSHIFT 127 128( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) 1291S 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\ ------------------------------------------------------------------------ 161TESTING COMPARISONS: 0= = 0< < > U< MIN MAX 1620 INVERT CONSTANT MAX-UINT 1630 INVERT 1 RSHIFT CONSTANT MAX-INT 1640 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT 1650 INVERT 1 RSHIFT CONSTANT MID-UINT 1660 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 167 1680S CONSTANT <FALSE> 1691S 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\ ------------------------------------------------------------------------ 275TESTING 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\ ------------------------------------------------------------------------ 295TESTING >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\ ------------------------------------------------------------------------ 304TESTING 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\ ------------------------------------------------------------------------ 350TESTING 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\ ------------------------------------------------------------------------ 407TESTING 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. 490IFFLOORED : T/MOD >R S>D R> FM/MOD ; 491IFFLOORED : T/ T/MOD SWAP DROP ; 492IFFLOORED : TMOD T/MOD DROP ; 493IFFLOORED : T*/MOD >R M* R> FM/MOD ; 494IFFLOORED : T*/ T*/MOD SWAP DROP ; 495IFSYM : T/MOD >R S>D R> SM/REM ; 496IFSYM : T/ T/MOD SWAP DROP ; 497IFSYM : TMOD T/MOD DROP ; 498IFSYM : T*/MOD >R M* R> SM/REM ; 499IFSYM : 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\ ------------------------------------------------------------------------ 608TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT 609 610HERE 1 ALLOT 611HERE 612CONSTANT 2NDA 613CONSTANT 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 618HERE 1 , 619HERE 2 , 620CONSTANT 2ND 621CONSTANT 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 635HERE 1 C, 636HERE 2 C, 637CONSTANT 2NDC 638CONSTANT 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 648ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT 649CONSTANT 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\ ------------------------------------------------------------------------ 677TESTING 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\ ------------------------------------------------------------------------ 693TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE 694 695{ : GT1 123 ; -> } 696{ ' GT1 EXECUTE -> 123 } 697{ : GT2 ['] GT1 ; IMMEDIATE -> } 698{ GT2 EXECUTE -> 123 } 699HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING 700HERE 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\ ------------------------------------------------------------------------ 721TESTING 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\ ------------------------------------------------------------------------ 758TESTING 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\ ------------------------------------------------------------------------ 794TESTING 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\ ------------------------------------------------------------------------ 830TESTING 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\ ------------------------------------------------------------------------ 848TESTING SOURCE >IN WORD 849 850: GS1 S" SOURCE" 2DUP EVALUATE 851 >R SWAP >R = R> R> = ; 852{ GS1 -> <TRUE> <TRUE> } 853 854VARIABLE SCANS 855: RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ; 856 857{ 2 SCANS ! 858345 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 868DROP -> 0 } \ BLANK LINE RETURN ZERO-LENGTH STRING 869 870: GS4 SOURCE >IN ! DROP ; 871{ GS4 123 456 872-> } 873 874\ ------------------------------------------------------------------------ 875TESTING <# # #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 90224 CONSTANT MAX-BASE \ BASE 2 .. 36 903: COUNT-BITS 904 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; 905COUNT-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 943CREATE 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\ ------------------------------------------------------------------------ 982TESTING FILL MOVE 983 984CREATE FBUF 00 C, 00 C, 00 C, 985CREATE 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\ ------------------------------------------------------------------------ 1016TESTING 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\ ------------------------------------------------------------------------ 1041TESTING INPUT: ACCEPT 1042 1043CREATE 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\ ------------------------------------------------------------------------ 1055TESTING DICTIONARY SEARCH RULES 1056 1057{ : GDX 123 ; : GDX GDX 234 ; -> } 1058 1059{ GDX -> 123 234 } 1060 1061 1062\ test suite finished. leaving engine. 1063 1064bye 1065