MSP430-FORTH/CORETESTx10.4th

   1 ; ------------------------
   2 ; file name : coretest.4th
   3 ; ------------------------
   4
   5 RST_STATE   ; so ANS_COMPLEMENT_xx_MPY is conserved
   6 \ NOECHO      ; if an error occurs, comment this line before new download to find it.
   7
   8
   9 \ From: John Hayes S1I
  10 \ Subject: tester.fr
  11 \ Date: Mon, 27 Nov 95 13:10:09 PST
  12
  13 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
  14 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
  15 \ VERSION 1.1
  16
  17 \ 22/1/09 The words { and } have been changed to T{ and }T respectively to
  18 \ agree with the Forth 200X file ttester.fs. This avoids clashes with
  19 \ locals using { ... } and the FSL use of }
  20
  21
  22 \ 13/05/14 jmt. added colorised error messages.
  23
  24
  25
  26  0 CONSTANT FALSE
  27 -1 CONSTANT TRUE
  28
  29 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
  30 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
  31 VARIABLE VERBOSE
  32     FALSE VERBOSE !
  33 \   TRUE VERBOSE !
  34
  35 \ : EMPTY-STACK ( ... -- )  \ EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
  36 \     DEPTH ?DUP
  37 \             IF DUP 0< IF NEGATE 0
  38 \             DO 0 LOOP
  39 \             ELSE 0 DO DROP LOOP THEN
  40 \             THEN ;
  41 \
  42 \ : ERROR     \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
  43 \         \ THE LINE THAT HAD THE ERROR.
  44 \     TYPE SOURCE TYPE CR          \ DISPLAY LINE CORRESPONDING TO ERROR
  45 \     EMPTY-STACK              \ THROW AWAY EVERY THING ELSE
  46 \     QUIT  \ *** Uncomment this line to QUIT on an error
  47 \ ;
  48
  49 VARIABLE ACTUAL-DEPTH           \ STACK RECORD
  50 CREATE ACTUAL-RESULTS 20 CELLS ALLOT
  51
  52 : T{        \ ( -- ) SYNTACTIC SUGAR.
  53     ;
  54
  55 : ->        \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
  56     DEPTH DUP ACTUAL-DEPTH !     \ RECORD DEPTH
  57     ?DUP IF              \ IF THERE IS SOMETHING ON STACK
  58         0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
  59     THEN ;
  60
  61 : }T        \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
  62             \ (ACTUAL) CONTENTS.
  63     DEPTH ACTUAL-DEPTH @ = IF   \ IF DEPTHS MATCH
  64         DEPTH ?DUP IF           \ IF THERE IS SOMETHING ON THE STACK
  65         0 DO                    \ FOR EACH STACK ITEM
  66             ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
  67 \           = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN   \ jmt
  68             = 0= IF ABORT" INCORRECT RESULT: " THEN           \ jmt : colorised message
  69         LOOP
  70         THEN
  71     ELSE                 \ DEPTH MISMATCH
  72 \       S" WRONG NUMBER OF RESULTS: " ERROR \ jmt
  73         ABORT" WRONG NUMBER OF RESULTS: "   \ jmt : colorised message
  74     THEN ;
  75
  76 : TESTING   \ ( -- ) TALKING COMMENT.
  77     SOURCE VERBOSE @
  78     IF DUP >R TYPE CR R> >IN !
  79     ELSE >IN ! DROP [CHAR] * EMIT
  80     THEN ;
  81
  82 \ From: John Hayes S1I
  83 \ Subject: core.fr
  84 \ Date: Mon, 27 Nov 95 13:10
  85
  86 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
  87 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
  88 \ VERSION 1.2
  89 \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
  90 \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
  91 \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
  92 \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
  93 \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
  94 \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
  95
  96 CR
  97 TESTING CORE WORDS
  98 HEX
  99
 100 \ ------------------------------------------------------------------------
 101 TESTING BASIC ASSUMPTIONS
 102
 103 T{ -> }T                    \ START WITH CLEAN SLATE
 104 ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
 105 T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T
 106 T{  0 BITSSET? -> 0 }T      ( ZERO IS ALL BITS CLEAR )
 107 T{  1 BITSSET? -> 0 0 }T        ( OTHER NUMBER HAVE AT LEAST ONE BIT )
 108 T{ -1 BITSSET? -> 0 0 }T
 109
 110 \ ------------------------------------------------------------------------
 111 TESTING BOOLEANS: INVERT AND OR XOR
 112
 113 T{ 0 0 AND -> 0 }T
 114 T{ 0 1 AND -> 0 }T
 115 T{ 1 0 AND -> 0 }T
 116 T{ 1 1 AND -> 1 }T
 117
 118 T{ 0 INVERT 1 AND -> 1 }T
 119 T{ 1 INVERT 1 AND -> 0 }T
 120
 121 0    CONSTANT 0S
 122 0 INVERT CONSTANT 1S
 123
 124 T{ 0S INVERT -> 1S }T
 125 T{ 1S INVERT -> 0S }T
 126
 127 T{ 0S 0S AND -> 0S }T
 128 T{ 0S 1S AND -> 0S }T
 129 T{ 1S 0S AND -> 0S }T
 130 T{ 1S 1S AND -> 1S }T
 131
 132 T{ 0S 0S OR -> 0S }T
 133 T{ 0S 1S OR -> 1S }T
 134 T{ 1S 0S OR -> 1S }T
 135 T{ 1S 1S OR -> 1S }T
 136
 137 T{ 0S 0S XOR -> 0S }T
 138 T{ 0S 1S XOR -> 1S }T
 139 T{ 1S 0S XOR -> 1S }T
 140 T{ 1S 1S XOR -> 0S }T
 141
 142 \ ------------------------------------------------------------------------
 143 TESTING 2* 2/ LSHIFT RSHIFT
 144
 145 ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
 146 1S 1 RSHIFT INVERT CONSTANT MSB
 147 T{ MSB BITSSET? -> 0 0 }T
 148
 149 T{ 0S 2* -> 0S }T
 150 T{ 1 2* -> 2 }T
 151 T{ 4000 2* -> 8000 }T
 152 T{ 1S 2* 1 XOR -> 1S }T
 153 T{ MSB 2* -> 0S }T
 154
 155 T{ 0S 2/ -> 0S }T
 156 T{ 1 2/ -> 0 }T
 157 T{ 4000 2/ -> 2000 }T
 158 T{ 1S 2/ -> 1S }T               \ MSB PROPOGATED
 159 T{ 1S 1 XOR 2/ -> 1S }T
 160 T{ MSB 2/ MSB AND -> MSB }T
 161
 162 T{ 1 0 LSHIFT -> 1 }T
 163 T{ 1 1 LSHIFT -> 2 }T
 164 T{ 1 2 LSHIFT -> 4 }T
 165 T{ 1 F LSHIFT -> 8000 }T            \ BIGGEST GUARANTEED SHIFT
 166 T{ 1S 1 LSHIFT 1 XOR -> 1S }T
 167 T{ MSB 1 LSHIFT -> 0 }T
 168
 169 T{ 1 0 RSHIFT -> 1 }T
 170 T{ 1 1 RSHIFT -> 0 }T
 171 T{ 2 1 RSHIFT -> 1 }T
 172 T{ 4 2 RSHIFT -> 1 }T
 173 T{ 8000 F RSHIFT -> 1 }T            \ BIGGEST
 174 T{ MSB 1 RSHIFT MSB AND -> 0 }T     \ RSHIFT ZERO FILLS MSBS
 175 T{ MSB 1 RSHIFT 2* -> MSB }T
 176
 177 \ ------------------------------------------------------------------------
 178 TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
 179 0 INVERT            CONSTANT MAX-UINT
 180 0 INVERT 1 RSHIFT       CONSTANT MAX-INT
 181 0 INVERT 1 RSHIFT INVERT    CONSTANT MIN-INT
 182 0 INVERT 1 RSHIFT       CONSTANT MID-UINT
 183 0 INVERT 1 RSHIFT INVERT    CONSTANT MID-UINT+1
 184
 185 0S CONSTANT <FALSE>
 186 1S CONSTANT <TRUE>
 187
 188 T{ 0 0= -> <TRUE> }T
 189 T{ 1 0= -> <FALSE> }T
 190 T{ 2 0= -> <FALSE> }T
 191 T{ -1 0= -> <FALSE> }T
 192 T{ MAX-UINT 0= -> <FALSE> }T
 193 T{ MIN-INT 0= -> <FALSE> }T
 194 T{ MAX-INT 0= -> <FALSE> }T
 195
 196 T{ 0 0 = -> <TRUE> }T
 197 T{ 1 1 = -> <TRUE> }T
 198 T{ -1 -1 = -> <TRUE> }T
 199 T{ 1 0 = -> <FALSE> }T
 200 T{ -1 0 = -> <FALSE> }T
 201 T{ 0 1 = -> <FALSE> }T
 202 T{ 0 -1 = -> <FALSE> }T
 203
 204 T{ 0 0< -> <FALSE> }T
 205 T{ -1 0< -> <TRUE> }T
 206 T{ MIN-INT 0< -> <TRUE> }T
 207 T{ 1 0< -> <FALSE> }T
 208 T{ MAX-INT 0< -> <FALSE> }T
 209
 210 T{ 0 1 < -> <TRUE> }T
 211 T{ 1 2 < -> <TRUE> }T
 212 T{ -1 0 < -> <TRUE> }T
 213 T{ -1 1 < -> <TRUE> }T
 214 T{ MIN-INT 0 < -> <TRUE> }T
 215 T{ MIN-INT MAX-INT < -> <TRUE> }T
 216 T{ 0 MAX-INT < -> <TRUE> }T
 217 T{ 0 0 < -> <FALSE> }T
 218 T{ 1 1 < -> <FALSE> }T
 219 T{ 1 0 < -> <FALSE> }T
 220 T{ 2 1 < -> <FALSE> }T
 221 T{ 0 -1 < -> <FALSE> }T
 222 T{ 1 -1 < -> <FALSE> }T
 223 T{ 0 MIN-INT < -> <FALSE> }T
 224 T{ MAX-INT MIN-INT < -> <FALSE> }T
 225 T{ MAX-INT 0 < -> <FALSE> }T
 226
 227 T{ 0 1 > -> <FALSE> }T
 228 T{ 1 2 > -> <FALSE> }T
 229 T{ -1 0 > -> <FALSE> }T
 230 T{ -1 1 > -> <FALSE> }T
 231 T{ MIN-INT 0 > -> <FALSE> }T
 232 T{ MIN-INT MAX-INT > -> <FALSE> }T
 233 T{ 0 MAX-INT > -> <FALSE> }T
 234 T{ 0 0 > -> <FALSE> }T
 235 T{ 1 1 > -> <FALSE> }T
 236 T{ 1 0 > -> <TRUE> }T
 237 T{ 2 1 > -> <TRUE> }T
 238 T{ 0 -1 > -> <TRUE> }T
 239 T{ 1 -1 > -> <TRUE> }T
 240 T{ 0 MIN-INT > -> <TRUE> }T
 241 T{ MAX-INT MIN-INT > -> <TRUE> }T
 242 T{ MAX-INT 0 > -> <TRUE> }T
 243
 244 T{ 0 1 U< -> <TRUE> }T
 245 T{ 1 2 U< -> <TRUE> }T
 246 T{ 0 MID-UINT U< -> <TRUE> }T
 247 T{ 0 MAX-UINT U< -> <TRUE> }T
 248 T{ MID-UINT MAX-UINT U< -> <TRUE> }T
 249 T{ 0 0 U< -> <FALSE> }T
 250 T{ 1 1 U< -> <FALSE> }T
 251 T{ 1 0 U< -> <FALSE> }T
 252 T{ 2 1 U< -> <FALSE> }T
 253 T{ MID-UINT 0 U< -> <FALSE> }T
 254 T{ MAX-UINT 0 U< -> <FALSE> }T
 255 T{ MAX-UINT MID-UINT U< -> <FALSE> }T
 256
 257 T{ 0 1 MIN -> 0 }T
 258 T{ 1 2 MIN -> 1 }T
 259 T{ -1 0 MIN -> -1 }T
 260 T{ -1 1 MIN -> -1 }T
 261 T{ MIN-INT 0 MIN -> MIN-INT }T
 262 T{ MIN-INT MAX-INT MIN -> MIN-INT }T
 263 T{ 0 MAX-INT MIN -> 0 }T
 264 T{ 0 0 MIN -> 0 }T
 265 T{ 1 1 MIN -> 1 }T
 266 T{ 1 0 MIN -> 0 }T
 267 T{ 2 1 MIN -> 1 }T
 268 T{ 0 -1 MIN -> -1 }T
 269 T{ 1 -1 MIN -> -1 }T
 270 T{ 0 MIN-INT MIN -> MIN-INT }T
 271 T{ MAX-INT MIN-INT MIN -> MIN-INT }T
 272 T{ MAX-INT 0 MIN -> 0 }T
 273
 274 T{ 0 1 MAX -> 1 }T
 275 T{ 1 2 MAX -> 2 }T
 276 T{ -1 0 MAX -> 0 }T
 277 T{ -1 1 MAX -> 1 }T
 278 T{ MIN-INT 0 MAX -> 0 }T
 279 T{ MIN-INT MAX-INT MAX -> MAX-INT }T
 280 T{ 0 MAX-INT MAX -> MAX-INT }T
 281 T{ 0 0 MAX -> 0 }T
 282 T{ 1 1 MAX -> 1 }T
 283 T{ 1 0 MAX -> 1 }T
 284 T{ 2 1 MAX -> 2 }T
 285 T{ 0 -1 MAX -> 0 }T
 286 T{ 1 -1 MAX -> 1 }T
 287 T{ 0 MIN-INT MAX -> 0 }T
 288 T{ MAX-INT MIN-INT MAX -> MAX-INT }T
 289 T{ MAX-INT 0 MAX -> MAX-INT }T
 290
 291 \ ------------------------------------------------------------------------
 292 TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
 293
 294 T{ 1 2 2DROP -> }T
 295 T{ 1 2 2DUP -> 1 2 1 2 }T
 296 T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T
 297 T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T
 298 T{ 0 ?DUP -> 0 }T
 299 T{ 1 ?DUP -> 1 1 }T
 300 T{ -1 ?DUP -> -1 -1 }T
 301 T{ DEPTH -> 0 }T
 302 T{ 0 DEPTH -> 0 1 }T
 303 T{ 0 1 DEPTH -> 0 1 2 }T
 304 T{ 0 DROP -> }T
 305 T{ 1 2 DROP -> 1 }T
 306 T{ 1 DUP -> 1 1 }T
 307 T{ 1 2 OVER -> 1 2 1 }T
 308 T{ 1 2 3 ROT -> 2 3 1 }T
 309 T{ 1 2 SWAP -> 2 1 }T
 310
 311 \ ------------------------------------------------------------------------
 312 TESTING >R R> R@
 313
 314 T{ : GR1 >R R> ; -> }T
 315 T{ : GR2 >R R@ R> DROP ; -> }T
 316 T{ 123 GR1 -> 123 }T
 317 T{ 123 GR2 -> 123 }T
 318 T{ 1S GR1 -> 1S }T   ( RETURN STACK HOLDS CELLS )
 319
 320 \ ------------------------------------------------------------------------
 321 TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
 322
 323 T{ 0 5 + -> 5 }T
 324 T{ 5 0 + -> 5 }T
 325 T{ 0 -5 + -> -5 }T
 326 T{ -5 0 + -> -5 }T
 327 T{ 1 2 + -> 3 }T
 328 T{ 1 -2 + -> -1 }T
 329 T{ -1 2 + -> 1 }T
 330 T{ -1 -2 + -> -3 }T
 331 T{ -1 1 + -> 0 }T
 332 T{ MID-UINT 1 + -> MID-UINT+1 }T
 333
 334 T{ 0 5 - -> -5 }T
 335 T{ 5 0 - -> 5 }T
 336 T{ 0 -5 - -> 5 }T
 337 T{ -5 0 - -> -5 }T
 338 T{ 1 2 - -> -1 }T
 339 T{ 1 -2 - -> 3 }T
 340 T{ -1 2 - -> -3 }T
 341 T{ -1 -2 - -> 1 }T
 342 T{ 0 1 - -> -1 }T
 343 T{ MID-UINT+1 1 - -> MID-UINT }T
 344
 345 T{ 0 1+ -> 1 }T
 346 T{ -1 1+ -> 0 }T
 347 T{ 1 1+ -> 2 }T
 348 T{ MID-UINT 1+ -> MID-UINT+1 }T
 349
 350 T{ 2 1- -> 1 }T
 351 T{ 1 1- -> 0 }T
 352 T{ 0 1- -> -1 }T
 353 T{ MID-UINT+1 1- -> MID-UINT }T
 354
 355 T{ 0 NEGATE -> 0 }T
 356 T{ 1 NEGATE -> -1 }T
 357 T{ -1 NEGATE -> 1 }T
 358 T{ 2 NEGATE -> -2 }T
 359 T{ -2 NEGATE -> 2 }T
 360
 361 T{ 0 ABS -> 0 }T
 362 T{ 1 ABS -> 1 }T
 363 T{ -1 ABS -> 1 }T
 364 T{ MIN-INT ABS -> MID-UINT+1 }T
 365
 366 \ ------------------------------------------------------------------------
 367 TESTING MULTIPLY: S>D * M* UM*
 368
 369 T{ 0 S>D -> 0 0 }T
 370 T{ 1 S>D -> 1 0 }T
 371 T{ 2 S>D -> 2 0 }T
 372 T{ -1 S>D -> -1 -1 }T
 373 T{ -2 S>D -> -2 -1 }T
 374 T{ MIN-INT S>D -> MIN-INT -1 }T
 375 T{ MAX-INT S>D -> MAX-INT 0 }T
 376
 377 T{ 0 0 M* -> 0 S>D }T
 378 T{ 0 1 M* -> 0 S>D }T
 379 T{ 1 0 M* -> 0 S>D }T
 380 T{ 1 2 M* -> 2 S>D }T
 381 T{ 2 1 M* -> 2 S>D }T
 382 T{ 3 3 M* -> 9 S>D }T
 383 T{ -3 3 M* -> -9 S>D }T
 384 T{ 3 -3 M* -> -9 S>D }T
 385 T{ -3 -3 M* -> 9 S>D }T
 386 T{ 0 MIN-INT M* -> 0 S>D }T
 387 T{ 1 MIN-INT M* -> MIN-INT S>D }T
 388 T{ 2 MIN-INT M* -> 0 1S }T
 389 T{ 0 MAX-INT M* -> 0 S>D }T
 390 T{ 1 MAX-INT M* -> MAX-INT S>D }T
 391 T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T
 392 T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T
 393 T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T
 394 T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T
 395
 396 T{ 0 0 * -> 0 }T                \ TEST IDENTITIES
 397 T{ 0 1 * -> 0 }T
 398 T{ 1 0 * -> 0 }T
 399 T{ 1 2 * -> 2 }T
 400 T{ 2 1 * -> 2 }T
 401 T{ 3 3 * -> 9 }T
 402 T{ -3 3 * -> -9 }T
 403 T{ 3 -3 * -> -9 }T
 404 T{ -3 -3 * -> 9 }T
 405
 406 T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T
 407 T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T
 408 T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T
 409
 410 T{ 0 0 UM* -> 0 0 }T
 411 T{ 0 1 UM* -> 0 0 }T
 412 T{ 1 0 UM* -> 0 0 }T
 413 T{ 1 2 UM* -> 2 0 }T
 414 T{ 2 1 UM* -> 2 0 }T
 415 T{ 3 3 UM* -> 9 0 }T
 416
 417 T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T
 418 T{ MID-UINT+1 2 UM* -> 0 1 }T
 419 T{ MID-UINT+1 4 UM* -> 0 2 }T
 420 T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T
 421 T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T
 422
 423 \ ------------------------------------------------------------------------
 424 TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
 425
 426 T{ 0 S>D 1 FM/MOD -> 0 0 }T
 427 T{ 1 S>D 1 FM/MOD -> 0 1 }T
 428 T{ 2 S>D 1 FM/MOD -> 0 2 }T
 429 T{ -1 S>D 1 FM/MOD -> 0 -1 }T
 430 T{ -2 S>D 1 FM/MOD -> 0 -2 }T
 431 T{ 0 S>D -1 FM/MOD -> 0 0 }T
 432 T{ 1 S>D -1 FM/MOD -> 0 -1 }T
 433 T{ 2 S>D -1 FM/MOD -> 0 -2 }T
 434 T{ -1 S>D -1 FM/MOD -> 0 1 }T
 435 T{ -2 S>D -1 FM/MOD -> 0 2 }T
 436 T{ 2 S>D 2 FM/MOD -> 0 1 }T
 437 T{ -1 S>D -1 FM/MOD -> 0 1 }T
 438 T{ -2 S>D -2 FM/MOD -> 0 1 }T
 439 T{  7 S>D  3 FM/MOD -> 1 2 }T
 440 T{  7 S>D -3 FM/MOD -> -2 -3 }T
 441 T{ -7 S>D  3 FM/MOD -> 2 -3 }T
 442 T{ -7 S>D -3 FM/MOD -> -1 2 }T
 443 T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T
 444 T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T
 445 T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T
 446 T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T
 447 T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T
 448 T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T
 449 T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T
 450 T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T
 451 T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T
 452 T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T
 453 T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T
 454 T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T
 455 T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T
 456 T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T
 457 T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T
 458 T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T
 459 T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T
 460
 461 T{ 0 S>D 1 SM/REM -> 0 0 }T
 462 T{ 1 S>D 1 SM/REM -> 0 1 }T
 463 T{ 2 S>D 1 SM/REM -> 0 2 }T
 464 T{ -1 S>D 1 SM/REM -> 0 -1 }T
 465 T{ -2 S>D 1 SM/REM -> 0 -2 }T
 466 T{ 0 S>D -1 SM/REM -> 0 0 }T
 467 T{ 1 S>D -1 SM/REM -> 0 -1 }T
 468 T{ 2 S>D -1 SM/REM -> 0 -2 }T
 469 T{ -1 S>D -1 SM/REM -> 0 1 }T
 470 T{ -2 S>D -1 SM/REM -> 0 2 }T
 471 T{ 2 S>D 2 SM/REM -> 0 1 }T
 472 T{ -1 S>D -1 SM/REM -> 0 1 }T
 473 T{ -2 S>D -2 SM/REM -> 0 1 }T
 474 T{  7 S>D  3 SM/REM -> 1 2 }T
 475 T{  7 S>D -3 SM/REM -> 1 -2 }T
 476 T{ -7 S>D  3 SM/REM -> -1 -2 }T
 477 T{ -7 S>D -3 SM/REM -> -1 2 }T
 478 T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T
 479 T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T
 480 T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T
 481 T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T
 482 T{ 1S 1 4 SM/REM -> 3 MAX-INT }T
 483 T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T
 484 T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T
 485 T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T
 486 T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T
 487 T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T
 488 T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T
 489 T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T
 490 T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T
 491
 492 T{ 0 0 1 UM/MOD -> 0 0 }T
 493 T{ 1 0 1 UM/MOD -> 0 1 }T
 494 T{ 1 0 2 UM/MOD -> 1 0 }T
 495 T{ 3 0 2 UM/MOD -> 1 1 }T
 496 T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T
 497 T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T
 498 T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T
 499
 500 : IFFLOORED
 501     [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
 502
 503 : IFSYM
 504     [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
 505
 506 \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
 507 \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
 508
 509 IFFLOORED : T/MOD  >R S>D R> FM/MOD ;
 510 IFFLOORED : T/     T/MOD SWAP DROP ;
 511 IFFLOORED : TMOD   T/MOD DROP ;
 512 IFFLOORED : T*/MOD >R M* R> FM/MOD ;
 513 IFFLOORED : T*/    T*/MOD SWAP DROP ;
 514 IFSYM     : T/MOD  >R S>D R> SM/REM ;
 515 IFSYM     : T/     T/MOD SWAP DROP ;
 516 IFSYM     : TMOD   T/MOD DROP ;
 517 IFSYM     : T*/MOD >R M* R> SM/REM ;
 518 IFSYM     : T*/    T*/MOD SWAP DROP ;
 519
 520 T{ 0 1 /MOD -> 0 1 T/MOD }T
 521 T{ 1 1 /MOD -> 1 1 T/MOD }T
 522 T{ 2 1 /MOD -> 2 1 T/MOD }T
 523 T{ -1 1 /MOD -> -1 1 T/MOD }T
 524 T{ -2 1 /MOD -> -2 1 T/MOD }T
 525 T{ 0 -1 /MOD -> 0 -1 T/MOD }T
 526 T{ 1 -1 /MOD -> 1 -1 T/MOD }T
 527 T{ 2 -1 /MOD -> 2 -1 T/MOD }T
 528 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
 529 T{ -2 -1 /MOD -> -2 -1 T/MOD }T
 530 T{ 2 2 /MOD -> 2 2 T/MOD }T
 531 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
 532 T{ -2 -2 /MOD -> -2 -2 T/MOD }T
 533 T{ 7 3 /MOD -> 7 3 T/MOD }T
 534 T{ 7 -3 /MOD -> 7 -3 T/MOD }T
 535 T{ -7 3 /MOD -> -7 3 T/MOD }T
 536 T{ -7 -3 /MOD -> -7 -3 T/MOD }T
 537 T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T
 538 T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T
 539 T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T
 540 T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T
 541
 542 T{ 0 1 / -> 0 1 T/ }T
 543 T{ 1 1 / -> 1 1 T/ }T
 544 T{ 2 1 / -> 2 1 T/ }T
 545 T{ -1 1 / -> -1 1 T/ }T
 546 T{ -2 1 / -> -2 1 T/ }T
 547 T{ 0 -1 / -> 0 -1 T/ }T
 548 T{ 1 -1 / -> 1 -1 T/ }T
 549 T{ 2 -1 / -> 2 -1 T/ }T
 550 T{ -1 -1 / -> -1 -1 T/ }T
 551 T{ -2 -1 / -> -2 -1 T/ }T
 552 T{ 2 2 / -> 2 2 T/ }T
 553 T{ -1 -1 / -> -1 -1 T/ }T
 554 T{ -2 -2 / -> -2 -2 T/ }T
 555 T{ 7 3 / -> 7 3 T/ }T
 556 T{ 7 -3 / -> 7 -3 T/ }T
 557 T{ -7 3 / -> -7 3 T/ }T
 558 T{ -7 -3 / -> -7 -3 T/ }T
 559 T{ MAX-INT 1 / -> MAX-INT 1 T/ }T
 560 T{ MIN-INT 1 / -> MIN-INT 1 T/ }T
 561 T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T
 562 T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T
 563
 564 T{ 0 1 MOD -> 0 1 TMOD }T
 565 T{ 1 1 MOD -> 1 1 TMOD }T
 566 T{ 2 1 MOD -> 2 1 TMOD }T
 567 T{ -1 1 MOD -> -1 1 TMOD }T
 568 T{ -2 1 MOD -> -2 1 TMOD }T
 569 T{ 0 -1 MOD -> 0 -1 TMOD }T
 570 T{ 1 -1 MOD -> 1 -1 TMOD }T
 571 T{ 2 -1 MOD -> 2 -1 TMOD }T
 572 T{ -1 -1 MOD -> -1 -1 TMOD }T
 573 T{ -2 -1 MOD -> -2 -1 TMOD }T
 574 T{ 2 2 MOD -> 2 2 TMOD }T
 575 T{ -1 -1 MOD -> -1 -1 TMOD }T
 576 T{ -2 -2 MOD -> -2 -2 TMOD }T
 577 T{ 7 3 MOD -> 7 3 TMOD }T
 578 T{ 7 -3 MOD -> 7 -3 TMOD }T
 579 T{ -7 3 MOD -> -7 3 TMOD }T
 580 T{ -7 -3 MOD -> -7 -3 TMOD }T
 581 T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T
 582 T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T
 583 T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T
 584 T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T
 585
 586 T{ 0 2 1 */ -> 0 2 1 T*/ }T
 587 T{ 1 2 1 */ -> 1 2 1 T*/ }T
 588 T{ 2 2 1 */ -> 2 2 1 T*/ }T
 589 T{ -1 2 1 */ -> -1 2 1 T*/ }T
 590 T{ -2 2 1 */ -> -2 2 1 T*/ }T
 591 T{ 0 2 -1 */ -> 0 2 -1 T*/ }T
 592 T{ 1 2 -1 */ -> 1 2 -1 T*/ }T
 593 T{ 2 2 -1 */ -> 2 2 -1 T*/ }T
 594 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
 595 T{ -2 2 -1 */ -> -2 2 -1 T*/ }T
 596 T{ 2 2 2 */ -> 2 2 2 T*/ }T
 597 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
 598 T{ -2 2 -2 */ -> -2 2 -2 T*/ }T
 599 T{ 7 2 3 */ -> 7 2 3 T*/ }T
 600 T{ 7 2 -3 */ -> 7 2 -3 T*/ }T
 601 T{ -7 2 3 */ -> -7 2 3 T*/ }T
 602 T{ -7 2 -3 */ -> -7 2 -3 T*/ }T
 603 T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T
 604 T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T
 605
 606 T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T
 607 T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T
 608 T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T
 609 T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T
 610 T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T
 611 T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T
 612 T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T
 613 T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T
 614 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
 615 T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T
 616 T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T
 617 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
 618 T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T
 619 T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T
 620 T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T
 621 T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T
 622 T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T
 623 T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T
 624 T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T
 625
 626 \ ------------------------------------------------------------------------
 627 TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
 628
 629 HERE 1 ALLOT
 630 HERE
 631 CONSTANT 2NDA
 632 CONSTANT 1STA
 633 T{ 1STA 2NDA U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
 634 T{ 1STA 1+ -> 2NDA }T           \ ... BY ONE ADDRESS UNIT
 635 ( MISSING TEST: NEGATIVE ALLOT )
 636
 637 HERE 1 ,
 638 HERE 2 ,
 639 CONSTANT 2ND
 640 CONSTANT 1ST
 641 T{ 1ST 2ND U< -> <TRUE> }T          \ HERE MUST GROW WITH ALLOT
 642 T{ 1ST CELL+ -> 2ND }T          \ ... BY ONE CELL
 643 T{ 1ST 1 CELLS + -> 2ND }T
 644 T{ 1ST @ 2ND @ -> 1 2 }T
 645 T{ 5 1ST ! -> }T
 646 T{ 1ST @ 2ND @ -> 5 2 }T
 647 T{ 6 2ND ! -> }T
 648 T{ 1ST @ 2ND @ -> 5 6 }T
 649 T{ 1ST 2@ -> 6 5 }T
 650 T{ 2 1 1ST 2! -> }T
 651 T{ 1ST 2@ -> 2 1 }T
 652 T{ 1S 1ST !  1ST @ -> 1S }T     \ CAN STORE CELL-WIDE VALUE
 653
 654 HERE 1 C,
 655 HERE 2 C,
 656 CONSTANT 2NDC
 657 CONSTANT 1STC
 658 T{ 1STC 2NDC U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
 659 T{ 1STC CHAR+ -> 2NDC }T            \ ... BY ONE CHAR
 660 T{ 1STC 1 CHARS + -> 2NDC }T
 661 T{ 1STC C@ 2NDC C@ -> 1 2 }T
 662 T{ 3 1STC C! -> }T
 663 T{ 1STC C@ 2NDC C@ -> 3 2 }T
 664 T{ 4 2NDC C! -> }T
 665 T{ 1STC C@ 2NDC C@ -> 3 4 }T
 666
 667 ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
 668 CONSTANT A-ADDR  CONSTANT UA-ADDR
 669 T{ UA-ADDR ALIGNED -> A-ADDR }T
 670 T{    1 A-ADDR C!  A-ADDR C@ ->    1 }T
 671 T{ 1234 A-ADDR  !  A-ADDR  @ -> 1234 }T
 672 T{ 123 456 A-ADDR 2!  A-ADDR 2@ -> 123 456 }T
 673 T{ 2 A-ADDR CHAR+ C!  A-ADDR CHAR+ C@ -> 2 }T
 674 T{ 3 A-ADDR CELL+ C!  A-ADDR CELL+ C@ -> 3 }T
 675 T{ 1234 A-ADDR CELL+ !  A-ADDR CELL+ @ -> 1234 }T
 676 T{ 123 456 A-ADDR CELL+ 2!  A-ADDR CELL+ 2@ -> 123 456 }T
 677
 678 : BITS ( X -- U )
 679     0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
 680 ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
 681 T{ 1 CHARS 1 < -> <FALSE> }T
 682 T{ 1 CHARS 1 CELLS > -> <FALSE> }T
 683 ( TBD: HOW TO FIND NUMBER OF BITS? )
 684
 685 ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
 686 T{ 1 CELLS 1 < -> <FALSE> }T
 687 T{ 1 CELLS 1 CHARS MOD -> 0 }T
 688 T{ 1S BITS 10 < -> <FALSE> }T
 689
 690 T{ 0 1ST ! -> }T
 691 T{ 1 1ST +! -> }T
 692 T{ 1ST @ -> 1 }T
 693 T{ -1 1ST +! 1ST @ -> 0 }T
 694
 695 \ ------------------------------------------------------------------------
 696 TESTING CHAR [CHAR] [ ] BL S"
 697
 698 T{ BL -> 20 }T
 699 T{ CHAR X -> 58 }T
 700 T{ CHAR HELLO -> 48 }T
 701 T{ : GC1 [CHAR] X ; -> }T
 702 T{ : GC2 [CHAR] HELLO ; -> }T
 703 T{ GC1 -> 58 }T
 704 T{ GC2 -> 48 }T
 705 T{ : GC3 [ GC1 ] LITERAL ; -> }T
 706 T{ GC3 -> 58 }T
 707 T{ : GC4 S" XY" ; -> }T
 708 T{ GC4 SWAP DROP -> 2 }T
 709 T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T
 710
 711 \ ------------------------------------------------------------------------
 712 TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
 713
 714 T{ : GT1 123 ; -> }T
 715 T{ ' GT1 EXECUTE -> 123 }T
 716 T{ : GT2 ['] GT1 ; IMMEDIATE -> }T
 717 T{ GT2 EXECUTE -> 123 }T
 718 HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
 719 HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
 720 T{ GT1STRING FIND -> ' GT1 -1 }T
 721 T{ GT2STRING FIND -> ' GT2 1 }T
 722 ( HOW TO SEARCH FOR NON-EXISTENT WORD? )
 723 T{ : GT3 GT2 LITERAL ; -> }T
 724 T{ GT3 -> ' GT1 }T
 725 T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T
 726
 727 T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T
 728 T{ : GT5 GT4 ; -> }T
 729 T{ GT5 -> 123 }T
 730 T{ : GT6 345 ; IMMEDIATE -> }T
 731 T{ : GT7 POSTPONE GT6 ; -> }T
 732 T{ GT7 -> 345 }T
 733
 734 T{ : GT8 STATE @ ; IMMEDIATE -> }T
 735 T{ GT8 -> 0 }T
 736 T{ : GT9 GT8 LITERAL ; -> }T
 737 T{ GT9 0= -> <FALSE> }T
 738
 739 \ ------------------------------------------------------------------------
 740 TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
 741
 742 T{ : GI1 IF 123 THEN ; -> }T
 743 T{ : GI2 IF 123 ELSE 234 THEN ; -> }T
 744 T{ 0 GI1 -> }T
 745 T{ 1 GI1 -> 123 }T
 746 T{ -1 GI1 -> 123 }T
 747 T{ 0 GI2 -> 234 }T
 748 T{ 1 GI2 -> 123 }T
 749 T{ -1 GI1 -> 123 }T
 750
 751 T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T
 752 T{ 0 GI3 -> 0 1 2 3 4 5 }T
 753 T{ 4 GI3 -> 4 5 }T
 754 T{ 5 GI3 -> 5 }T
 755 T{ 6 GI3 -> 6 }T
 756
 757 T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T
 758 T{ 3 GI4 -> 3 4 5 6 }T
 759 T{ 5 GI4 -> 5 6 }T
 760 T{ 6 GI4 -> 6 7 }T
 761
 762 T{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T
 763 T{ 1 GI5 -> 1 345 }T
 764 T{ 2 GI5 -> 2 345 }T
 765 T{ 3 GI5 -> 3 4 5 123 }T
 766 T{ 4 GI5 -> 4 5 123 }T
 767 T{ 5 GI5 -> 5 123 }T
 768
 769 T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T
 770 T{ 0 GI6 -> 0 }T
 771 T{ 1 GI6 -> 0 1 }T
 772 T{ 2 GI6 -> 0 1 2 }T
 773 T{ 3 GI6 -> 0 1 2 3 }T
 774 T{ 4 GI6 -> 0 1 2 3 4 }T
 775
 776 \ ------------------------------------------------------------------------
 777 TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
 778
 779 T{ : GD1 DO I LOOP ; -> }T
 780 T{ 4 1 GD1 -> 1 2 3 }T
 781 T{ 2 -1 GD1 -> -1 0 1 }T
 782 T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T
 783
 784 T{ : GD2 DO I -1 +LOOP ; -> }T
 785 T{ 1 4 GD2 -> 4 3 2 1 }T
 786 T{ -1 2 GD2 -> 2 1 0 -1 }T
 787 T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T
 788
 789 T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T
 790 T{ 4 1 GD3 -> 1 2 3 }T
 791 T{ 2 -1 GD3 -> -1 0 1 }T
 792 T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T
 793
 794 T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T
 795 T{ 1 4 GD4 -> 4 3 2 1 }T
 796 T{ -1 2 GD4 -> 2 1 0 -1 }T
 797 T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T
 798
 799 T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T
 800 T{ 1 GD5 -> 123 }T
 801 T{ 5 GD5 -> 123 }T
 802 T{ 6 GD5 -> 234 }T
 803
 804 T{ : GD6  ( PAT: T{0 0}T,T{0 0}TT{1 0}TT{1 1}T,T{0 0}TT{1 0}TT{1 1}TT{2 0}TT{2 1}TT{2 2}T )
 805     0 SWAP 0 DO
 806         I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
 807     LOOP ; -> }T
 808 T{ 1 GD6 -> 1 }T
 809 T{ 2 GD6 -> 3 }T
 810 T{ 3 GD6 -> 4 1 2 }T
 811
 812 \ ------------------------------------------------------------------------
 813 TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
 814
 815 T{ 123 CONSTANT X123 -> }T
 816 T{ X123 -> 123 }T
 817 T{ : EQU CONSTANT ; -> }T
 818 T{ X123 EQU Y123 -> }T
 819 T{ Y123 -> 123 }T
 820
 821 T{ VARIABLE V1 -> }T
 822 T{ 123 V1 ! -> }T
 823 T{ V1 @ -> 123 }T
 824
 825 T{ : NOP : POSTPONE ; ; -> }T
 826 T{ NOP NOP1 NOP NOP2 -> }T
 827 T{ NOP1 -> }T
 828 T{ NOP2 -> }T
 829
 830 T{ : DOES1 DOES> @ 1 + ; -> }T
 831 T{ : DOES2 DOES> @ 2 + ; -> }T
 832 T{ CREATE CR1 -> }T
 833 T{ CR1 -> HERE }T
 834 T{ ' CR1 >BODY -> HERE }T
 835 T{ 1 , -> }T
 836 T{ CR1 @ -> 1 }T
 837 T{ DOES1 -> }T
 838 T{ CR1 -> 2 }T
 839 T{ DOES2 -> }T
 840 T{ CR1 -> 3 }T
 841
 842 T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T
 843 T{ WEIRD: W1 -> }T
 844 T{ ' W1 >BODY -> HERE }T
 845 T{ W1 -> HERE 1 + }T
 846 T{ W1 -> HERE 2 + }T
 847
 848 \ ------------------------------------------------------------------------
 849 TESTING EVALUATE
 850
 851 : GE1 S" 123" ; IMMEDIATE
 852 : GE2 S" 123 1+" ; IMMEDIATE
 853 : GE3 S" : GE4 345 ;" ;
 854 : GE5 EVALUATE ; IMMEDIATE
 855
 856 T{ GE1 EVALUATE -> 123 }T           ( TEST EVALUATE IN INTERP. STATE )
 857 T{ GE2 EVALUATE -> 124 }T
 858 T{ GE3 EVALUATE -> }T
 859 T{ GE4 -> 345 }T
 860
 861 T{ : GE6 GE1 GE5 ; -> }T            ( TEST EVALUATE IN COMPILE STATE )
 862 T{ GE6 -> 123 }T
 863 T{ : GE7 GE2 GE5 ; -> }T
 864 T{ GE7 -> 124 }T
 865
 866 \ ------------------------------------------------------------------------
 867 TESTING SOURCE >IN WORD
 868
 869 : GS1 S" SOURCE" 2DUP EVALUATE
 870         >R SWAP >R = R> R> = ;
 871 T{ GS1 -> <TRUE> <TRUE> }T
 872
 873 VARIABLE SCANS
 874 : RESCAN?  -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
 875
 876 T{ 2 SCANS !
 877 345 RESCAN?
 878 -> 345 345 }T
 879
 880 : GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
 881 T{ GS2 -> 123 123 123 123 123 }T
 882
 883 : GS3 WORD COUNT SWAP C@ ;
 884 T{ BL GS3 HELLO -> 5 CHAR H }T
 885 T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T
 886 T{ BL GS3
 887 DROP -> 0 }T                \ BLANK LINE RETURN ZERO-LENGTH STRING
 888
 889 : GS4 SOURCE >IN ! DROP ;
 890 T{ GS4 123 456
 891 -> }T
 892
 893 \ ------------------------------------------------------------------------
 894 TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
 895
 896 : S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
 897     >R SWAP R@ = IF          \ MAKE SURE STRINGS HAVE SAME LENGTH
 898         R> ?DUP IF            \ IF NON-EMPTY STRINGS
 899         0 DO
 900         OVER C@ OVER C@ - IF
 901             2DROP <FALSE> UNLOOP EXIT THEN
 902         SWAP CHAR+ SWAP CHAR+
 903             LOOP
 904         THEN
 905         2DROP <TRUE>          \ IF WE GET HERE, STRINGS MATCH
 906     ELSE
 907         R> DROP 2DROP <FALSE>     \ LENGTHS MISMATCH
 908     THEN ;
 909
 910 : GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
 911 T{ GP1 -> <TRUE> }T
 912
 913 : GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
 914 T{ GP2 -> <TRUE> }T
 915
 916 : GP3  <# 1 0 # # #> S" 01" S= ;
 917 T{ GP3 -> <TRUE> }T
 918
 919 : GP4  <# 1 0 #S #> S" 1" S= ;
 920 T{ GP4 -> <TRUE> }T
 921
 922 24 CONSTANT MAX-BASE            \ BASE 2 .. 36
 923 : COUNT-BITS
 924     0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
 925 COUNT-BITS 2* CONSTANT #BITS-UD     \ NUMBER OF BITS IN UD
 926
 927 : GP5
 928     BASE @ <TRUE>
 929     MAX-BASE 1+ 2 DO         \ FOR EACH POSSIBLE BASE
 930         I BASE !              \ TBD: ASSUMES BASE WORKS
 931         I 0 <# #S #> S" 10" S= AND
 932     LOOP
 933     SWAP BASE ! ;
 934 T{ GP5 -> <TRUE> }T
 935
 936 : GP6
 937     BASE @ >R  2 BASE !
 938     MAX-UINT MAX-UINT <# #S #>       \ MAXIMUM UD TO BINARY
 939     R> BASE !                \ S: C-ADDR U
 940     DUP #BITS-UD = SWAP
 941     0 DO                 \ S: C-ADDR FLAG
 942         OVER C@ [CHAR] 1 = AND        \ ALL ONES
 943         >R CHAR+ R>
 944     LOOP SWAP DROP ;
 945 T{ GP6 -> <TRUE> }T
 946
 947 : GP7
 948     BASE @ >R    MAX-BASE BASE !
 949     <TRUE>
 950     A 0 DO
 951         I 0 <# #S #>
 952         1 = SWAP C@ I 30 + = AND AND
 953     LOOP
 954     MAX-BASE A DO
 955         I 0 <# #S #>
 956         1 = SWAP C@ 41 I A - + = AND AND
 957     LOOP
 958     R> BASE ! ;
 959
 960 T{ GP7 -> <TRUE> }T
 961
 962 \ >NUMBER TESTS
 963 CREATE GN-BUF 0 C,
 964 : GN-STRING GN-BUF 1 ;
 965 : GN-CONSUMED   GN-BUF CHAR+ 0 ;
 966 : GN'       [CHAR] ' WORD CHAR+ C@ GN-BUF C!  GN-STRING ;
 967
 968 T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T
 969 T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T
 970 T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T
 971 T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T   \ SHOULD FAIL TO CONVERT THESE
 972 T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T
 973 T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T
 974
 975 : >NUMBER-BASED
 976     BASE @ >R BASE ! >NUMBER R> BASE ! ;
 977
 978 T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T
 979 T{ 0 0 GN' 2'  2 >NUMBER-BASED -> 0 0 GN-STRING }T
 980 T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T
 981 T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T
 982 T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T
 983 T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T
 984
 985 : GN1   \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
 986     BASE @ >R BASE !
 987     <# #S #>
 988     0 0 2SWAP >NUMBER SWAP DROP      \ RETURN LENGTH ONLY
 989     R> BASE ! ;
 990 T{ 0 0 2 GN1 -> 0 0 0 }T
 991 T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
 992 T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
 993 T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T
 994 T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T
 995 T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T
 996
 997 : GN2   \ ( -- 16 10 )
 998     BASE @ >R  HEX BASE @  DECIMAL BASE @  R> BASE ! ;
 999 T{ GN2 -> 10 A }T
1000
1001 \ ------------------------------------------------------------------------
1002 TESTING FILL MOVE
1003
1004 CREATE FBUF 00 C, 00 C, 00 C,
1005 CREATE SBUF 12 C, 34 C, 56 C,
1006 : SEEBUF FBUF C@  FBUF CHAR+ C@  FBUF CHAR+ CHAR+ C@ ;
1007
1008 T{ FBUF 0 20 FILL -> }T
1009 T{ SEEBUF -> 00 00 00 }T
1010
1011 T{ FBUF 1 20 FILL -> }T
1012 T{ SEEBUF -> 20 00 00 }T
1013
1014 T{ FBUF 3 20 FILL -> }T
1015 T{ SEEBUF -> 20 20 20 }T
1016
1017 T{ FBUF FBUF 3 CHARS MOVE -> }T     \ BIZARRE SPECIAL CASE
1018 T{ SEEBUF -> 20 20 20 }T
1019
1020 T{ SBUF FBUF 0 CHARS MOVE -> }T
1021 T{ SEEBUF -> 20 20 20 }T
1022
1023 T{ SBUF FBUF 1 CHARS MOVE -> }T
1024 T{ SEEBUF -> 12 20 20 }T
1025
1026 T{ SBUF FBUF 3 CHARS MOVE -> }T
1027 T{ SEEBUF -> 12 34 56 }T
1028
1029 T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T
1030 T{ SEEBUF -> 12 12 34 }T
1031
1032 T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T
1033 T{ SEEBUF -> 12 34 34 }T
1034
1035 \ ------------------------------------------------------------------------
1036 TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
1037
1038 : OUTPUT-TEST
1039     ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
1040     41 BL DO I EMIT LOOP CR
1041     61 41 DO I EMIT LOOP CR
1042     7F 61 DO I EMIT LOOP CR
1043     ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
1044     9 1+ 0 DO I . LOOP CR
1045     ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
1046     [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
1047     ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
1048     [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
1049     ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
1050     5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
1051     ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
1052     S" LINE 1" TYPE CR S" LINE 2" TYPE CR
1053     ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
1054     ."   SIGNED: " MIN-INT . MAX-INT . CR
1055     ." UNSIGNED: " 0 U. MAX-UINT U. CR
1056 ;
1057
1058 T{ OUTPUT-TEST -> }T
1059 \ ------------------------------------------------------------------------
1060 TESTING INPUT: ACCEPT
1061
1062 CREATE ABUF 80 CHARS ALLOT
1063
1064 : ACCEPT-TEST
1065     CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
1066     ABUF 80 ACCEPT
1067     CR ." RECEIVED: " [CHAR] " EMIT
1068     ABUF SWAP TYPE [CHAR] " EMIT CR
1069 ;
1070
1071 T{ ACCEPT-TEST -> }T
1072 Vingt fois sur le métier remettez votre ouvrage, ...
1073 \ ------------------------------------------------------------------------
1074 TESTING DICTIONARY SEARCH RULES
1075
1076 T{ : GDX   123 ; : GDX   GDX 234 ; -> }T
1077
1078 T{ GDX -> 123 234 }T
1079
1080 CR .( End of Core word set tests) CR
1081
1082
1083
1084 RST_STATE   ; so ANS_COMPLEMENT_xx_MPY is conserved ;
1085 \ NOECHO      ; if an error occurs, comment this line before new download to find it.
1086
1087
1088 \ From: John Hayes S1I
1089 \ Subject: tester.fr
1090 \ Date: Mon, 27 Nov 95 13:10:09 PST
1091
1092 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
1093 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
1094 \ VERSION 1.1
1095
1096 \ 22/1/09 The words { and } have been changed to T{ and }T respectively to
1097 \ agree with the Forth 200X file ttester.fs. This avoids clashes with
1098 \ locals using { ... } and the FSL use of }
1099
1100
1101 \ 13/05/14 jmt. added colorised error messages.
1102
1103
1104
1105  0 CONSTANT FALSE
1106 -1 CONSTANT TRUE
1107
1108 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
1109 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
1110 VARIABLE VERBOSE
1111     FALSE VERBOSE !
1112 \   TRUE VERBOSE !
1113
1114 \ : EMPTY-STACK ( ... -- )  \ EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
1115 \     DEPTH ?DUP
1116 \             IF DUP 0< IF NEGATE 0
1117 \             DO 0 LOOP
1118 \             ELSE 0 DO DROP LOOP THEN
1119 \             THEN ;
1120 \
1121 \ : ERROR     \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
1122 \         \ THE LINE THAT HAD THE ERROR.
1123 \     TYPE SOURCE TYPE CR          \ DISPLAY LINE CORRESPONDING TO ERROR
1124 \     EMPTY-STACK              \ THROW AWAY EVERY THING ELSE
1125 \     QUIT  \ *** Uncomment this line to QUIT on an error
1126 \ ;
1127
1128 VARIABLE ACTUAL-DEPTH           \ STACK RECORD
1129 CREATE ACTUAL-RESULTS 20 CELLS ALLOT
1130
1131 : T{        \ ( -- ) SYNTACTIC SUGAR.
1132     ;
1133
1134 : ->        \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
1135     DEPTH DUP ACTUAL-DEPTH !     \ RECORD DEPTH
1136     ?DUP IF              \ IF THERE IS SOMETHING ON STACK
1137         0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
1138     THEN ;
1139
1140 : }T        \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
1141             \ (ACTUAL) CONTENTS.
1142     DEPTH ACTUAL-DEPTH @ = IF   \ IF DEPTHS MATCH
1143         DEPTH ?DUP IF           \ IF THERE IS SOMETHING ON THE STACK
1144         0 DO                    \ FOR EACH STACK ITEM
1145             ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
1146 \           = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN   \ jmt
1147             = 0= IF ABORT" INCORRECT RESULT: " THEN           \ jmt : colorised message
1148         LOOP
1149         THEN
1150     ELSE                 \ DEPTH MISMATCH
1151 \       S" WRONG NUMBER OF RESULTS: " ERROR \ jmt
1152         ABORT" WRONG NUMBER OF RESULTS: "   \ jmt : colorised message
1153     THEN ;
1154
1155 : TESTING   \ ( -- ) TALKING COMMENT.
1156     SOURCE VERBOSE @
1157     IF DUP >R TYPE CR R> >IN !
1158     ELSE >IN ! DROP [CHAR] * EMIT
1159     THEN ;
1160
1161 \ From: John Hayes S1I
1162 \ Subject: core.fr
1163 \ Date: Mon, 27 Nov 95 13:10
1164
1165 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
1166 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
1167 \ VERSION 1.2
1168 \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
1169 \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
1170 \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
1171 \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
1172 \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
1173 \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
1174
1175 CR
1176 TESTING CORE WORDS
1177 HEX
1178
1179 \ ------------------------------------------------------------------------
1180 TESTING BASIC ASSUMPTIONS
1181
1182 T{ -> }T                    \ START WITH CLEAN SLATE
1183 ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
1184 T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T
1185 T{  0 BITSSET? -> 0 }T      ( ZERO IS ALL BITS CLEAR )
1186 T{  1 BITSSET? -> 0 0 }T        ( OTHER NUMBER HAVE AT LEAST ONE BIT )
1187 T{ -1 BITSSET? -> 0 0 }T
1188
1189 \ ------------------------------------------------------------------------
1190 TESTING BOOLEANS: INVERT AND OR XOR
1191
1192 T{ 0 0 AND -> 0 }T
1193 T{ 0 1 AND -> 0 }T
1194 T{ 1 0 AND -> 0 }T
1195 T{ 1 1 AND -> 1 }T
1196
1197 T{ 0 INVERT 1 AND -> 1 }T
1198 T{ 1 INVERT 1 AND -> 0 }T
1199
1200 0    CONSTANT 0S
1201 0 INVERT CONSTANT 1S
1202
1203 T{ 0S INVERT -> 1S }T
1204 T{ 1S INVERT -> 0S }T
1205
1206 T{ 0S 0S AND -> 0S }T
1207 T{ 0S 1S AND -> 0S }T
1208 T{ 1S 0S AND -> 0S }T
1209 T{ 1S 1S AND -> 1S }T
1210
1211 T{ 0S 0S OR -> 0S }T
1212 T{ 0S 1S OR -> 1S }T
1213 T{ 1S 0S OR -> 1S }T
1214 T{ 1S 1S OR -> 1S }T
1215
1216 T{ 0S 0S XOR -> 0S }T
1217 T{ 0S 1S XOR -> 1S }T
1218 T{ 1S 0S XOR -> 1S }T
1219 T{ 1S 1S XOR -> 0S }T
1220
1221 \ ------------------------------------------------------------------------
1222 TESTING 2* 2/ LSHIFT RSHIFT
1223
1224 ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
1225 1S 1 RSHIFT INVERT CONSTANT MSB
1226 T{ MSB BITSSET? -> 0 0 }T
1227
1228 T{ 0S 2* -> 0S }T
1229 T{ 1 2* -> 2 }T
1230 T{ 4000 2* -> 8000 }T
1231 T{ 1S 2* 1 XOR -> 1S }T
1232 T{ MSB 2* -> 0S }T
1233
1234 T{ 0S 2/ -> 0S }T
1235 T{ 1 2/ -> 0 }T
1236 T{ 4000 2/ -> 2000 }T
1237 T{ 1S 2/ -> 1S }T               \ MSB PROPOGATED
1238 T{ 1S 1 XOR 2/ -> 1S }T
1239 T{ MSB 2/ MSB AND -> MSB }T
1240
1241 T{ 1 0 LSHIFT -> 1 }T
1242 T{ 1 1 LSHIFT -> 2 }T
1243 T{ 1 2 LSHIFT -> 4 }T
1244 T{ 1 F LSHIFT -> 8000 }T            \ BIGGEST GUARANTEED SHIFT
1245 T{ 1S 1 LSHIFT 1 XOR -> 1S }T
1246 T{ MSB 1 LSHIFT -> 0 }T
1247
1248 T{ 1 0 RSHIFT -> 1 }T
1249 T{ 1 1 RSHIFT -> 0 }T
1250 T{ 2 1 RSHIFT -> 1 }T
1251 T{ 4 2 RSHIFT -> 1 }T
1252 T{ 8000 F RSHIFT -> 1 }T            \ BIGGEST
1253 T{ MSB 1 RSHIFT MSB AND -> 0 }T     \ RSHIFT ZERO FILLS MSBS
1254 T{ MSB 1 RSHIFT 2* -> MSB }T
1255
1256 \ ------------------------------------------------------------------------
1257 TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
1258 0 INVERT            CONSTANT MAX-UINT
1259 0 INVERT 1 RSHIFT       CONSTANT MAX-INT
1260 0 INVERT 1 RSHIFT INVERT    CONSTANT MIN-INT
1261 0 INVERT 1 RSHIFT       CONSTANT MID-UINT
1262 0 INVERT 1 RSHIFT INVERT    CONSTANT MID-UINT+1
1263
1264 0S CONSTANT <FALSE>
1265 1S CONSTANT <TRUE>
1266
1267 T{ 0 0= -> <TRUE> }T
1268 T{ 1 0= -> <FALSE> }T
1269 T{ 2 0= -> <FALSE> }T
1270 T{ -1 0= -> <FALSE> }T
1271 T{ MAX-UINT 0= -> <FALSE> }T
1272 T{ MIN-INT 0= -> <FALSE> }T
1273 T{ MAX-INT 0= -> <FALSE> }T
1274
1275 T{ 0 0 = -> <TRUE> }T
1276 T{ 1 1 = -> <TRUE> }T
1277 T{ -1 -1 = -> <TRUE> }T
1278 T{ 1 0 = -> <FALSE> }T
1279 T{ -1 0 = -> <FALSE> }T
1280 T{ 0 1 = -> <FALSE> }T
1281 T{ 0 -1 = -> <FALSE> }T
1282
1283 T{ 0 0< -> <FALSE> }T
1284 T{ -1 0< -> <TRUE> }T
1285 T{ MIN-INT 0< -> <TRUE> }T
1286 T{ 1 0< -> <FALSE> }T
1287 T{ MAX-INT 0< -> <FALSE> }T
1288
1289 T{ 0 1 < -> <TRUE> }T
1290 T{ 1 2 < -> <TRUE> }T
1291 T{ -1 0 < -> <TRUE> }T
1292 T{ -1 1 < -> <TRUE> }T
1293 T{ MIN-INT 0 < -> <TRUE> }T
1294 T{ MIN-INT MAX-INT < -> <TRUE> }T
1295 T{ 0 MAX-INT < -> <TRUE> }T
1296 T{ 0 0 < -> <FALSE> }T
1297 T{ 1 1 < -> <FALSE> }T
1298 T{ 1 0 < -> <FALSE> }T
1299 T{ 2 1 < -> <FALSE> }T
1300 T{ 0 -1 < -> <FALSE> }T
1301 T{ 1 -1 < -> <FALSE> }T
1302 T{ 0 MIN-INT < -> <FALSE> }T
1303 T{ MAX-INT MIN-INT < -> <FALSE> }T
1304 T{ MAX-INT 0 < -> <FALSE> }T
1305
1306 T{ 0 1 > -> <FALSE> }T
1307 T{ 1 2 > -> <FALSE> }T
1308 T{ -1 0 > -> <FALSE> }T
1309 T{ -1 1 > -> <FALSE> }T
1310 T{ MIN-INT 0 > -> <FALSE> }T
1311 T{ MIN-INT MAX-INT > -> <FALSE> }T
1312 T{ 0 MAX-INT > -> <FALSE> }T
1313 T{ 0 0 > -> <FALSE> }T
1314 T{ 1 1 > -> <FALSE> }T
1315 T{ 1 0 > -> <TRUE> }T
1316 T{ 2 1 > -> <TRUE> }T
1317 T{ 0 -1 > -> <TRUE> }T
1318 T{ 1 -1 > -> <TRUE> }T
1319 T{ 0 MIN-INT > -> <TRUE> }T
1320 T{ MAX-INT MIN-INT > -> <TRUE> }T
1321 T{ MAX-INT 0 > -> <TRUE> }T
1322
1323 T{ 0 1 U< -> <TRUE> }T
1324 T{ 1 2 U< -> <TRUE> }T
1325 T{ 0 MID-UINT U< -> <TRUE> }T
1326 T{ 0 MAX-UINT U< -> <TRUE> }T
1327 T{ MID-UINT MAX-UINT U< -> <TRUE> }T
1328 T{ 0 0 U< -> <FALSE> }T
1329 T{ 1 1 U< -> <FALSE> }T
1330 T{ 1 0 U< -> <FALSE> }T
1331 T{ 2 1 U< -> <FALSE> }T
1332 T{ MID-UINT 0 U< -> <FALSE> }T
1333 T{ MAX-UINT 0 U< -> <FALSE> }T
1334 T{ MAX-UINT MID-UINT U< -> <FALSE> }T
1335
1336 T{ 0 1 MIN -> 0 }T
1337 T{ 1 2 MIN -> 1 }T
1338 T{ -1 0 MIN -> -1 }T
1339 T{ -1 1 MIN -> -1 }T
1340 T{ MIN-INT 0 MIN -> MIN-INT }T
1341 T{ MIN-INT MAX-INT MIN -> MIN-INT }T
1342 T{ 0 MAX-INT MIN -> 0 }T
1343 T{ 0 0 MIN -> 0 }T
1344 T{ 1 1 MIN -> 1 }T
1345 T{ 1 0 MIN -> 0 }T
1346 T{ 2 1 MIN -> 1 }T
1347 T{ 0 -1 MIN -> -1 }T
1348 T{ 1 -1 MIN -> -1 }T
1349 T{ 0 MIN-INT MIN -> MIN-INT }T
1350 T{ MAX-INT MIN-INT MIN -> MIN-INT }T
1351 T{ MAX-INT 0 MIN -> 0 }T
1352
1353 T{ 0 1 MAX -> 1 }T
1354 T{ 1 2 MAX -> 2 }T
1355 T{ -1 0 MAX -> 0 }T
1356 T{ -1 1 MAX -> 1 }T
1357 T{ MIN-INT 0 MAX -> 0 }T
1358 T{ MIN-INT MAX-INT MAX -> MAX-INT }T
1359 T{ 0 MAX-INT MAX -> MAX-INT }T
1360 T{ 0 0 MAX -> 0 }T
1361 T{ 1 1 MAX -> 1 }T
1362 T{ 1 0 MAX -> 1 }T
1363 T{ 2 1 MAX -> 2 }T
1364 T{ 0 -1 MAX -> 0 }T
1365 T{ 1 -1 MAX -> 1 }T
1366 T{ 0 MIN-INT MAX -> 0 }T
1367 T{ MAX-INT MIN-INT MAX -> MAX-INT }T
1368 T{ MAX-INT 0 MAX -> MAX-INT }T
1369
1370 \ ------------------------------------------------------------------------
1371 TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
1372
1373 T{ 1 2 2DROP -> }T
1374 T{ 1 2 2DUP -> 1 2 1 2 }T
1375 T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T
1376 T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T
1377 T{ 0 ?DUP -> 0 }T
1378 T{ 1 ?DUP -> 1 1 }T
1379 T{ -1 ?DUP -> -1 -1 }T
1380 T{ DEPTH -> 0 }T
1381 T{ 0 DEPTH -> 0 1 }T
1382 T{ 0 1 DEPTH -> 0 1 2 }T
1383 T{ 0 DROP -> }T
1384 T{ 1 2 DROP -> 1 }T
1385 T{ 1 DUP -> 1 1 }T
1386 T{ 1 2 OVER -> 1 2 1 }T
1387 T{ 1 2 3 ROT -> 2 3 1 }T
1388 T{ 1 2 SWAP -> 2 1 }T
1389
1390 \ ------------------------------------------------------------------------
1391 TESTING >R R> R@
1392
1393 T{ : GR1 >R R> ; -> }T
1394 T{ : GR2 >R R@ R> DROP ; -> }T
1395 T{ 123 GR1 -> 123 }T
1396 T{ 123 GR2 -> 123 }T
1397 T{ 1S GR1 -> 1S }T   ( RETURN STACK HOLDS CELLS )
1398
1399 \ ------------------------------------------------------------------------
1400 TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
1401
1402 T{ 0 5 + -> 5 }T
1403 T{ 5 0 + -> 5 }T
1404 T{ 0 -5 + -> -5 }T
1405 T{ -5 0 + -> -5 }T
1406 T{ 1 2 + -> 3 }T
1407 T{ 1 -2 + -> -1 }T
1408 T{ -1 2 + -> 1 }T
1409 T{ -1 -2 + -> -3 }T
1410 T{ -1 1 + -> 0 }T
1411 T{ MID-UINT 1 + -> MID-UINT+1 }T
1412
1413 T{ 0 5 - -> -5 }T
1414 T{ 5 0 - -> 5 }T
1415 T{ 0 -5 - -> 5 }T
1416 T{ -5 0 - -> -5 }T
1417 T{ 1 2 - -> -1 }T
1418 T{ 1 -2 - -> 3 }T
1419 T{ -1 2 - -> -3 }T
1420 T{ -1 -2 - -> 1 }T
1421 T{ 0 1 - -> -1 }T
1422 T{ MID-UINT+1 1 - -> MID-UINT }T
1423
1424 T{ 0 1+ -> 1 }T
1425 T{ -1 1+ -> 0 }T
1426 T{ 1 1+ -> 2 }T
1427 T{ MID-UINT 1+ -> MID-UINT+1 }T
1428
1429 T{ 2 1- -> 1 }T
1430 T{ 1 1- -> 0 }T
1431 T{ 0 1- -> -1 }T
1432 T{ MID-UINT+1 1- -> MID-UINT }T
1433
1434 T{ 0 NEGATE -> 0 }T
1435 T{ 1 NEGATE -> -1 }T
1436 T{ -1 NEGATE -> 1 }T
1437 T{ 2 NEGATE -> -2 }T
1438 T{ -2 NEGATE -> 2 }T
1439
1440 T{ 0 ABS -> 0 }T
1441 T{ 1 ABS -> 1 }T
1442 T{ -1 ABS -> 1 }T
1443 T{ MIN-INT ABS -> MID-UINT+1 }T
1444
1445 \ ------------------------------------------------------------------------
1446 TESTING MULTIPLY: S>D * M* UM*
1447
1448 T{ 0 S>D -> 0 0 }T
1449 T{ 1 S>D -> 1 0 }T
1450 T{ 2 S>D -> 2 0 }T
1451 T{ -1 S>D -> -1 -1 }T
1452 T{ -2 S>D -> -2 -1 }T
1453 T{ MIN-INT S>D -> MIN-INT -1 }T
1454 T{ MAX-INT S>D -> MAX-INT 0 }T
1455
1456 T{ 0 0 M* -> 0 S>D }T
1457 T{ 0 1 M* -> 0 S>D }T
1458 T{ 1 0 M* -> 0 S>D }T
1459 T{ 1 2 M* -> 2 S>D }T
1460 T{ 2 1 M* -> 2 S>D }T
1461 T{ 3 3 M* -> 9 S>D }T
1462 T{ -3 3 M* -> -9 S>D }T
1463 T{ 3 -3 M* -> -9 S>D }T
1464 T{ -3 -3 M* -> 9 S>D }T
1465 T{ 0 MIN-INT M* -> 0 S>D }T
1466 T{ 1 MIN-INT M* -> MIN-INT S>D }T
1467 T{ 2 MIN-INT M* -> 0 1S }T
1468 T{ 0 MAX-INT M* -> 0 S>D }T
1469 T{ 1 MAX-INT M* -> MAX-INT S>D }T
1470 T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T
1471 T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T
1472 T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T
1473 T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T
1474
1475 T{ 0 0 * -> 0 }T                \ TEST IDENTITIES
1476 T{ 0 1 * -> 0 }T
1477 T{ 1 0 * -> 0 }T
1478 T{ 1 2 * -> 2 }T
1479 T{ 2 1 * -> 2 }T
1480 T{ 3 3 * -> 9 }T
1481 T{ -3 3 * -> -9 }T
1482 T{ 3 -3 * -> -9 }T
1483 T{ -3 -3 * -> 9 }T
1484
1485 T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T
1486 T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T
1487 T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T
1488
1489 T{ 0 0 UM* -> 0 0 }T
1490 T{ 0 1 UM* -> 0 0 }T
1491 T{ 1 0 UM* -> 0 0 }T
1492 T{ 1 2 UM* -> 2 0 }T
1493 T{ 2 1 UM* -> 2 0 }T
1494 T{ 3 3 UM* -> 9 0 }T
1495
1496 T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T
1497 T{ MID-UINT+1 2 UM* -> 0 1 }T
1498 T{ MID-UINT+1 4 UM* -> 0 2 }T
1499 T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T
1500 T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T
1501
1502 \ ------------------------------------------------------------------------
1503 TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
1504
1505 T{ 0 S>D 1 FM/MOD -> 0 0 }T
1506 T{ 1 S>D 1 FM/MOD -> 0 1 }T
1507 T{ 2 S>D 1 FM/MOD -> 0 2 }T
1508 T{ -1 S>D 1 FM/MOD -> 0 -1 }T
1509 T{ -2 S>D 1 FM/MOD -> 0 -2 }T
1510 T{ 0 S>D -1 FM/MOD -> 0 0 }T
1511 T{ 1 S>D -1 FM/MOD -> 0 -1 }T
1512 T{ 2 S>D -1 FM/MOD -> 0 -2 }T
1513 T{ -1 S>D -1 FM/MOD -> 0 1 }T
1514 T{ -2 S>D -1 FM/MOD -> 0 2 }T
1515 T{ 2 S>D 2 FM/MOD -> 0 1 }T
1516 T{ -1 S>D -1 FM/MOD -> 0 1 }T
1517 T{ -2 S>D -2 FM/MOD -> 0 1 }T
1518 T{  7 S>D  3 FM/MOD -> 1 2 }T
1519 T{  7 S>D -3 FM/MOD -> -2 -3 }T
1520 T{ -7 S>D  3 FM/MOD -> 2 -3 }T
1521 T{ -7 S>D -3 FM/MOD -> -1 2 }T
1522 T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T
1523 T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T
1524 T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T
1525 T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T
1526 T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T
1527 T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T
1528 T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T
1529 T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T
1530 T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T
1531 T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T
1532 T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T
1533 T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T
1534 T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T
1535 T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T
1536 T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T
1537 T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T
1538 T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T
1539
1540 T{ 0 S>D 1 SM/REM -> 0 0 }T
1541 T{ 1 S>D 1 SM/REM -> 0 1 }T
1542 T{ 2 S>D 1 SM/REM -> 0 2 }T
1543 T{ -1 S>D 1 SM/REM -> 0 -1 }T
1544 T{ -2 S>D 1 SM/REM -> 0 -2 }T
1545 T{ 0 S>D -1 SM/REM -> 0 0 }T
1546 T{ 1 S>D -1 SM/REM -> 0 -1 }T
1547 T{ 2 S>D -1 SM/REM -> 0 -2 }T
1548 T{ -1 S>D -1 SM/REM -> 0 1 }T
1549 T{ -2 S>D -1 SM/REM -> 0 2 }T
1550 T{ 2 S>D 2 SM/REM -> 0 1 }T
1551 T{ -1 S>D -1 SM/REM -> 0 1 }T
1552 T{ -2 S>D -2 SM/REM -> 0 1 }T
1553 T{  7 S>D  3 SM/REM -> 1 2 }T
1554 T{  7 S>D -3 SM/REM -> 1 -2 }T
1555 T{ -7 S>D  3 SM/REM -> -1 -2 }T
1556 T{ -7 S>D -3 SM/REM -> -1 2 }T
1557 T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T
1558 T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T
1559 T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T
1560 T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T
1561 T{ 1S 1 4 SM/REM -> 3 MAX-INT }T
1562 T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T
1563 T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T
1564 T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T
1565 T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T
1566 T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T
1567 T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T
1568 T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T
1569 T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T
1570
1571 T{ 0 0 1 UM/MOD -> 0 0 }T
1572 T{ 1 0 1 UM/MOD -> 0 1 }T
1573 T{ 1 0 2 UM/MOD -> 1 0 }T
1574 T{ 3 0 2 UM/MOD -> 1 1 }T
1575 T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T
1576 T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T
1577 T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T
1578
1579 : IFFLOORED
1580     [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
1581
1582 : IFSYM
1583     [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
1584
1585 \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
1586 \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
1587
1588 IFFLOORED : T/MOD  >R S>D R> FM/MOD ;
1589 IFFLOORED : T/     T/MOD SWAP DROP ;
1590 IFFLOORED : TMOD   T/MOD DROP ;
1591 IFFLOORED : T*/MOD >R M* R> FM/MOD ;
1592 IFFLOORED : T*/    T*/MOD SWAP DROP ;
1593 IFSYM     : T/MOD  >R S>D R> SM/REM ;
1594 IFSYM     : T/     T/MOD SWAP DROP ;
1595 IFSYM     : TMOD   T/MOD DROP ;
1596 IFSYM     : T*/MOD >R M* R> SM/REM ;
1597 IFSYM     : T*/    T*/MOD SWAP DROP ;
1598
1599 T{ 0 1 /MOD -> 0 1 T/MOD }T
1600 T{ 1 1 /MOD -> 1 1 T/MOD }T
1601 T{ 2 1 /MOD -> 2 1 T/MOD }T
1602 T{ -1 1 /MOD -> -1 1 T/MOD }T
1603 T{ -2 1 /MOD -> -2 1 T/MOD }T
1604 T{ 0 -1 /MOD -> 0 -1 T/MOD }T
1605 T{ 1 -1 /MOD -> 1 -1 T/MOD }T
1606 T{ 2 -1 /MOD -> 2 -1 T/MOD }T
1607 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
1608 T{ -2 -1 /MOD -> -2 -1 T/MOD }T
1609 T{ 2 2 /MOD -> 2 2 T/MOD }T
1610 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
1611 T{ -2 -2 /MOD -> -2 -2 T/MOD }T
1612 T{ 7 3 /MOD -> 7 3 T/MOD }T
1613 T{ 7 -3 /MOD -> 7 -3 T/MOD }T
1614 T{ -7 3 /MOD -> -7 3 T/MOD }T
1615 T{ -7 -3 /MOD -> -7 -3 T/MOD }T
1616 T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T
1617 T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T
1618 T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T
1619 T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T
1620
1621 T{ 0 1 / -> 0 1 T/ }T
1622 T{ 1 1 / -> 1 1 T/ }T
1623 T{ 2 1 / -> 2 1 T/ }T
1624 T{ -1 1 / -> -1 1 T/ }T
1625 T{ -2 1 / -> -2 1 T/ }T
1626 T{ 0 -1 / -> 0 -1 T/ }T
1627 T{ 1 -1 / -> 1 -1 T/ }T
1628 T{ 2 -1 / -> 2 -1 T/ }T
1629 T{ -1 -1 / -> -1 -1 T/ }T
1630 T{ -2 -1 / -> -2 -1 T/ }T
1631 T{ 2 2 / -> 2 2 T/ }T
1632 T{ -1 -1 / -> -1 -1 T/ }T
1633 T{ -2 -2 / -> -2 -2 T/ }T
1634 T{ 7 3 / -> 7 3 T/ }T
1635 T{ 7 -3 / -> 7 -3 T/ }T
1636 T{ -7 3 / -> -7 3 T/ }T
1637 T{ -7 -3 / -> -7 -3 T/ }T
1638 T{ MAX-INT 1 / -> MAX-INT 1 T/ }T
1639 T{ MIN-INT 1 / -> MIN-INT 1 T/ }T
1640 T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T
1641 T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T
1642
1643 T{ 0 1 MOD -> 0 1 TMOD }T
1644 T{ 1 1 MOD -> 1 1 TMOD }T
1645 T{ 2 1 MOD -> 2 1 TMOD }T
1646 T{ -1 1 MOD -> -1 1 TMOD }T
1647 T{ -2 1 MOD -> -2 1 TMOD }T
1648 T{ 0 -1 MOD -> 0 -1 TMOD }T
1649 T{ 1 -1 MOD -> 1 -1 TMOD }T
1650 T{ 2 -1 MOD -> 2 -1 TMOD }T
1651 T{ -1 -1 MOD -> -1 -1 TMOD }T
1652 T{ -2 -1 MOD -> -2 -1 TMOD }T
1653 T{ 2 2 MOD -> 2 2 TMOD }T
1654 T{ -1 -1 MOD -> -1 -1 TMOD }T
1655 T{ -2 -2 MOD -> -2 -2 TMOD }T
1656 T{ 7 3 MOD -> 7 3 TMOD }T
1657 T{ 7 -3 MOD -> 7 -3 TMOD }T
1658 T{ -7 3 MOD -> -7 3 TMOD }T
1659 T{ -7 -3 MOD -> -7 -3 TMOD }T
1660 T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T
1661 T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T
1662 T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T
1663 T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T
1664
1665 T{ 0 2 1 */ -> 0 2 1 T*/ }T
1666 T{ 1 2 1 */ -> 1 2 1 T*/ }T
1667 T{ 2 2 1 */ -> 2 2 1 T*/ }T
1668 T{ -1 2 1 */ -> -1 2 1 T*/ }T
1669 T{ -2 2 1 */ -> -2 2 1 T*/ }T
1670 T{ 0 2 -1 */ -> 0 2 -1 T*/ }T
1671 T{ 1 2 -1 */ -> 1 2 -1 T*/ }T
1672 T{ 2 2 -1 */ -> 2 2 -1 T*/ }T
1673 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
1674 T{ -2 2 -1 */ -> -2 2 -1 T*/ }T
1675 T{ 2 2 2 */ -> 2 2 2 T*/ }T
1676 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
1677 T{ -2 2 -2 */ -> -2 2 -2 T*/ }T
1678 T{ 7 2 3 */ -> 7 2 3 T*/ }T
1679 T{ 7 2 -3 */ -> 7 2 -3 T*/ }T
1680 T{ -7 2 3 */ -> -7 2 3 T*/ }T
1681 T{ -7 2 -3 */ -> -7 2 -3 T*/ }T
1682 T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T
1683 T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T
1684
1685 T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T
1686 T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T
1687 T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T
1688 T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T
1689 T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T
1690 T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T
1691 T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T
1692 T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T
1693 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
1694 T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T
1695 T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T
1696 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
1697 T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T
1698 T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T
1699 T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T
1700 T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T
1701 T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T
1702 T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T
1703 T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T
1704
1705 \ ------------------------------------------------------------------------
1706 TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
1707
1708 HERE 1 ALLOT
1709 HERE
1710 CONSTANT 2NDA
1711 CONSTANT 1STA
1712 T{ 1STA 2NDA U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
1713 T{ 1STA 1+ -> 2NDA }T           \ ... BY ONE ADDRESS UNIT
1714 ( MISSING TEST: NEGATIVE ALLOT )
1715
1716 HERE 1 ,
1717 HERE 2 ,
1718 CONSTANT 2ND
1719 CONSTANT 1ST
1720 T{ 1ST 2ND U< -> <TRUE> }T          \ HERE MUST GROW WITH ALLOT
1721 T{ 1ST CELL+ -> 2ND }T          \ ... BY ONE CELL
1722 T{ 1ST 1 CELLS + -> 2ND }T
1723 T{ 1ST @ 2ND @ -> 1 2 }T
1724 T{ 5 1ST ! -> }T
1725 T{ 1ST @ 2ND @ -> 5 2 }T
1726 T{ 6 2ND ! -> }T
1727 T{ 1ST @ 2ND @ -> 5 6 }T
1728 T{ 1ST 2@ -> 6 5 }T
1729 T{ 2 1 1ST 2! -> }T
1730 T{ 1ST 2@ -> 2 1 }T
1731 T{ 1S 1ST !  1ST @ -> 1S }T     \ CAN STORE CELL-WIDE VALUE
1732
1733 HERE 1 C,
1734 HERE 2 C,
1735 CONSTANT 2NDC
1736 CONSTANT 1STC
1737 T{ 1STC 2NDC U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
1738 T{ 1STC CHAR+ -> 2NDC }T            \ ... BY ONE CHAR
1739 T{ 1STC 1 CHARS + -> 2NDC }T
1740 T{ 1STC C@ 2NDC C@ -> 1 2 }T
1741 T{ 3 1STC C! -> }T
1742 T{ 1STC C@ 2NDC C@ -> 3 2 }T
1743 T{ 4 2NDC C! -> }T
1744 T{ 1STC C@ 2NDC C@ -> 3 4 }T
1745
1746 ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
1747 CONSTANT A-ADDR  CONSTANT UA-ADDR
1748 T{ UA-ADDR ALIGNED -> A-ADDR }T
1749 T{    1 A-ADDR C!  A-ADDR C@ ->    1 }T
1750 T{ 1234 A-ADDR  !  A-ADDR  @ -> 1234 }T
1751 T{ 123 456 A-ADDR 2!  A-ADDR 2@ -> 123 456 }T
1752 T{ 2 A-ADDR CHAR+ C!  A-ADDR CHAR+ C@ -> 2 }T
1753 T{ 3 A-ADDR CELL+ C!  A-ADDR CELL+ C@ -> 3 }T
1754 T{ 1234 A-ADDR CELL+ !  A-ADDR CELL+ @ -> 1234 }T
1755 T{ 123 456 A-ADDR CELL+ 2!  A-ADDR CELL+ 2@ -> 123 456 }T
1756
1757 : BITS ( X -- U )
1758     0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
1759 ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
1760 T{ 1 CHARS 1 < -> <FALSE> }T
1761 T{ 1 CHARS 1 CELLS > -> <FALSE> }T
1762 ( TBD: HOW TO FIND NUMBER OF BITS? )
1763
1764 ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
1765 T{ 1 CELLS 1 < -> <FALSE> }T
1766 T{ 1 CELLS 1 CHARS MOD -> 0 }T
1767 T{ 1S BITS 10 < -> <FALSE> }T
1768
1769 T{ 0 1ST ! -> }T
1770 T{ 1 1ST +! -> }T
1771 T{ 1ST @ -> 1 }T
1772 T{ -1 1ST +! 1ST @ -> 0 }T
1773
1774 \ ------------------------------------------------------------------------
1775 TESTING CHAR [CHAR] [ ] BL S"
1776
1777 T{ BL -> 20 }T
1778 T{ CHAR X -> 58 }T
1779 T{ CHAR HELLO -> 48 }T
1780 T{ : GC1 [CHAR] X ; -> }T
1781 T{ : GC2 [CHAR] HELLO ; -> }T
1782 T{ GC1 -> 58 }T
1783 T{ GC2 -> 48 }T
1784 T{ : GC3 [ GC1 ] LITERAL ; -> }T
1785 T{ GC3 -> 58 }T
1786 T{ : GC4 S" XY" ; -> }T
1787 T{ GC4 SWAP DROP -> 2 }T
1788 T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T
1789
1790 \ ------------------------------------------------------------------------
1791 TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
1792
1793 T{ : GT1 123 ; -> }T
1794 T{ ' GT1 EXECUTE -> 123 }T
1795 T{ : GT2 ['] GT1 ; IMMEDIATE -> }T
1796 T{ GT2 EXECUTE -> 123 }T
1797 HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
1798 HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
1799 T{ GT1STRING FIND -> ' GT1 -1 }T
1800 T{ GT2STRING FIND -> ' GT2 1 }T
1801 ( HOW TO SEARCH FOR NON-EXISTENT WORD? )
1802 T{ : GT3 GT2 LITERAL ; -> }T
1803 T{ GT3 -> ' GT1 }T
1804 T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T
1805
1806 T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T
1807 T{ : GT5 GT4 ; -> }T
1808 T{ GT5 -> 123 }T
1809 T{ : GT6 345 ; IMMEDIATE -> }T
1810 T{ : GT7 POSTPONE GT6 ; -> }T
1811 T{ GT7 -> 345 }T
1812
1813 T{ : GT8 STATE @ ; IMMEDIATE -> }T
1814 T{ GT8 -> 0 }T
1815 T{ : GT9 GT8 LITERAL ; -> }T
1816 T{ GT9 0= -> <FALSE> }T
1817
1818 \ ------------------------------------------------------------------------
1819 TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
1820
1821 T{ : GI1 IF 123 THEN ; -> }T
1822 T{ : GI2 IF 123 ELSE 234 THEN ; -> }T
1823 T{ 0 GI1 -> }T
1824 T{ 1 GI1 -> 123 }T
1825 T{ -1 GI1 -> 123 }T
1826 T{ 0 GI2 -> 234 }T
1827 T{ 1 GI2 -> 123 }T
1828 T{ -1 GI1 -> 123 }T
1829
1830 T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T
1831 T{ 0 GI3 -> 0 1 2 3 4 5 }T
1832 T{ 4 GI3 -> 4 5 }T
1833 T{ 5 GI3 -> 5 }T
1834 T{ 6 GI3 -> 6 }T
1835
1836 T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T
1837 T{ 3 GI4 -> 3 4 5 6 }T
1838 T{ 5 GI4 -> 5 6 }T
1839 T{ 6 GI4 -> 6 7 }T
1840
1841 T{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T
1842 T{ 1 GI5 -> 1 345 }T
1843 T{ 2 GI5 -> 2 345 }T
1844 T{ 3 GI5 -> 3 4 5 123 }T
1845 T{ 4 GI5 -> 4 5 123 }T
1846 T{ 5 GI5 -> 5 123 }T
1847
1848 T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T
1849 T{ 0 GI6 -> 0 }T
1850 T{ 1 GI6 -> 0 1 }T
1851 T{ 2 GI6 -> 0 1 2 }T
1852 T{ 3 GI6 -> 0 1 2 3 }T
1853 T{ 4 GI6 -> 0 1 2 3 4 }T
1854
1855 \ ------------------------------------------------------------------------
1856 TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
1857
1858 T{ : GD1 DO I LOOP ; -> }T
1859 T{ 4 1 GD1 -> 1 2 3 }T
1860 T{ 2 -1 GD1 -> -1 0 1 }T
1861 T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T
1862
1863 T{ : GD2 DO I -1 +LOOP ; -> }T
1864 T{ 1 4 GD2 -> 4 3 2 1 }T
1865 T{ -1 2 GD2 -> 2 1 0 -1 }T
1866 T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T
1867
1868 T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T
1869 T{ 4 1 GD3 -> 1 2 3 }T
1870 T{ 2 -1 GD3 -> -1 0 1 }T
1871 T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T
1872
1873 T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T
1874 T{ 1 4 GD4 -> 4 3 2 1 }T
1875 T{ -1 2 GD4 -> 2 1 0 -1 }T
1876 T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T
1877
1878 T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T
1879 T{ 1 GD5 -> 123 }T
1880 T{ 5 GD5 -> 123 }T
1881 T{ 6 GD5 -> 234 }T
1882
1883 T{ : GD6  ( PAT: T{0 0}T,T{0 0}TT{1 0}TT{1 1}T,T{0 0}TT{1 0}TT{1 1}TT{2 0}TT{2 1}TT{2 2}T )
1884     0 SWAP 0 DO
1885         I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
1886     LOOP ; -> }T
1887 T{ 1 GD6 -> 1 }T
1888 T{ 2 GD6 -> 3 }T
1889 T{ 3 GD6 -> 4 1 2 }T
1890
1891 \ ------------------------------------------------------------------------
1892 TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
1893
1894 T{ 123 CONSTANT X123 -> }T
1895 T{ X123 -> 123 }T
1896 T{ : EQU CONSTANT ; -> }T
1897 T{ X123 EQU Y123 -> }T
1898 T{ Y123 -> 123 }T
1899
1900 T{ VARIABLE V1 -> }T
1901 T{ 123 V1 ! -> }T
1902 T{ V1 @ -> 123 }T
1903
1904 T{ : NOP : POSTPONE ; ; -> }T
1905 T{ NOP NOP1 NOP NOP2 -> }T
1906 T{ NOP1 -> }T
1907 T{ NOP2 -> }T
1908
1909 T{ : DOES1 DOES> @ 1 + ; -> }T
1910 T{ : DOES2 DOES> @ 2 + ; -> }T
1911 T{ CREATE CR1 -> }T
1912 T{ CR1 -> HERE }T
1913 T{ ' CR1 >BODY -> HERE }T
1914 T{ 1 , -> }T
1915 T{ CR1 @ -> 1 }T
1916 T{ DOES1 -> }T
1917 T{ CR1 -> 2 }T
1918 T{ DOES2 -> }T
1919 T{ CR1 -> 3 }T
1920
1921 T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T
1922 T{ WEIRD: W1 -> }T
1923 T{ ' W1 >BODY -> HERE }T
1924 T{ W1 -> HERE 1 + }T
1925 T{ W1 -> HERE 2 + }T
1926
1927 \ ------------------------------------------------------------------------
1928 TESTING EVALUATE
1929
1930 : GE1 S" 123" ; IMMEDIATE
1931 : GE2 S" 123 1+" ; IMMEDIATE
1932 : GE3 S" : GE4 345 ;" ;
1933 : GE5 EVALUATE ; IMMEDIATE
1934
1935 T{ GE1 EVALUATE -> 123 }T           ( TEST EVALUATE IN INTERP. STATE )
1936 T{ GE2 EVALUATE -> 124 }T
1937 T{ GE3 EVALUATE -> }T
1938 T{ GE4 -> 345 }T
1939
1940 T{ : GE6 GE1 GE5 ; -> }T            ( TEST EVALUATE IN COMPILE STATE )
1941 T{ GE6 -> 123 }T
1942 T{ : GE7 GE2 GE5 ; -> }T
1943 T{ GE7 -> 124 }T
1944
1945 \ ------------------------------------------------------------------------
1946 TESTING SOURCE >IN WORD
1947
1948 : GS1 S" SOURCE" 2DUP EVALUATE
1949         >R SWAP >R = R> R> = ;
1950 T{ GS1 -> <TRUE> <TRUE> }T
1951
1952 VARIABLE SCANS
1953 : RESCAN?  -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
1954
1955 T{ 2 SCANS !
1956 345 RESCAN?
1957 -> 345 345 }T
1958
1959 : GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
1960 T{ GS2 -> 123 123 123 123 123 }T
1961
1962 : GS3 WORD COUNT SWAP C@ ;
1963 T{ BL GS3 HELLO -> 5 CHAR H }T
1964 T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T
1965 T{ BL GS3
1966 DROP -> 0 }T                \ BLANK LINE RETURN ZERO-LENGTH STRING
1967
1968 : GS4 SOURCE >IN ! DROP ;
1969 T{ GS4 123 456
1970 -> }T
1971
1972 \ ------------------------------------------------------------------------
1973 TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
1974
1975 : S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
1976     >R SWAP R@ = IF          \ MAKE SURE STRINGS HAVE SAME LENGTH
1977         R> ?DUP IF            \ IF NON-EMPTY STRINGS
1978         0 DO
1979         OVER C@ OVER C@ - IF
1980             2DROP <FALSE> UNLOOP EXIT THEN
1981         SWAP CHAR+ SWAP CHAR+
1982             LOOP
1983         THEN
1984         2DROP <TRUE>          \ IF WE GET HERE, STRINGS MATCH
1985     ELSE
1986         R> DROP 2DROP <FALSE>     \ LENGTHS MISMATCH
1987     THEN ;
1988
1989 : GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
1990 T{ GP1 -> <TRUE> }T
1991
1992 : GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
1993 T{ GP2 -> <TRUE> }T
1994
1995 : GP3  <# 1 0 # # #> S" 01" S= ;
1996 T{ GP3 -> <TRUE> }T
1997
1998 : GP4  <# 1 0 #S #> S" 1" S= ;
1999 T{ GP4 -> <TRUE> }T
2000
2001 24 CONSTANT MAX-BASE            \ BASE 2 .. 36
2002 : COUNT-BITS
2003     0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
2004 COUNT-BITS 2* CONSTANT #BITS-UD     \ NUMBER OF BITS IN UD
2005
2006 : GP5
2007     BASE @ <TRUE>
2008     MAX-BASE 1+ 2 DO         \ FOR EACH POSSIBLE BASE
2009         I BASE !              \ TBD: ASSUMES BASE WORKS
2010         I 0 <# #S #> S" 10" S= AND
2011     LOOP
2012     SWAP BASE ! ;
2013 T{ GP5 -> <TRUE> }T
2014
2015 : GP6
2016     BASE @ >R  2 BASE !
2017     MAX-UINT MAX-UINT <# #S #>       \ MAXIMUM UD TO BINARY
2018     R> BASE !                \ S: C-ADDR U
2019     DUP #BITS-UD = SWAP
2020     0 DO                 \ S: C-ADDR FLAG
2021         OVER C@ [CHAR] 1 = AND        \ ALL ONES
2022         >R CHAR+ R>
2023     LOOP SWAP DROP ;
2024 T{ GP6 -> <TRUE> }T
2025
2026 : GP7
2027     BASE @ >R    MAX-BASE BASE !
2028     <TRUE>
2029     A 0 DO
2030         I 0 <# #S #>
2031         1 = SWAP C@ I 30 + = AND AND
2032     LOOP
2033     MAX-BASE A DO
2034         I 0 <# #S #>
2035         1 = SWAP C@ 41 I A - + = AND AND
2036     LOOP
2037     R> BASE ! ;
2038
2039 T{ GP7 -> <TRUE> }T
2040
2041 \ >NUMBER TESTS
2042 CREATE GN-BUF 0 C,
2043 : GN-STRING GN-BUF 1 ;
2044 : GN-CONSUMED   GN-BUF CHAR+ 0 ;
2045 : GN'       [CHAR] ' WORD CHAR+ C@ GN-BUF C!  GN-STRING ;
2046
2047 T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T
2048 T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T
2049 T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T
2050 T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T   \ SHOULD FAIL TO CONVERT THESE
2051 T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T
2052 T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T
2053
2054 : >NUMBER-BASED
2055     BASE @ >R BASE ! >NUMBER R> BASE ! ;
2056
2057 T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T
2058 T{ 0 0 GN' 2'  2 >NUMBER-BASED -> 0 0 GN-STRING }T
2059 T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T
2060 T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T
2061 T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T
2062 T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T
2063
2064 : GN1   \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
2065     BASE @ >R BASE !
2066     <# #S #>
2067     0 0 2SWAP >NUMBER SWAP DROP      \ RETURN LENGTH ONLY
2068     R> BASE ! ;
2069 T{ 0 0 2 GN1 -> 0 0 0 }T
2070 T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
2071 T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
2072 T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T
2073 T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T
2074 T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T
2075
2076 : GN2   \ ( -- 16 10 )
2077     BASE @ >R  HEX BASE @  DECIMAL BASE @  R> BASE ! ;
2078 T{ GN2 -> 10 A }T
2079
2080 \ ------------------------------------------------------------------------
2081 TESTING FILL MOVE
2082
2083 CREATE FBUF 00 C, 00 C, 00 C,
2084 CREATE SBUF 12 C, 34 C, 56 C,
2085 : SEEBUF FBUF C@  FBUF CHAR+ C@  FBUF CHAR+ CHAR+ C@ ;
2086
2087 T{ FBUF 0 20 FILL -> }T
2088 T{ SEEBUF -> 00 00 00 }T
2089
2090 T{ FBUF 1 20 FILL -> }T
2091 T{ SEEBUF -> 20 00 00 }T
2092
2093 T{ FBUF 3 20 FILL -> }T
2094 T{ SEEBUF -> 20 20 20 }T
2095
2096 T{ FBUF FBUF 3 CHARS MOVE -> }T     \ BIZARRE SPECIAL CASE
2097 T{ SEEBUF -> 20 20 20 }T
2098
2099 T{ SBUF FBUF 0 CHARS MOVE -> }T
2100 T{ SEEBUF -> 20 20 20 }T
2101
2102 T{ SBUF FBUF 1 CHARS MOVE -> }T
2103 T{ SEEBUF -> 12 20 20 }T
2104
2105 T{ SBUF FBUF 3 CHARS MOVE -> }T
2106 T{ SEEBUF -> 12 34 56 }T
2107
2108 T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T
2109 T{ SEEBUF -> 12 12 34 }T
2110
2111 T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T
2112 T{ SEEBUF -> 12 34 34 }T
2113
2114 \ ------------------------------------------------------------------------
2115 TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
2116
2117 : OUTPUT-TEST
2118     ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
2119     41 BL DO I EMIT LOOP CR
2120     61 41 DO I EMIT LOOP CR
2121     7F 61 DO I EMIT LOOP CR
2122     ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
2123     9 1+ 0 DO I . LOOP CR
2124     ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
2125     [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
2126     ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
2127     [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
2128     ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
2129     5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
2130     ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
2131     S" LINE 1" TYPE CR S" LINE 2" TYPE CR
2132     ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
2133     ."   SIGNED: " MIN-INT . MAX-INT . CR
2134     ." UNSIGNED: " 0 U. MAX-UINT U. CR
2135 ;
2136
2137 T{ OUTPUT-TEST -> }T
2138 \ ------------------------------------------------------------------------
2139 TESTING INPUT: ACCEPT
2140
2141 CREATE ABUF 80 CHARS ALLOT
2142
2143 : ACCEPT-TEST
2144     CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
2145     ABUF 80 ACCEPT
2146     CR ." RECEIVED: " [CHAR] " EMIT
2147     ABUF SWAP TYPE [CHAR] " EMIT CR
2148 ;
2149
2150 T{ ACCEPT-TEST -> }T
2151 Vingt fois sur le métier remettez votre ouvrage, ...
2152 \ ------------------------------------------------------------------------
2153 TESTING DICTIONARY SEARCH RULES
2154
2155 T{ : GDX   123 ; : GDX   GDX 234 ; -> }T
2156
2157 T{ GDX -> 123 234 }T
2158
2159 CR .( End of Core word set tests) CR
2160
2161
2162
2163 RST_STATE   ; so ANS_COMPLEMENT_xx_MPY is conserved ;
2164 \ NOECHO      ; if an error occurs, comment this line before new download to find it.
2165
2166
2167 \ From: John Hayes S1I
2168 \ Subject: tester.fr
2169 \ Date: Mon, 27 Nov 95 13:10:09 PST
2170
2171 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
2172 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
2173 \ VERSION 1.1
2174
2175 \ 22/1/09 The words { and } have been changed to T{ and }T respectively to
2176 \ agree with the Forth 200X file ttester.fs. This avoids clashes with
2177 \ locals using { ... } and the FSL use of }
2178
2179
2180 \ 13/05/14 jmt. added colorised error messages.
2181
2182
2183
2184  0 CONSTANT FALSE
2185 -1 CONSTANT TRUE
2186
2187 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
2188 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
2189 VARIABLE VERBOSE
2190     FALSE VERBOSE !
2191 \   TRUE VERBOSE !
2192
2193 \ : EMPTY-STACK ( ... -- )  \ EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
2194 \     DEPTH ?DUP
2195 \             IF DUP 0< IF NEGATE 0
2196 \             DO 0 LOOP
2197 \             ELSE 0 DO DROP LOOP THEN
2198 \             THEN ;
2199 \
2200 \ : ERROR     \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
2201 \         \ THE LINE THAT HAD THE ERROR.
2202 \     TYPE SOURCE TYPE CR          \ DISPLAY LINE CORRESPONDING TO ERROR
2203 \     EMPTY-STACK              \ THROW AWAY EVERY THING ELSE
2204 \     QUIT  \ *** Uncomment this line to QUIT on an error
2205 \ ;
2206
2207 VARIABLE ACTUAL-DEPTH           \ STACK RECORD
2208 CREATE ACTUAL-RESULTS 20 CELLS ALLOT
2209
2210 : T{        \ ( -- ) SYNTACTIC SUGAR.
2211     ;
2212
2213 : ->        \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
2214     DEPTH DUP ACTUAL-DEPTH !     \ RECORD DEPTH
2215     ?DUP IF              \ IF THERE IS SOMETHING ON STACK
2216         0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
2217     THEN ;
2218
2219 : }T        \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
2220             \ (ACTUAL) CONTENTS.
2221     DEPTH ACTUAL-DEPTH @ = IF   \ IF DEPTHS MATCH
2222         DEPTH ?DUP IF           \ IF THERE IS SOMETHING ON THE STACK
2223         0 DO                    \ FOR EACH STACK ITEM
2224             ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
2225 \           = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN   \ jmt
2226             = 0= IF ABORT" INCORRECT RESULT: " THEN           \ jmt : colorised message
2227         LOOP
2228         THEN
2229     ELSE                 \ DEPTH MISMATCH
2230 \       S" WRONG NUMBER OF RESULTS: " ERROR \ jmt
2231         ABORT" WRONG NUMBER OF RESULTS: "   \ jmt : colorised message
2232     THEN ;
2233
2234 : TESTING   \ ( -- ) TALKING COMMENT.
2235     SOURCE VERBOSE @
2236     IF DUP >R TYPE CR R> >IN !
2237     ELSE >IN ! DROP [CHAR] * EMIT
2238     THEN ;
2239
2240 \ From: John Hayes S1I
2241 \ Subject: core.fr
2242 \ Date: Mon, 27 Nov 95 13:10
2243
2244 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
2245 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
2246 \ VERSION 1.2
2247 \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
2248 \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
2249 \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
2250 \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
2251 \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
2252 \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
2253
2254 CR
2255 TESTING CORE WORDS
2256 HEX
2257
2258 \ ------------------------------------------------------------------------
2259 TESTING BASIC ASSUMPTIONS
2260
2261 T{ -> }T                    \ START WITH CLEAN SLATE
2262 ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
2263 T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T
2264 T{  0 BITSSET? -> 0 }T      ( ZERO IS ALL BITS CLEAR )
2265 T{  1 BITSSET? -> 0 0 }T        ( OTHER NUMBER HAVE AT LEAST ONE BIT )
2266 T{ -1 BITSSET? -> 0 0 }T
2267
2268 \ ------------------------------------------------------------------------
2269 TESTING BOOLEANS: INVERT AND OR XOR
2270
2271 T{ 0 0 AND -> 0 }T
2272 T{ 0 1 AND -> 0 }T
2273 T{ 1 0 AND -> 0 }T
2274 T{ 1 1 AND -> 1 }T
2275
2276 T{ 0 INVERT 1 AND -> 1 }T
2277 T{ 1 INVERT 1 AND -> 0 }T
2278
2279 0    CONSTANT 0S
2280 0 INVERT CONSTANT 1S
2281
2282 T{ 0S INVERT -> 1S }T
2283 T{ 1S INVERT -> 0S }T
2284
2285 T{ 0S 0S AND -> 0S }T
2286 T{ 0S 1S AND -> 0S }T
2287 T{ 1S 0S AND -> 0S }T
2288 T{ 1S 1S AND -> 1S }T
2289
2290 T{ 0S 0S OR -> 0S }T
2291 T{ 0S 1S OR -> 1S }T
2292 T{ 1S 0S OR -> 1S }T
2293 T{ 1S 1S OR -> 1S }T
2294
2295 T{ 0S 0S XOR -> 0S }T
2296 T{ 0S 1S XOR -> 1S }T
2297 T{ 1S 0S XOR -> 1S }T
2298 T{ 1S 1S XOR -> 0S }T
2299
2300 \ ------------------------------------------------------------------------
2301 TESTING 2* 2/ LSHIFT RSHIFT
2302
2303 ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
2304 1S 1 RSHIFT INVERT CONSTANT MSB
2305 T{ MSB BITSSET? -> 0 0 }T
2306
2307 T{ 0S 2* -> 0S }T
2308 T{ 1 2* -> 2 }T
2309 T{ 4000 2* -> 8000 }T
2310 T{ 1S 2* 1 XOR -> 1S }T
2311 T{ MSB 2* -> 0S }T
2312
2313 T{ 0S 2/ -> 0S }T
2314 T{ 1 2/ -> 0 }T
2315 T{ 4000 2/ -> 2000 }T
2316 T{ 1S 2/ -> 1S }T               \ MSB PROPOGATED
2317 T{ 1S 1 XOR 2/ -> 1S }T
2318 T{ MSB 2/ MSB AND -> MSB }T
2319
2320 T{ 1 0 LSHIFT -> 1 }T
2321 T{ 1 1 LSHIFT -> 2 }T
2322 T{ 1 2 LSHIFT -> 4 }T
2323 T{ 1 F LSHIFT -> 8000 }T            \ BIGGEST GUARANTEED SHIFT
2324 T{ 1S 1 LSHIFT 1 XOR -> 1S }T
2325 T{ MSB 1 LSHIFT -> 0 }T
2326
2327 T{ 1 0 RSHIFT -> 1 }T
2328 T{ 1 1 RSHIFT -> 0 }T
2329 T{ 2 1 RSHIFT -> 1 }T
2330 T{ 4 2 RSHIFT -> 1 }T
2331 T{ 8000 F RSHIFT -> 1 }T            \ BIGGEST
2332 T{ MSB 1 RSHIFT MSB AND -> 0 }T     \ RSHIFT ZERO FILLS MSBS
2333 T{ MSB 1 RSHIFT 2* -> MSB }T
2334
2335 \ ------------------------------------------------------------------------
2336 TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
2337 0 INVERT            CONSTANT MAX-UINT
2338 0 INVERT 1 RSHIFT       CONSTANT MAX-INT
2339 0 INVERT 1 RSHIFT INVERT    CONSTANT MIN-INT
2340 0 INVERT 1 RSHIFT       CONSTANT MID-UINT
2341 0 INVERT 1 RSHIFT INVERT    CONSTANT MID-UINT+1
2342
2343 0S CONSTANT <FALSE>
2344 1S CONSTANT <TRUE>
2345
2346 T{ 0 0= -> <TRUE> }T
2347 T{ 1 0= -> <FALSE> }T
2348 T{ 2 0= -> <FALSE> }T
2349 T{ -1 0= -> <FALSE> }T
2350 T{ MAX-UINT 0= -> <FALSE> }T
2351 T{ MIN-INT 0= -> <FALSE> }T
2352 T{ MAX-INT 0= -> <FALSE> }T
2353
2354 T{ 0 0 = -> <TRUE> }T
2355 T{ 1 1 = -> <TRUE> }T
2356 T{ -1 -1 = -> <TRUE> }T
2357 T{ 1 0 = -> <FALSE> }T
2358 T{ -1 0 = -> <FALSE> }T
2359 T{ 0 1 = -> <FALSE> }T
2360 T{ 0 -1 = -> <FALSE> }T
2361
2362 T{ 0 0< -> <FALSE> }T
2363 T{ -1 0< -> <TRUE> }T
2364 T{ MIN-INT 0< -> <TRUE> }T
2365 T{ 1 0< -> <FALSE> }T
2366 T{ MAX-INT 0< -> <FALSE> }T
2367
2368 T{ 0 1 < -> <TRUE> }T
2369 T{ 1 2 < -> <TRUE> }T
2370 T{ -1 0 < -> <TRUE> }T
2371 T{ -1 1 < -> <TRUE> }T
2372 T{ MIN-INT 0 < -> <TRUE> }T
2373 T{ MIN-INT MAX-INT < -> <TRUE> }T
2374 T{ 0 MAX-INT < -> <TRUE> }T
2375 T{ 0 0 < -> <FALSE> }T
2376 T{ 1 1 < -> <FALSE> }T
2377 T{ 1 0 < -> <FALSE> }T
2378 T{ 2 1 < -> <FALSE> }T
2379 T{ 0 -1 < -> <FALSE> }T
2380 T{ 1 -1 < -> <FALSE> }T
2381 T{ 0 MIN-INT < -> <FALSE> }T
2382 T{ MAX-INT MIN-INT < -> <FALSE> }T
2383 T{ MAX-INT 0 < -> <FALSE> }T
2384
2385 T{ 0 1 > -> <FALSE> }T
2386 T{ 1 2 > -> <FALSE> }T
2387 T{ -1 0 > -> <FALSE> }T
2388 T{ -1 1 > -> <FALSE> }T
2389 T{ MIN-INT 0 > -> <FALSE> }T
2390 T{ MIN-INT MAX-INT > -> <FALSE> }T
2391 T{ 0 MAX-INT > -> <FALSE> }T
2392 T{ 0 0 > -> <FALSE> }T
2393 T{ 1 1 > -> <FALSE> }T
2394 T{ 1 0 > -> <TRUE> }T
2395 T{ 2 1 > -> <TRUE> }T
2396 T{ 0 -1 > -> <TRUE> }T
2397 T{ 1 -1 > -> <TRUE> }T
2398 T{ 0 MIN-INT > -> <TRUE> }T
2399 T{ MAX-INT MIN-INT > -> <TRUE> }T
2400 T{ MAX-INT 0 > -> <TRUE> }T
2401
2402 T{ 0 1 U< -> <TRUE> }T
2403 T{ 1 2 U< -> <TRUE> }T
2404 T{ 0 MID-UINT U< -> <TRUE> }T
2405 T{ 0 MAX-UINT U< -> <TRUE> }T
2406 T{ MID-UINT MAX-UINT U< -> <TRUE> }T
2407 T{ 0 0 U< -> <FALSE> }T
2408 T{ 1 1 U< -> <FALSE> }T
2409 T{ 1 0 U< -> <FALSE> }T
2410 T{ 2 1 U< -> <FALSE> }T
2411 T{ MID-UINT 0 U< -> <FALSE> }T
2412 T{ MAX-UINT 0 U< -> <FALSE> }T
2413 T{ MAX-UINT MID-UINT U< -> <FALSE> }T
2414
2415 T{ 0 1 MIN -> 0 }T
2416 T{ 1 2 MIN -> 1 }T
2417 T{ -1 0 MIN -> -1 }T
2418 T{ -1 1 MIN -> -1 }T
2419 T{ MIN-INT 0 MIN -> MIN-INT }T
2420 T{ MIN-INT MAX-INT MIN -> MIN-INT }T
2421 T{ 0 MAX-INT MIN -> 0 }T
2422 T{ 0 0 MIN -> 0 }T
2423 T{ 1 1 MIN -> 1 }T
2424 T{ 1 0 MIN -> 0 }T
2425 T{ 2 1 MIN -> 1 }T
2426 T{ 0 -1 MIN -> -1 }T
2427 T{ 1 -1 MIN -> -1 }T
2428 T{ 0 MIN-INT MIN -> MIN-INT }T
2429 T{ MAX-INT MIN-INT MIN -> MIN-INT }T
2430 T{ MAX-INT 0 MIN -> 0 }T
2431
2432 T{ 0 1 MAX -> 1 }T
2433 T{ 1 2 MAX -> 2 }T
2434 T{ -1 0 MAX -> 0 }T
2435 T{ -1 1 MAX -> 1 }T
2436 T{ MIN-INT 0 MAX -> 0 }T
2437 T{ MIN-INT MAX-INT MAX -> MAX-INT }T
2438 T{ 0 MAX-INT MAX -> MAX-INT }T
2439 T{ 0 0 MAX -> 0 }T
2440 T{ 1 1 MAX -> 1 }T
2441 T{ 1 0 MAX -> 1 }T
2442 T{ 2 1 MAX -> 2 }T
2443 T{ 0 -1 MAX -> 0 }T
2444 T{ 1 -1 MAX -> 1 }T
2445 T{ 0 MIN-INT MAX -> 0 }T
2446 T{ MAX-INT MIN-INT MAX -> MAX-INT }T
2447 T{ MAX-INT 0 MAX -> MAX-INT }T
2448
2449 \ ------------------------------------------------------------------------
2450 TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
2451
2452 T{ 1 2 2DROP -> }T
2453 T{ 1 2 2DUP -> 1 2 1 2 }T
2454 T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T
2455 T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T
2456 T{ 0 ?DUP -> 0 }T
2457 T{ 1 ?DUP -> 1 1 }T
2458 T{ -1 ?DUP -> -1 -1 }T
2459 T{ DEPTH -> 0 }T
2460 T{ 0 DEPTH -> 0 1 }T
2461 T{ 0 1 DEPTH -> 0 1 2 }T
2462 T{ 0 DROP -> }T
2463 T{ 1 2 DROP -> 1 }T
2464 T{ 1 DUP -> 1 1 }T
2465 T{ 1 2 OVER -> 1 2 1 }T
2466 T{ 1 2 3 ROT -> 2 3 1 }T
2467 T{ 1 2 SWAP -> 2 1 }T
2468
2469 \ ------------------------------------------------------------------------
2470 TESTING >R R> R@
2471
2472 T{ : GR1 >R R> ; -> }T
2473 T{ : GR2 >R R@ R> DROP ; -> }T
2474 T{ 123 GR1 -> 123 }T
2475 T{ 123 GR2 -> 123 }T
2476 T{ 1S GR1 -> 1S }T   ( RETURN STACK HOLDS CELLS )
2477
2478 \ ------------------------------------------------------------------------
2479 TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
2480
2481 T{ 0 5 + -> 5 }T
2482 T{ 5 0 + -> 5 }T
2483 T{ 0 -5 + -> -5 }T
2484 T{ -5 0 + -> -5 }T
2485 T{ 1 2 + -> 3 }T
2486 T{ 1 -2 + -> -1 }T
2487 T{ -1 2 + -> 1 }T
2488 T{ -1 -2 + -> -3 }T
2489 T{ -1 1 + -> 0 }T
2490 T{ MID-UINT 1 + -> MID-UINT+1 }T
2491
2492 T{ 0 5 - -> -5 }T
2493 T{ 5 0 - -> 5 }T
2494 T{ 0 -5 - -> 5 }T
2495 T{ -5 0 - -> -5 }T
2496 T{ 1 2 - -> -1 }T
2497 T{ 1 -2 - -> 3 }T
2498 T{ -1 2 - -> -3 }T
2499 T{ -1 -2 - -> 1 }T
2500 T{ 0 1 - -> -1 }T
2501 T{ MID-UINT+1 1 - -> MID-UINT }T
2502
2503 T{ 0 1+ -> 1 }T
2504 T{ -1 1+ -> 0 }T
2505 T{ 1 1+ -> 2 }T
2506 T{ MID-UINT 1+ -> MID-UINT+1 }T
2507
2508 T{ 2 1- -> 1 }T
2509 T{ 1 1- -> 0 }T
2510 T{ 0 1- -> -1 }T
2511 T{ MID-UINT+1 1- -> MID-UINT }T
2512
2513 T{ 0 NEGATE -> 0 }T
2514 T{ 1 NEGATE -> -1 }T
2515 T{ -1 NEGATE -> 1 }T
2516 T{ 2 NEGATE -> -2 }T
2517 T{ -2 NEGATE -> 2 }T
2518
2519 T{ 0 ABS -> 0 }T
2520 T{ 1 ABS -> 1 }T
2521 T{ -1 ABS -> 1 }T
2522 T{ MIN-INT ABS -> MID-UINT+1 }T
2523
2524 \ ------------------------------------------------------------------------
2525 TESTING MULTIPLY: S>D * M* UM*
2526
2527 T{ 0 S>D -> 0 0 }T
2528 T{ 1 S>D -> 1 0 }T
2529 T{ 2 S>D -> 2 0 }T
2530 T{ -1 S>D -> -1 -1 }T
2531 T{ -2 S>D -> -2 -1 }T
2532 T{ MIN-INT S>D -> MIN-INT -1 }T
2533 T{ MAX-INT S>D -> MAX-INT 0 }T
2534
2535 T{ 0 0 M* -> 0 S>D }T
2536 T{ 0 1 M* -> 0 S>D }T
2537 T{ 1 0 M* -> 0 S>D }T
2538 T{ 1 2 M* -> 2 S>D }T
2539 T{ 2 1 M* -> 2 S>D }T
2540 T{ 3 3 M* -> 9 S>D }T
2541 T{ -3 3 M* -> -9 S>D }T
2542 T{ 3 -3 M* -> -9 S>D }T
2543 T{ -3 -3 M* -> 9 S>D }T
2544 T{ 0 MIN-INT M* -> 0 S>D }T
2545 T{ 1 MIN-INT M* -> MIN-INT S>D }T
2546 T{ 2 MIN-INT M* -> 0 1S }T
2547 T{ 0 MAX-INT M* -> 0 S>D }T
2548 T{ 1 MAX-INT M* -> MAX-INT S>D }T
2549 T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T
2550 T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T
2551 T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T
2552 T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T
2553
2554 T{ 0 0 * -> 0 }T                \ TEST IDENTITIES
2555 T{ 0 1 * -> 0 }T
2556 T{ 1 0 * -> 0 }T
2557 T{ 1 2 * -> 2 }T
2558 T{ 2 1 * -> 2 }T
2559 T{ 3 3 * -> 9 }T
2560 T{ -3 3 * -> -9 }T
2561 T{ 3 -3 * -> -9 }T
2562 T{ -3 -3 * -> 9 }T
2563
2564 T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T
2565 T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T
2566 T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T
2567
2568 T{ 0 0 UM* -> 0 0 }T
2569 T{ 0 1 UM* -> 0 0 }T
2570 T{ 1 0 UM* -> 0 0 }T
2571 T{ 1 2 UM* -> 2 0 }T
2572 T{ 2 1 UM* -> 2 0 }T
2573 T{ 3 3 UM* -> 9 0 }T
2574
2575 T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T
2576 T{ MID-UINT+1 2 UM* -> 0 1 }T
2577 T{ MID-UINT+1 4 UM* -> 0 2 }T
2578 T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T
2579 T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T
2580
2581 \ ------------------------------------------------------------------------
2582 TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
2583
2584 T{ 0 S>D 1 FM/MOD -> 0 0 }T
2585 T{ 1 S>D 1 FM/MOD -> 0 1 }T
2586 T{ 2 S>D 1 FM/MOD -> 0 2 }T
2587 T{ -1 S>D 1 FM/MOD -> 0 -1 }T
2588 T{ -2 S>D 1 FM/MOD -> 0 -2 }T
2589 T{ 0 S>D -1 FM/MOD -> 0 0 }T
2590 T{ 1 S>D -1 FM/MOD -> 0 -1 }T
2591 T{ 2 S>D -1 FM/MOD -> 0 -2 }T
2592 T{ -1 S>D -1 FM/MOD -> 0 1 }T
2593 T{ -2 S>D -1 FM/MOD -> 0 2 }T
2594 T{ 2 S>D 2 FM/MOD -> 0 1 }T
2595 T{ -1 S>D -1 FM/MOD -> 0 1 }T
2596 T{ -2 S>D -2 FM/MOD -> 0 1 }T
2597 T{  7 S>D  3 FM/MOD -> 1 2 }T
2598 T{  7 S>D -3 FM/MOD -> -2 -3 }T
2599 T{ -7 S>D  3 FM/MOD -> 2 -3 }T
2600 T{ -7 S>D -3 FM/MOD -> -1 2 }T
2601 T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T
2602 T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T
2603 T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T
2604 T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T
2605 T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T
2606 T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T
2607 T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T
2608 T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T
2609 T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T
2610 T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T
2611 T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T
2612 T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T
2613 T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T
2614 T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T
2615 T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T
2616 T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T
2617 T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T
2618
2619 T{ 0 S>D 1 SM/REM -> 0 0 }T
2620 T{ 1 S>D 1 SM/REM -> 0 1 }T
2621 T{ 2 S>D 1 SM/REM -> 0 2 }T
2622 T{ -1 S>D 1 SM/REM -> 0 -1 }T
2623 T{ -2 S>D 1 SM/REM -> 0 -2 }T
2624 T{ 0 S>D -1 SM/REM -> 0 0 }T
2625 T{ 1 S>D -1 SM/REM -> 0 -1 }T
2626 T{ 2 S>D -1 SM/REM -> 0 -2 }T
2627 T{ -1 S>D -1 SM/REM -> 0 1 }T
2628 T{ -2 S>D -1 SM/REM -> 0 2 }T
2629 T{ 2 S>D 2 SM/REM -> 0 1 }T
2630 T{ -1 S>D -1 SM/REM -> 0 1 }T
2631 T{ -2 S>D -2 SM/REM -> 0 1 }T
2632 T{  7 S>D  3 SM/REM -> 1 2 }T
2633 T{  7 S>D -3 SM/REM -> 1 -2 }T
2634 T{ -7 S>D  3 SM/REM -> -1 -2 }T
2635 T{ -7 S>D -3 SM/REM -> -1 2 }T
2636 T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T
2637 T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T
2638 T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T
2639 T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T
2640 T{ 1S 1 4 SM/REM -> 3 MAX-INT }T
2641 T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T
2642 T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T
2643 T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T
2644 T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T
2645 T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T
2646 T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T
2647 T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T
2648 T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T
2649
2650 T{ 0 0 1 UM/MOD -> 0 0 }T
2651 T{ 1 0 1 UM/MOD -> 0 1 }T
2652 T{ 1 0 2 UM/MOD -> 1 0 }T
2653 T{ 3 0 2 UM/MOD -> 1 1 }T
2654 T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T
2655 T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T
2656 T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T
2657
2658 : IFFLOORED
2659     [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
2660
2661 : IFSYM
2662     [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
2663
2664 \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
2665 \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
2666
2667 IFFLOORED : T/MOD  >R S>D R> FM/MOD ;
2668 IFFLOORED : T/     T/MOD SWAP DROP ;
2669 IFFLOORED : TMOD   T/MOD DROP ;
2670 IFFLOORED : T*/MOD >R M* R> FM/MOD ;
2671 IFFLOORED : T*/    T*/MOD SWAP DROP ;
2672 IFSYM     : T/MOD  >R S>D R> SM/REM ;
2673 IFSYM     : T/     T/MOD SWAP DROP ;
2674 IFSYM     : TMOD   T/MOD DROP ;
2675 IFSYM     : T*/MOD >R M* R> SM/REM ;
2676 IFSYM     : T*/    T*/MOD SWAP DROP ;
2677
2678 T{ 0 1 /MOD -> 0 1 T/MOD }T
2679 T{ 1 1 /MOD -> 1 1 T/MOD }T
2680 T{ 2 1 /MOD -> 2 1 T/MOD }T
2681 T{ -1 1 /MOD -> -1 1 T/MOD }T
2682 T{ -2 1 /MOD -> -2 1 T/MOD }T
2683 T{ 0 -1 /MOD -> 0 -1 T/MOD }T
2684 T{ 1 -1 /MOD -> 1 -1 T/MOD }T
2685 T{ 2 -1 /MOD -> 2 -1 T/MOD }T
2686 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
2687 T{ -2 -1 /MOD -> -2 -1 T/MOD }T
2688 T{ 2 2 /MOD -> 2 2 T/MOD }T
2689 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
2690 T{ -2 -2 /MOD -> -2 -2 T/MOD }T
2691 T{ 7 3 /MOD -> 7 3 T/MOD }T
2692 T{ 7 -3 /MOD -> 7 -3 T/MOD }T
2693 T{ -7 3 /MOD -> -7 3 T/MOD }T
2694 T{ -7 -3 /MOD -> -7 -3 T/MOD }T
2695 T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T
2696 T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T
2697 T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T
2698 T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T
2699
2700 T{ 0 1 / -> 0 1 T/ }T
2701 T{ 1 1 / -> 1 1 T/ }T
2702 T{ 2 1 / -> 2 1 T/ }T
2703 T{ -1 1 / -> -1 1 T/ }T
2704 T{ -2 1 / -> -2 1 T/ }T
2705 T{ 0 -1 / -> 0 -1 T/ }T
2706 T{ 1 -1 / -> 1 -1 T/ }T
2707 T{ 2 -1 / -> 2 -1 T/ }T
2708 T{ -1 -1 / -> -1 -1 T/ }T
2709 T{ -2 -1 / -> -2 -1 T/ }T
2710 T{ 2 2 / -> 2 2 T/ }T
2711 T{ -1 -1 / -> -1 -1 T/ }T
2712 T{ -2 -2 / -> -2 -2 T/ }T
2713 T{ 7 3 / -> 7 3 T/ }T
2714 T{ 7 -3 / -> 7 -3 T/ }T
2715 T{ -7 3 / -> -7 3 T/ }T
2716 T{ -7 -3 / -> -7 -3 T/ }T
2717 T{ MAX-INT 1 / -> MAX-INT 1 T/ }T
2718 T{ MIN-INT 1 / -> MIN-INT 1 T/ }T
2719 T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T
2720 T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T
2721
2722 T{ 0 1 MOD -> 0 1 TMOD }T
2723 T{ 1 1 MOD -> 1 1 TMOD }T
2724 T{ 2 1 MOD -> 2 1 TMOD }T
2725 T{ -1 1 MOD -> -1 1 TMOD }T
2726 T{ -2 1 MOD -> -2 1 TMOD }T
2727 T{ 0 -1 MOD -> 0 -1 TMOD }T
2728 T{ 1 -1 MOD -> 1 -1 TMOD }T
2729 T{ 2 -1 MOD -> 2 -1 TMOD }T
2730 T{ -1 -1 MOD -> -1 -1 TMOD }T
2731 T{ -2 -1 MOD -> -2 -1 TMOD }T
2732 T{ 2 2 MOD -> 2 2 TMOD }T
2733 T{ -1 -1 MOD -> -1 -1 TMOD }T
2734 T{ -2 -2 MOD -> -2 -2 TMOD }T
2735 T{ 7 3 MOD -> 7 3 TMOD }T
2736 T{ 7 -3 MOD -> 7 -3 TMOD }T
2737 T{ -7 3 MOD -> -7 3 TMOD }T
2738 T{ -7 -3 MOD -> -7 -3 TMOD }T
2739 T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T
2740 T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T
2741 T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T
2742 T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T
2743
2744 T{ 0 2 1 */ -> 0 2 1 T*/ }T
2745 T{ 1 2 1 */ -> 1 2 1 T*/ }T
2746 T{ 2 2 1 */ -> 2 2 1 T*/ }T
2747 T{ -1 2 1 */ -> -1 2 1 T*/ }T
2748 T{ -2 2 1 */ -> -2 2 1 T*/ }T
2749 T{ 0 2 -1 */ -> 0 2 -1 T*/ }T
2750 T{ 1 2 -1 */ -> 1 2 -1 T*/ }T
2751 T{ 2 2 -1 */ -> 2 2 -1 T*/ }T
2752 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
2753 T{ -2 2 -1 */ -> -2 2 -1 T*/ }T
2754 T{ 2 2 2 */ -> 2 2 2 T*/ }T
2755 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
2756 T{ -2 2 -2 */ -> -2 2 -2 T*/ }T
2757 T{ 7 2 3 */ -> 7 2 3 T*/ }T
2758 T{ 7 2 -3 */ -> 7 2 -3 T*/ }T
2759 T{ -7 2 3 */ -> -7 2 3 T*/ }T
2760 T{ -7 2 -3 */ -> -7 2 -3 T*/ }T
2761 T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T
2762 T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T
2763
2764 T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T
2765 T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T
2766 T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T
2767 T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T
2768 T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T
2769 T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T
2770 T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T
2771 T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T
2772 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
2773 T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T
2774 T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T
2775 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
2776 T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T
2777 T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T
2778 T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T
2779 T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T
2780 T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T
2781 T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T
2782 T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T
2783
2784 \ ------------------------------------------------------------------------
2785 TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
2786
2787 HERE 1 ALLOT
2788 HERE
2789 CONSTANT 2NDA
2790 CONSTANT 1STA
2791 T{ 1STA 2NDA U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
2792 T{ 1STA 1+ -> 2NDA }T           \ ... BY ONE ADDRESS UNIT
2793 ( MISSING TEST: NEGATIVE ALLOT )
2794
2795 HERE 1 ,
2796 HERE 2 ,
2797 CONSTANT 2ND
2798 CONSTANT 1ST
2799 T{ 1ST 2ND U< -> <TRUE> }T          \ HERE MUST GROW WITH ALLOT
2800 T{ 1ST CELL+ -> 2ND }T          \ ... BY ONE CELL
2801 T{ 1ST 1 CELLS + -> 2ND }T
2802 T{ 1ST @ 2ND @ -> 1 2 }T
2803 T{ 5 1ST ! -> }T
2804 T{ 1ST @ 2ND @ -> 5 2 }T
2805 T{ 6 2ND ! -> }T
2806 T{ 1ST @ 2ND @ -> 5 6 }T
2807 T{ 1ST 2@ -> 6 5 }T
2808 T{ 2 1 1ST 2! -> }T
2809 T{ 1ST 2@ -> 2 1 }T
2810 T{ 1S 1ST !  1ST @ -> 1S }T     \ CAN STORE CELL-WIDE VALUE
2811
2812 HERE 1 C,
2813 HERE 2 C,
2814 CONSTANT 2NDC
2815 CONSTANT 1STC
2816 T{ 1STC 2NDC U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
2817 T{ 1STC CHAR+ -> 2NDC }T            \ ... BY ONE CHAR
2818 T{ 1STC 1 CHARS + -> 2NDC }T
2819 T{ 1STC C@ 2NDC C@ -> 1 2 }T
2820 T{ 3 1STC C! -> }T
2821 T{ 1STC C@ 2NDC C@ -> 3 2 }T
2822 T{ 4 2NDC C! -> }T
2823 T{ 1STC C@ 2NDC C@ -> 3 4 }T
2824
2825 ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
2826 CONSTANT A-ADDR  CONSTANT UA-ADDR
2827 T{ UA-ADDR ALIGNED -> A-ADDR }T
2828 T{    1 A-ADDR C!  A-ADDR C@ ->    1 }T
2829 T{ 1234 A-ADDR  !  A-ADDR  @ -> 1234 }T
2830 T{ 123 456 A-ADDR 2!  A-ADDR 2@ -> 123 456 }T
2831 T{ 2 A-ADDR CHAR+ C!  A-ADDR CHAR+ C@ -> 2 }T
2832 T{ 3 A-ADDR CELL+ C!  A-ADDR CELL+ C@ -> 3 }T
2833 T{ 1234 A-ADDR CELL+ !  A-ADDR CELL+ @ -> 1234 }T
2834 T{ 123 456 A-ADDR CELL+ 2!  A-ADDR CELL+ 2@ -> 123 456 }T
2835
2836 : BITS ( X -- U )
2837     0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
2838 ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
2839 T{ 1 CHARS 1 < -> <FALSE> }T
2840 T{ 1 CHARS 1 CELLS > -> <FALSE> }T
2841 ( TBD: HOW TO FIND NUMBER OF BITS? )
2842
2843 ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
2844 T{ 1 CELLS 1 < -> <FALSE> }T
2845 T{ 1 CELLS 1 CHARS MOD -> 0 }T
2846 T{ 1S BITS 10 < -> <FALSE> }T
2847
2848 T{ 0 1ST ! -> }T
2849 T{ 1 1ST +! -> }T
2850 T{ 1ST @ -> 1 }T
2851 T{ -1 1ST +! 1ST @ -> 0 }T
2852
2853 \ ------------------------------------------------------------------------
2854 TESTING CHAR [CHAR] [ ] BL S"
2855
2856 T{ BL -> 20 }T
2857 T{ CHAR X -> 58 }T
2858 T{ CHAR HELLO -> 48 }T
2859 T{ : GC1 [CHAR] X ; -> }T
2860 T{ : GC2 [CHAR] HELLO ; -> }T
2861 T{ GC1 -> 58 }T
2862 T{ GC2 -> 48 }T
2863 T{ : GC3 [ GC1 ] LITERAL ; -> }T
2864 T{ GC3 -> 58 }T
2865 T{ : GC4 S" XY" ; -> }T
2866 T{ GC4 SWAP DROP -> 2 }T
2867 T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T
2868
2869 \ ------------------------------------------------------------------------
2870 TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
2871
2872 T{ : GT1 123 ; -> }T
2873 T{ ' GT1 EXECUTE -> 123 }T
2874 T{ : GT2 ['] GT1 ; IMMEDIATE -> }T
2875 T{ GT2 EXECUTE -> 123 }T
2876 HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
2877 HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
2878 T{ GT1STRING FIND -> ' GT1 -1 }T
2879 T{ GT2STRING FIND -> ' GT2 1 }T
2880 ( HOW TO SEARCH FOR NON-EXISTENT WORD? )
2881 T{ : GT3 GT2 LITERAL ; -> }T
2882 T{ GT3 -> ' GT1 }T
2883 T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T
2884
2885 T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T
2886 T{ : GT5 GT4 ; -> }T
2887 T{ GT5 -> 123 }T
2888 T{ : GT6 345 ; IMMEDIATE -> }T
2889 T{ : GT7 POSTPONE GT6 ; -> }T
2890 T{ GT7 -> 345 }T
2891
2892 T{ : GT8 STATE @ ; IMMEDIATE -> }T
2893 T{ GT8 -> 0 }T
2894 T{ : GT9 GT8 LITERAL ; -> }T
2895 T{ GT9 0= -> <FALSE> }T
2896
2897 \ ------------------------------------------------------------------------
2898 TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
2899
2900 T{ : GI1 IF 123 THEN ; -> }T
2901 T{ : GI2 IF 123 ELSE 234 THEN ; -> }T
2902 T{ 0 GI1 -> }T
2903 T{ 1 GI1 -> 123 }T
2904 T{ -1 GI1 -> 123 }T
2905 T{ 0 GI2 -> 234 }T
2906 T{ 1 GI2 -> 123 }T
2907 T{ -1 GI1 -> 123 }T
2908
2909 T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T
2910 T{ 0 GI3 -> 0 1 2 3 4 5 }T
2911 T{ 4 GI3 -> 4 5 }T
2912 T{ 5 GI3 -> 5 }T
2913 T{ 6 GI3 -> 6 }T
2914
2915 T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T
2916 T{ 3 GI4 -> 3 4 5 6 }T
2917 T{ 5 GI4 -> 5 6 }T
2918 T{ 6 GI4 -> 6 7 }T
2919
2920 T{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T
2921 T{ 1 GI5 -> 1 345 }T
2922 T{ 2 GI5 -> 2 345 }T
2923 T{ 3 GI5 -> 3 4 5 123 }T
2924 T{ 4 GI5 -> 4 5 123 }T
2925 T{ 5 GI5 -> 5 123 }T
2926
2927 T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T
2928 T{ 0 GI6 -> 0 }T
2929 T{ 1 GI6 -> 0 1 }T
2930 T{ 2 GI6 -> 0 1 2 }T
2931 T{ 3 GI6 -> 0 1 2 3 }T
2932 T{ 4 GI6 -> 0 1 2 3 4 }T
2933
2934 \ ------------------------------------------------------------------------
2935 TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
2936
2937 T{ : GD1 DO I LOOP ; -> }T
2938 T{ 4 1 GD1 -> 1 2 3 }T
2939 T{ 2 -1 GD1 -> -1 0 1 }T
2940 T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T
2941
2942 T{ : GD2 DO I -1 +LOOP ; -> }T
2943 T{ 1 4 GD2 -> 4 3 2 1 }T
2944 T{ -1 2 GD2 -> 2 1 0 -1 }T
2945 T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T
2946
2947 T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T
2948 T{ 4 1 GD3 -> 1 2 3 }T
2949 T{ 2 -1 GD3 -> -1 0 1 }T
2950 T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T
2951
2952 T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T
2953 T{ 1 4 GD4 -> 4 3 2 1 }T
2954 T{ -1 2 GD4 -> 2 1 0 -1 }T
2955 T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T
2956
2957 T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T
2958 T{ 1 GD5 -> 123 }T
2959 T{ 5 GD5 -> 123 }T
2960 T{ 6 GD5 -> 234 }T
2961
2962 T{ : GD6  ( PAT: T{0 0}T,T{0 0}TT{1 0}TT{1 1}T,T{0 0}TT{1 0}TT{1 1}TT{2 0}TT{2 1}TT{2 2}T )
2963     0 SWAP 0 DO
2964         I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
2965     LOOP ; -> }T
2966 T{ 1 GD6 -> 1 }T
2967 T{ 2 GD6 -> 3 }T
2968 T{ 3 GD6 -> 4 1 2 }T
2969
2970 \ ------------------------------------------------------------------------
2971 TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
2972
2973 T{ 123 CONSTANT X123 -> }T
2974 T{ X123 -> 123 }T
2975 T{ : EQU CONSTANT ; -> }T
2976 T{ X123 EQU Y123 -> }T
2977 T{ Y123 -> 123 }T
2978
2979 T{ VARIABLE V1 -> }T
2980 T{ 123 V1 ! -> }T
2981 T{ V1 @ -> 123 }T
2982
2983 T{ : NOP : POSTPONE ; ; -> }T
2984 T{ NOP NOP1 NOP NOP2 -> }T
2985 T{ NOP1 -> }T
2986 T{ NOP2 -> }T
2987
2988 T{ : DOES1 DOES> @ 1 + ; -> }T
2989 T{ : DOES2 DOES> @ 2 + ; -> }T
2990 T{ CREATE CR1 -> }T
2991 T{ CR1 -> HERE }T
2992 T{ ' CR1 >BODY -> HERE }T
2993 T{ 1 , -> }T
2994 T{ CR1 @ -> 1 }T
2995 T{ DOES1 -> }T
2996 T{ CR1 -> 2 }T
2997 T{ DOES2 -> }T
2998 T{ CR1 -> 3 }T
2999
3000 T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T
3001 T{ WEIRD: W1 -> }T
3002 T{ ' W1 >BODY -> HERE }T
3003 T{ W1 -> HERE 1 + }T
3004 T{ W1 -> HERE 2 + }T
3005
3006 \ ------------------------------------------------------------------------
3007 TESTING EVALUATE
3008
3009 : GE1 S" 123" ; IMMEDIATE
3010 : GE2 S" 123 1+" ; IMMEDIATE
3011 : GE3 S" : GE4 345 ;" ;
3012 : GE5 EVALUATE ; IMMEDIATE
3013
3014 T{ GE1 EVALUATE -> 123 }T           ( TEST EVALUATE IN INTERP. STATE )
3015 T{ GE2 EVALUATE -> 124 }T
3016 T{ GE3 EVALUATE -> }T
3017 T{ GE4 -> 345 }T
3018
3019 T{ : GE6 GE1 GE5 ; -> }T            ( TEST EVALUATE IN COMPILE STATE )
3020 T{ GE6 -> 123 }T
3021 T{ : GE7 GE2 GE5 ; -> }T
3022 T{ GE7 -> 124 }T
3023
3024 \ ------------------------------------------------------------------------
3025 TESTING SOURCE >IN WORD
3026
3027 : GS1 S" SOURCE" 2DUP EVALUATE
3028         >R SWAP >R = R> R> = ;
3029 T{ GS1 -> <TRUE> <TRUE> }T
3030
3031 VARIABLE SCANS
3032 : RESCAN?  -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
3033
3034 T{ 2 SCANS !
3035 345 RESCAN?
3036 -> 345 345 }T
3037
3038 : GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
3039 T{ GS2 -> 123 123 123 123 123 }T
3040
3041 : GS3 WORD COUNT SWAP C@ ;
3042 T{ BL GS3 HELLO -> 5 CHAR H }T
3043 T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T
3044 T{ BL GS3
3045 DROP -> 0 }T                \ BLANK LINE RETURN ZERO-LENGTH STRING
3046
3047 : GS4 SOURCE >IN ! DROP ;
3048 T{ GS4 123 456
3049 -> }T
3050
3051 \ ------------------------------------------------------------------------
3052 TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
3053
3054 : S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
3055     >R SWAP R@ = IF          \ MAKE SURE STRINGS HAVE SAME LENGTH
3056         R> ?DUP IF            \ IF NON-EMPTY STRINGS
3057         0 DO
3058         OVER C@ OVER C@ - IF
3059             2DROP <FALSE> UNLOOP EXIT THEN
3060         SWAP CHAR+ SWAP CHAR+
3061             LOOP
3062         THEN
3063         2DROP <TRUE>          \ IF WE GET HERE, STRINGS MATCH
3064     ELSE
3065         R> DROP 2DROP <FALSE>     \ LENGTHS MISMATCH
3066     THEN ;
3067
3068 : GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
3069 T{ GP1 -> <TRUE> }T
3070
3071 : GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
3072 T{ GP2 -> <TRUE> }T
3073
3074 : GP3  <# 1 0 # # #> S" 01" S= ;
3075 T{ GP3 -> <TRUE> }T
3076
3077 : GP4  <# 1 0 #S #> S" 1" S= ;
3078 T{ GP4 -> <TRUE> }T
3079
3080 24 CONSTANT MAX-BASE            \ BASE 2 .. 36
3081 : COUNT-BITS
3082     0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
3083 COUNT-BITS 2* CONSTANT #BITS-UD     \ NUMBER OF BITS IN UD
3084
3085 : GP5
3086     BASE @ <TRUE>
3087     MAX-BASE 1+ 2 DO         \ FOR EACH POSSIBLE BASE
3088         I BASE !              \ TBD: ASSUMES BASE WORKS
3089         I 0 <# #S #> S" 10" S= AND
3090     LOOP
3091     SWAP BASE ! ;
3092 T{ GP5 -> <TRUE> }T
3093
3094 : GP6
3095     BASE @ >R  2 BASE !
3096     MAX-UINT MAX-UINT <# #S #>       \ MAXIMUM UD TO BINARY
3097     R> BASE !                \ S: C-ADDR U
3098     DUP #BITS-UD = SWAP
3099     0 DO                 \ S: C-ADDR FLAG
3100         OVER C@ [CHAR] 1 = AND        \ ALL ONES
3101         >R CHAR+ R>
3102     LOOP SWAP DROP ;
3103 T{ GP6 -> <TRUE> }T
3104
3105 : GP7
3106     BASE @ >R    MAX-BASE BASE !
3107     <TRUE>
3108     A 0 DO
3109         I 0 <# #S #>
3110         1 = SWAP C@ I 30 + = AND AND
3111     LOOP
3112     MAX-BASE A DO
3113         I 0 <# #S #>
3114         1 = SWAP C@ 41 I A - + = AND AND
3115     LOOP
3116     R> BASE ! ;
3117
3118 T{ GP7 -> <TRUE> }T
3119
3120 \ >NUMBER TESTS
3121 CREATE GN-BUF 0 C,
3122 : GN-STRING GN-BUF 1 ;
3123 : GN-CONSUMED   GN-BUF CHAR+ 0 ;
3124 : GN'       [CHAR] ' WORD CHAR+ C@ GN-BUF C!  GN-STRING ;
3125
3126 T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T
3127 T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T
3128 T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T
3129 T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T   \ SHOULD FAIL TO CONVERT THESE
3130 T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T
3131 T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T
3132
3133 : >NUMBER-BASED
3134     BASE @ >R BASE ! >NUMBER R> BASE ! ;
3135
3136 T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T
3137 T{ 0 0 GN' 2'  2 >NUMBER-BASED -> 0 0 GN-STRING }T
3138 T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T
3139 T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T
3140 T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T
3141 T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T
3142
3143 : GN1   \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
3144     BASE @ >R BASE !
3145     <# #S #>
3146     0 0 2SWAP >NUMBER SWAP DROP      \ RETURN LENGTH ONLY
3147     R> BASE ! ;
3148 T{ 0 0 2 GN1 -> 0 0 0 }T
3149 T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
3150 T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
3151 T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T
3152 T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T
3153 T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T
3154
3155 : GN2   \ ( -- 16 10 )
3156     BASE @ >R  HEX BASE @  DECIMAL BASE @  R> BASE ! ;
3157 T{ GN2 -> 10 A }T
3158
3159 \ ------------------------------------------------------------------------
3160 TESTING FILL MOVE
3161
3162 CREATE FBUF 00 C, 00 C, 00 C,
3163 CREATE SBUF 12 C, 34 C, 56 C,
3164 : SEEBUF FBUF C@  FBUF CHAR+ C@  FBUF CHAR+ CHAR+ C@ ;
3165
3166 T{ FBUF 0 20 FILL -> }T
3167 T{ SEEBUF -> 00 00 00 }T
3168
3169 T{ FBUF 1 20 FILL -> }T
3170 T{ SEEBUF -> 20 00 00 }T
3171
3172 T{ FBUF 3 20 FILL -> }T
3173 T{ SEEBUF -> 20 20 20 }T
3174
3175 T{ FBUF FBUF 3 CHARS MOVE -> }T     \ BIZARRE SPECIAL CASE
3176 T{ SEEBUF -> 20 20 20 }T
3177
3178 T{ SBUF FBUF 0 CHARS MOVE -> }T
3179 T{ SEEBUF -> 20 20 20 }T
3180
3181 T{ SBUF FBUF 1 CHARS MOVE -> }T
3182 T{ SEEBUF -> 12 20 20 }T
3183
3184 T{ SBUF FBUF 3 CHARS MOVE -> }T
3185 T{ SEEBUF -> 12 34 56 }T
3186
3187 T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T
3188 T{ SEEBUF -> 12 12 34 }T
3189
3190 T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T
3191 T{ SEEBUF -> 12 34 34 }T
3192
3193 \ ------------------------------------------------------------------------
3194 TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
3195
3196 : OUTPUT-TEST
3197     ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
3198     41 BL DO I EMIT LOOP CR
3199     61 41 DO I EMIT LOOP CR
3200     7F 61 DO I EMIT LOOP CR
3201     ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
3202     9 1+ 0 DO I . LOOP CR
3203     ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
3204     [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
3205     ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
3206     [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
3207     ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
3208     5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
3209     ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
3210     S" LINE 1" TYPE CR S" LINE 2" TYPE CR
3211     ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
3212     ."   SIGNED: " MIN-INT . MAX-INT . CR
3213     ." UNSIGNED: " 0 U. MAX-UINT U. CR
3214 ;
3215
3216 T{ OUTPUT-TEST -> }T
3217 \ ------------------------------------------------------------------------
3218 TESTING INPUT: ACCEPT
3219
3220 CREATE ABUF 80 CHARS ALLOT
3221
3222 : ACCEPT-TEST
3223     CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
3224     ABUF 80 ACCEPT
3225     CR ." RECEIVED: " [CHAR] " EMIT
3226     ABUF SWAP TYPE [CHAR] " EMIT CR
3227 ;
3228
3229 T{ ACCEPT-TEST -> }T
3230 Vingt fois sur le métier remettez votre ouvrage, ...
3231 \ ------------------------------------------------------------------------
3232 TESTING DICTIONARY SEARCH RULES
3233
3234 T{ : GDX   123 ; : GDX   GDX 234 ; -> }T
3235
3236 T{ GDX -> 123 234 }T
3237
3238 CR .( End of Core word set tests) CR
3239
3240
3241
3242 RST_STATE   ; so ANS_COMPLEMENT_xx_MPY is conserved ;
3243 \ NOECHO      ; if an error occurs, comment this line before new download to find it.
3244
3245
3246 \ From: John Hayes S1I
3247 \ Subject: tester.fr
3248 \ Date: Mon, 27 Nov 95 13:10:09 PST
3249
3250 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
3251 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
3252 \ VERSION 1.1
3253
3254 \ 22/1/09 The words { and } have been changed to T{ and }T respectively to
3255 \ agree with the Forth 200X file ttester.fs. This avoids clashes with
3256 \ locals using { ... } and the FSL use of }
3257
3258
3259 \ 13/05/14 jmt. added colorised error messages.
3260
3261
3262
3263  0 CONSTANT FALSE
3264 -1 CONSTANT TRUE
3265
3266 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
3267 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
3268 VARIABLE VERBOSE
3269     FALSE VERBOSE !
3270 \   TRUE VERBOSE !
3271
3272 \ : EMPTY-STACK ( ... -- )  \ EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
3273 \     DEPTH ?DUP
3274 \             IF DUP 0< IF NEGATE 0
3275 \             DO 0 LOOP
3276 \             ELSE 0 DO DROP LOOP THEN
3277 \             THEN ;
3278 \
3279 \ : ERROR     \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
3280 \         \ THE LINE THAT HAD THE ERROR.
3281 \     TYPE SOURCE TYPE CR          \ DISPLAY LINE CORRESPONDING TO ERROR
3282 \     EMPTY-STACK              \ THROW AWAY EVERY THING ELSE
3283 \     QUIT  \ *** Uncomment this line to QUIT on an error
3284 \ ;
3285
3286 VARIABLE ACTUAL-DEPTH           \ STACK RECORD
3287 CREATE ACTUAL-RESULTS 20 CELLS ALLOT
3288
3289 : T{        \ ( -- ) SYNTACTIC SUGAR.
3290     ;
3291
3292 : ->        \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
3293     DEPTH DUP ACTUAL-DEPTH !     \ RECORD DEPTH
3294     ?DUP IF              \ IF THERE IS SOMETHING ON STACK
3295         0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
3296     THEN ;
3297
3298 : }T        \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
3299             \ (ACTUAL) CONTENTS.
3300     DEPTH ACTUAL-DEPTH @ = IF   \ IF DEPTHS MATCH
3301         DEPTH ?DUP IF           \ IF THERE IS SOMETHING ON THE STACK
3302         0 DO                    \ FOR EACH STACK ITEM
3303             ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
3304 \           = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN   \ jmt
3305             = 0= IF ABORT" INCORRECT RESULT: " THEN           \ jmt : colorised message
3306         LOOP
3307         THEN
3308     ELSE                 \ DEPTH MISMATCH
3309 \       S" WRONG NUMBER OF RESULTS: " ERROR \ jmt
3310         ABORT" WRONG NUMBER OF RESULTS: "   \ jmt : colorised message
3311     THEN ;
3312
3313 : TESTING   \ ( -- ) TALKING COMMENT.
3314     SOURCE VERBOSE @
3315     IF DUP >R TYPE CR R> >IN !
3316     ELSE >IN ! DROP [CHAR] * EMIT
3317     THEN ;
3318
3319 \ From: John Hayes S1I
3320 \ Subject: core.fr
3321 \ Date: Mon, 27 Nov 95 13:10
3322
3323 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
3324 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
3325 \ VERSION 1.2
3326 \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
3327 \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
3328 \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
3329 \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
3330 \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
3331 \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
3332
3333 CR
3334 TESTING CORE WORDS
3335 HEX
3336
3337 \ ------------------------------------------------------------------------
3338 TESTING BASIC ASSUMPTIONS
3339
3340 T{ -> }T                    \ START WITH CLEAN SLATE
3341 ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
3342 T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T
3343 T{  0 BITSSET? -> 0 }T      ( ZERO IS ALL BITS CLEAR )
3344 T{  1 BITSSET? -> 0 0 }T        ( OTHER NUMBER HAVE AT LEAST ONE BIT )
3345 T{ -1 BITSSET? -> 0 0 }T
3346
3347 \ ------------------------------------------------------------------------
3348 TESTING BOOLEANS: INVERT AND OR XOR
3349
3350 T{ 0 0 AND -> 0 }T
3351 T{ 0 1 AND -> 0 }T
3352 T{ 1 0 AND -> 0 }T
3353 T{ 1 1 AND -> 1 }T
3354
3355 T{ 0 INVERT 1 AND -> 1 }T
3356 T{ 1 INVERT 1 AND -> 0 }T
3357
3358 0    CONSTANT 0S
3359 0 INVERT CONSTANT 1S
3360
3361 T{ 0S INVERT -> 1S }T
3362 T{ 1S INVERT -> 0S }T
3363
3364 T{ 0S 0S AND -> 0S }T
3365 T{ 0S 1S AND -> 0S }T
3366 T{ 1S 0S AND -> 0S }T
3367 T{ 1S 1S AND -> 1S }T
3368
3369 T{ 0S 0S OR -> 0S }T
3370 T{ 0S 1S OR -> 1S }T
3371 T{ 1S 0S OR -> 1S }T
3372 T{ 1S 1S OR -> 1S }T
3373
3374 T{ 0S 0S XOR -> 0S }T
3375 T{ 0S 1S XOR -> 1S }T
3376 T{ 1S 0S XOR -> 1S }T
3377 T{ 1S 1S XOR -> 0S }T
3378
3379 \ ------------------------------------------------------------------------
3380 TESTING 2* 2/ LSHIFT RSHIFT
3381
3382 ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
3383 1S 1 RSHIFT INVERT CONSTANT MSB
3384 T{ MSB BITSSET? -> 0 0 }T
3385
3386 T{ 0S 2* -> 0S }T
3387 T{ 1 2* -> 2 }T
3388 T{ 4000 2* -> 8000 }T
3389 T{ 1S 2* 1 XOR -> 1S }T
3390 T{ MSB 2* -> 0S }T
3391
3392 T{ 0S 2/ -> 0S }T
3393 T{ 1 2/ -> 0 }T
3394 T{ 4000 2/ -> 2000 }T
3395 T{ 1S 2/ -> 1S }T               \ MSB PROPOGATED
3396 T{ 1S 1 XOR 2/ -> 1S }T
3397 T{ MSB 2/ MSB AND -> MSB }T
3398
3399 T{ 1 0 LSHIFT -> 1 }T
3400 T{ 1 1 LSHIFT -> 2 }T
3401 T{ 1 2 LSHIFT -> 4 }T
3402 T{ 1 F LSHIFT -> 8000 }T            \ BIGGEST GUARANTEED SHIFT
3403 T{ 1S 1 LSHIFT 1 XOR -> 1S }T
3404 T{ MSB 1 LSHIFT -> 0 }T
3405
3406 T{ 1 0 RSHIFT -> 1 }T
3407 T{ 1 1 RSHIFT -> 0 }T
3408 T{ 2 1 RSHIFT -> 1 }T
3409 T{ 4 2 RSHIFT -> 1 }T
3410 T{ 8000 F RSHIFT -> 1 }T            \ BIGGEST
3411 T{ MSB 1 RSHIFT MSB AND -> 0 }T     \ RSHIFT ZERO FILLS MSBS
3412 T{ MSB 1 RSHIFT 2* -> MSB }T
3413
3414 \ ------------------------------------------------------------------------
3415 TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
3416 0 INVERT            CONSTANT MAX-UINT
3417 0 INVERT 1 RSHIFT       CONSTANT MAX-INT
3418 0 INVERT 1 RSHIFT INVERT    CONSTANT MIN-INT
3419 0 INVERT 1 RSHIFT       CONSTANT MID-UINT
3420 0 INVERT 1 RSHIFT INVERT    CONSTANT MID-UINT+1
3421
3422 0S CONSTANT <FALSE>
3423 1S CONSTANT <TRUE>
3424
3425 T{ 0 0= -> <TRUE> }T
3426 T{ 1 0= -> <FALSE> }T
3427 T{ 2 0= -> <FALSE> }T
3428 T{ -1 0= -> <FALSE> }T
3429 T{ MAX-UINT 0= -> <FALSE> }T
3430 T{ MIN-INT 0= -> <FALSE> }T
3431 T{ MAX-INT 0= -> <FALSE> }T
3432
3433 T{ 0 0 = -> <TRUE> }T
3434 T{ 1 1 = -> <TRUE> }T
3435 T{ -1 -1 = -> <TRUE> }T
3436 T{ 1 0 = -> <FALSE> }T
3437 T{ -1 0 = -> <FALSE> }T
3438 T{ 0 1 = -> <FALSE> }T
3439 T{ 0 -1 = -> <FALSE> }T
3440
3441 T{ 0 0< -> <FALSE> }T
3442 T{ -1 0< -> <TRUE> }T
3443 T{ MIN-INT 0< -> <TRUE> }T
3444 T{ 1 0< -> <FALSE> }T
3445 T{ MAX-INT 0< -> <FALSE> }T
3446
3447 T{ 0 1 < -> <TRUE> }T
3448 T{ 1 2 < -> <TRUE> }T
3449 T{ -1 0 < -> <TRUE> }T
3450 T{ -1 1 < -> <TRUE> }T
3451 T{ MIN-INT 0 < -> <TRUE> }T
3452 T{ MIN-INT MAX-INT < -> <TRUE> }T
3453 T{ 0 MAX-INT < -> <TRUE> }T
3454 T{ 0 0 < -> <FALSE> }T
3455 T{ 1 1 < -> <FALSE> }T
3456 T{ 1 0 < -> <FALSE> }T
3457 T{ 2 1 < -> <FALSE> }T
3458 T{ 0 -1 < -> <FALSE> }T
3459 T{ 1 -1 < -> <FALSE> }T
3460 T{ 0 MIN-INT < -> <FALSE> }T
3461 T{ MAX-INT MIN-INT < -> <FALSE> }T
3462 T{ MAX-INT 0 < -> <FALSE> }T
3463
3464 T{ 0 1 > -> <FALSE> }T
3465 T{ 1 2 > -> <FALSE> }T
3466 T{ -1 0 > -> <FALSE> }T
3467 T{ -1 1 > -> <FALSE> }T
3468 T{ MIN-INT 0 > -> <FALSE> }T
3469 T{ MIN-INT MAX-INT > -> <FALSE> }T
3470 T{ 0 MAX-INT > -> <FALSE> }T
3471 T{ 0 0 > -> <FALSE> }T
3472 T{ 1 1 > -> <FALSE> }T
3473 T{ 1 0 > -> <TRUE> }T
3474 T{ 2 1 > -> <TRUE> }T
3475 T{ 0 -1 > -> <TRUE> }T
3476 T{ 1 -1 > -> <TRUE> }T
3477 T{ 0 MIN-INT > -> <TRUE> }T
3478 T{ MAX-INT MIN-INT > -> <TRUE> }T
3479 T{ MAX-INT 0 > -> <TRUE> }T
3480
3481 T{ 0 1 U< -> <TRUE> }T
3482 T{ 1 2 U< -> <TRUE> }T
3483 T{ 0 MID-UINT U< -> <TRUE> }T
3484 T{ 0 MAX-UINT U< -> <TRUE> }T
3485 T{ MID-UINT MAX-UINT U< -> <TRUE> }T
3486 T{ 0 0 U< -> <FALSE> }T
3487 T{ 1 1 U< -> <FALSE> }T
3488 T{ 1 0 U< -> <FALSE> }T
3489 T{ 2 1 U< -> <FALSE> }T
3490 T{ MID-UINT 0 U< -> <FALSE> }T
3491 T{ MAX-UINT 0 U< -> <FALSE> }T
3492 T{ MAX-UINT MID-UINT U< -> <FALSE> }T
3493
3494 T{ 0 1 MIN -> 0 }T
3495 T{ 1 2 MIN -> 1 }T
3496 T{ -1 0 MIN -> -1 }T
3497 T{ -1 1 MIN -> -1 }T
3498 T{ MIN-INT 0 MIN -> MIN-INT }T
3499 T{ MIN-INT MAX-INT MIN -> MIN-INT }T
3500 T{ 0 MAX-INT MIN -> 0 }T
3501 T{ 0 0 MIN -> 0 }T
3502 T{ 1 1 MIN -> 1 }T
3503 T{ 1 0 MIN -> 0 }T
3504 T{ 2 1 MIN -> 1 }T
3505 T{ 0 -1 MIN -> -1 }T
3506 T{ 1 -1 MIN -> -1 }T
3507 T{ 0 MIN-INT MIN -> MIN-INT }T
3508 T{ MAX-INT MIN-INT MIN -> MIN-INT }T
3509 T{ MAX-INT 0 MIN -> 0 }T
3510
3511 T{ 0 1 MAX -> 1 }T
3512 T{ 1 2 MAX -> 2 }T
3513 T{ -1 0 MAX -> 0 }T
3514 T{ -1 1 MAX -> 1 }T
3515 T{ MIN-INT 0 MAX -> 0 }T
3516 T{ MIN-INT MAX-INT MAX -> MAX-INT }T
3517 T{ 0 MAX-INT MAX -> MAX-INT }T
3518 T{ 0 0 MAX -> 0 }T
3519 T{ 1 1 MAX -> 1 }T
3520 T{ 1 0 MAX -> 1 }T
3521 T{ 2 1 MAX -> 2 }T
3522 T{ 0 -1 MAX -> 0 }T
3523 T{ 1 -1 MAX -> 1 }T
3524 T{ 0 MIN-INT MAX -> 0 }T
3525 T{ MAX-INT MIN-INT MAX -> MAX-INT }T
3526 T{ MAX-INT 0 MAX -> MAX-INT }T
3527
3528 \ ------------------------------------------------------------------------
3529 TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
3530
3531 T{ 1 2 2DROP -> }T
3532 T{ 1 2 2DUP -> 1 2 1 2 }T
3533 T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T
3534 T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T
3535 T{ 0 ?DUP -> 0 }T
3536 T{ 1 ?DUP -> 1 1 }T
3537 T{ -1 ?DUP -> -1 -1 }T
3538 T{ DEPTH -> 0 }T
3539 T{ 0 DEPTH -> 0 1 }T
3540 T{ 0 1 DEPTH -> 0 1 2 }T
3541 T{ 0 DROP -> }T
3542 T{ 1 2 DROP -> 1 }T
3543 T{ 1 DUP -> 1 1 }T
3544 T{ 1 2 OVER -> 1 2 1 }T
3545 T{ 1 2 3 ROT -> 2 3 1 }T
3546 T{ 1 2 SWAP -> 2 1 }T
3547
3548 \ ------------------------------------------------------------------------
3549 TESTING >R R> R@
3550
3551 T{ : GR1 >R R> ; -> }T
3552 T{ : GR2 >R R@ R> DROP ; -> }T
3553 T{ 123 GR1 -> 123 }T
3554 T{ 123 GR2 -> 123 }T
3555 T{ 1S GR1 -> 1S }T   ( RETURN STACK HOLDS CELLS )
3556
3557 \ ------------------------------------------------------------------------
3558 TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
3559
3560 T{ 0 5 + -> 5 }T
3561 T{ 5 0 + -> 5 }T
3562 T{ 0 -5 + -> -5 }T
3563 T{ -5 0 + -> -5 }T
3564 T{ 1 2 + -> 3 }T
3565 T{ 1 -2 + -> -1 }T
3566 T{ -1 2 + -> 1 }T
3567 T{ -1 -2 + -> -3 }T
3568 T{ -1 1 + -> 0 }T
3569 T{ MID-UINT 1 + -> MID-UINT+1 }T
3570
3571 T{ 0 5 - -> -5 }T
3572 T{ 5 0 - -> 5 }T
3573 T{ 0 -5 - -> 5 }T
3574 T{ -5 0 - -> -5 }T
3575 T{ 1 2 - -> -1 }T
3576 T{ 1 -2 - -> 3 }T
3577 T{ -1 2 - -> -3 }T
3578 T{ -1 -2 - -> 1 }T
3579 T{ 0 1 - -> -1 }T
3580 T{ MID-UINT+1 1 - -> MID-UINT }T
3581
3582 T{ 0 1+ -> 1 }T
3583 T{ -1 1+ -> 0 }T
3584 T{ 1 1+ -> 2 }T
3585 T{ MID-UINT 1+ -> MID-UINT+1 }T
3586
3587 T{ 2 1- -> 1 }T
3588 T{ 1 1- -> 0 }T
3589 T{ 0 1- -> -1 }T
3590 T{ MID-UINT+1 1- -> MID-UINT }T
3591
3592 T{ 0 NEGATE -> 0 }T
3593 T{ 1 NEGATE -> -1 }T
3594 T{ -1 NEGATE -> 1 }T
3595 T{ 2 NEGATE -> -2 }T
3596 T{ -2 NEGATE -> 2 }T
3597
3598 T{ 0 ABS -> 0 }T
3599 T{ 1 ABS -> 1 }T
3600 T{ -1 ABS -> 1 }T
3601 T{ MIN-INT ABS -> MID-UINT+1 }T
3602
3603 \ ------------------------------------------------------------------------
3604 TESTING MULTIPLY: S>D * M* UM*
3605
3606 T{ 0 S>D -> 0 0 }T
3607 T{ 1 S>D -> 1 0 }T
3608 T{ 2 S>D -> 2 0 }T
3609 T{ -1 S>D -> -1 -1 }T
3610 T{ -2 S>D -> -2 -1 }T
3611 T{ MIN-INT S>D -> MIN-INT -1 }T
3612 T{ MAX-INT S>D -> MAX-INT 0 }T
3613
3614 T{ 0 0 M* -> 0 S>D }T
3615 T{ 0 1 M* -> 0 S>D }T
3616 T{ 1 0 M* -> 0 S>D }T
3617 T{ 1 2 M* -> 2 S>D }T
3618 T{ 2 1 M* -> 2 S>D }T
3619 T{ 3 3 M* -> 9 S>D }T
3620 T{ -3 3 M* -> -9 S>D }T
3621 T{ 3 -3 M* -> -9 S>D }T
3622 T{ -3 -3 M* -> 9 S>D }T
3623 T{ 0 MIN-INT M* -> 0 S>D }T
3624 T{ 1 MIN-INT M* -> MIN-INT S>D }T
3625 T{ 2 MIN-INT M* -> 0 1S }T
3626 T{ 0 MAX-INT M* -> 0 S>D }T
3627 T{ 1 MAX-INT M* -> MAX-INT S>D }T
3628 T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T
3629 T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T
3630 T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T
3631 T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T
3632
3633 T{ 0 0 * -> 0 }T                \ TEST IDENTITIES
3634 T{ 0 1 * -> 0 }T
3635 T{ 1 0 * -> 0 }T
3636 T{ 1 2 * -> 2 }T
3637 T{ 2 1 * -> 2 }T
3638 T{ 3 3 * -> 9 }T
3639 T{ -3 3 * -> -9 }T
3640 T{ 3 -3 * -> -9 }T
3641 T{ -3 -3 * -> 9 }T
3642
3643 T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T
3644 T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T
3645 T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T
3646
3647 T{ 0 0 UM* -> 0 0 }T
3648 T{ 0 1 UM* -> 0 0 }T
3649 T{ 1 0 UM* -> 0 0 }T
3650 T{ 1 2 UM* -> 2 0 }T
3651 T{ 2 1 UM* -> 2 0 }T
3652 T{ 3 3 UM* -> 9 0 }T
3653
3654 T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T
3655 T{ MID-UINT+1 2 UM* -> 0 1 }T
3656 T{ MID-UINT+1 4 UM* -> 0 2 }T
3657 T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T
3658 T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T
3659
3660 \ ------------------------------------------------------------------------
3661 TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
3662
3663 T{ 0 S>D 1 FM/MOD -> 0 0 }T
3664 T{ 1 S>D 1 FM/MOD -> 0 1 }T
3665 T{ 2 S>D 1 FM/MOD -> 0 2 }T
3666 T{ -1 S>D 1 FM/MOD -> 0 -1 }T
3667 T{ -2 S>D 1 FM/MOD -> 0 -2 }T
3668 T{ 0 S>D -1 FM/MOD -> 0 0 }T
3669 T{ 1 S>D -1 FM/MOD -> 0 -1 }T
3670 T{ 2 S>D -1 FM/MOD -> 0 -2 }T
3671 T{ -1 S>D -1 FM/MOD -> 0 1 }T
3672 T{ -2 S>D -1 FM/MOD -> 0 2 }T
3673 T{ 2 S>D 2 FM/MOD -> 0 1 }T
3674 T{ -1 S>D -1 FM/MOD -> 0 1 }T
3675 T{ -2 S>D -2 FM/MOD -> 0 1 }T
3676 T{  7 S>D  3 FM/MOD -> 1 2 }T
3677 T{  7 S>D -3 FM/MOD -> -2 -3 }T
3678 T{ -7 S>D  3 FM/MOD -> 2 -3 }T
3679 T{ -7 S>D -3 FM/MOD -> -1 2 }T
3680 T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T
3681 T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T
3682 T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T
3683 T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T
3684 T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T
3685 T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T
3686 T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T
3687 T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T
3688 T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T
3689 T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T
3690 T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T
3691 T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T
3692 T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T
3693 T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T
3694 T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T
3695 T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T
3696 T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T
3697
3698 T{ 0 S>D 1 SM/REM -> 0 0 }T
3699 T{ 1 S>D 1 SM/REM -> 0 1 }T
3700 T{ 2 S>D 1 SM/REM -> 0 2 }T
3701 T{ -1 S>D 1 SM/REM -> 0 -1 }T
3702 T{ -2 S>D 1 SM/REM -> 0 -2 }T
3703 T{ 0 S>D -1 SM/REM -> 0 0 }T
3704 T{ 1 S>D -1 SM/REM -> 0 -1 }T
3705 T{ 2 S>D -1 SM/REM -> 0 -2 }T
3706 T{ -1 S>D -1 SM/REM -> 0 1 }T
3707 T{ -2 S>D -1 SM/REM -> 0 2 }T
3708 T{ 2 S>D 2 SM/REM -> 0 1 }T
3709 T{ -1 S>D -1 SM/REM -> 0 1 }T
3710 T{ -2 S>D -2 SM/REM -> 0 1 }T
3711 T{  7 S>D  3 SM/REM -> 1 2 }T
3712 T{  7 S>D -3 SM/REM -> 1 -2 }T
3713 T{ -7 S>D  3 SM/REM -> -1 -2 }T
3714 T{ -7 S>D -3 SM/REM -> -1 2 }T
3715 T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T
3716 T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T
3717 T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T
3718 T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T
3719 T{ 1S 1 4 SM/REM -> 3 MAX-INT }T
3720 T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T
3721 T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T
3722 T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T
3723 T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T
3724 T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T
3725 T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T
3726 T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T
3727 T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T
3728
3729 T{ 0 0 1 UM/MOD -> 0 0 }T
3730 T{ 1 0 1 UM/MOD -> 0 1 }T
3731 T{ 1 0 2 UM/MOD -> 1 0 }T
3732 T{ 3 0 2 UM/MOD -> 1 1 }T
3733 T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T
3734 T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T
3735 T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T
3736
3737 : IFFLOORED
3738     [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
3739
3740 : IFSYM
3741     [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
3742
3743 \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
3744 \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
3745
3746 IFFLOORED : T/MOD  >R S>D R> FM/MOD ;
3747 IFFLOORED : T/     T/MOD SWAP DROP ;
3748 IFFLOORED : TMOD   T/MOD DROP ;
3749 IFFLOORED : T*/MOD >R M* R> FM/MOD ;
3750 IFFLOORED : T*/    T*/MOD SWAP DROP ;
3751 IFSYM     : T/MOD  >R S>D R> SM/REM ;
3752 IFSYM     : T/     T/MOD SWAP DROP ;
3753 IFSYM     : TMOD   T/MOD DROP ;
3754 IFSYM     : T*/MOD >R M* R> SM/REM ;
3755 IFSYM     : T*/    T*/MOD SWAP DROP ;
3756
3757 T{ 0 1 /MOD -> 0 1 T/MOD }T
3758 T{ 1 1 /MOD -> 1 1 T/MOD }T
3759 T{ 2 1 /MOD -> 2 1 T/MOD }T
3760 T{ -1 1 /MOD -> -1 1 T/MOD }T
3761 T{ -2 1 /MOD -> -2 1 T/MOD }T
3762 T{ 0 -1 /MOD -> 0 -1 T/MOD }T
3763 T{ 1 -1 /MOD -> 1 -1 T/MOD }T
3764 T{ 2 -1 /MOD -> 2 -1 T/MOD }T
3765 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
3766 T{ -2 -1 /MOD -> -2 -1 T/MOD }T
3767 T{ 2 2 /MOD -> 2 2 T/MOD }T
3768 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
3769 T{ -2 -2 /MOD -> -2 -2 T/MOD }T
3770 T{ 7 3 /MOD -> 7 3 T/MOD }T
3771 T{ 7 -3 /MOD -> 7 -3 T/MOD }T
3772 T{ -7 3 /MOD -> -7 3 T/MOD }T
3773 T{ -7 -3 /MOD -> -7 -3 T/MOD }T
3774 T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T
3775 T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T
3776 T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T
3777 T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T
3778
3779 T{ 0 1 / -> 0 1 T/ }T
3780 T{ 1 1 / -> 1 1 T/ }T
3781 T{ 2 1 / -> 2 1 T/ }T
3782 T{ -1 1 / -> -1 1 T/ }T
3783 T{ -2 1 / -> -2 1 T/ }T
3784 T{ 0 -1 / -> 0 -1 T/ }T
3785 T{ 1 -1 / -> 1 -1 T/ }T
3786 T{ 2 -1 / -> 2 -1 T/ }T
3787 T{ -1 -1 / -> -1 -1 T/ }T
3788 T{ -2 -1 / -> -2 -1 T/ }T
3789 T{ 2 2 / -> 2 2 T/ }T
3790 T{ -1 -1 / -> -1 -1 T/ }T
3791 T{ -2 -2 / -> -2 -2 T/ }T
3792 T{ 7 3 / -> 7 3 T/ }T
3793 T{ 7 -3 / -> 7 -3 T/ }T
3794 T{ -7 3 / -> -7 3 T/ }T
3795 T{ -7 -3 / -> -7 -3 T/ }T
3796 T{ MAX-INT 1 / -> MAX-INT 1 T/ }T
3797 T{ MIN-INT 1 / -> MIN-INT 1 T/ }T
3798 T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T
3799 T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T
3800
3801 T{ 0 1 MOD -> 0 1 TMOD }T
3802 T{ 1 1 MOD -> 1 1 TMOD }T
3803 T{ 2 1 MOD -> 2 1 TMOD }T
3804 T{ -1 1 MOD -> -1 1 TMOD }T
3805 T{ -2 1 MOD -> -2 1 TMOD }T
3806 T{ 0 -1 MOD -> 0 -1 TMOD }T
3807 T{ 1 -1 MOD -> 1 -1 TMOD }T
3808 T{ 2 -1 MOD -> 2 -1 TMOD }T
3809 T{ -1 -1 MOD -> -1 -1 TMOD }T
3810 T{ -2 -1 MOD -> -2 -1 TMOD }T
3811 T{ 2 2 MOD -> 2 2 TMOD }T
3812 T{ -1 -1 MOD -> -1 -1 TMOD }T
3813 T{ -2 -2 MOD -> -2 -2 TMOD }T
3814 T{ 7 3 MOD -> 7 3 TMOD }T
3815 T{ 7 -3 MOD -> 7 -3 TMOD }T
3816 T{ -7 3 MOD -> -7 3 TMOD }T
3817 T{ -7 -3 MOD -> -7 -3 TMOD }T
3818 T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T
3819 T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T
3820 T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T
3821 T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T
3822
3823 T{ 0 2 1 */ -> 0 2 1 T*/ }T
3824 T{ 1 2 1 */ -> 1 2 1 T*/ }T
3825 T{ 2 2 1 */ -> 2 2 1 T*/ }T
3826 T{ -1 2 1 */ -> -1 2 1 T*/ }T
3827 T{ -2 2 1 */ -> -2 2 1 T*/ }T
3828 T{ 0 2 -1 */ -> 0 2 -1 T*/ }T
3829 T{ 1 2 -1 */ -> 1 2 -1 T*/ }T
3830 T{ 2 2 -1 */ -> 2 2 -1 T*/ }T
3831 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
3832 T{ -2 2 -1 */ -> -2 2 -1 T*/ }T
3833 T{ 2 2 2 */ -> 2 2 2 T*/ }T
3834 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
3835 T{ -2 2 -2 */ -> -2 2 -2 T*/ }T
3836 T{ 7 2 3 */ -> 7 2 3 T*/ }T
3837 T{ 7 2 -3 */ -> 7 2 -3 T*/ }T
3838 T{ -7 2 3 */ -> -7 2 3 T*/ }T
3839 T{ -7 2 -3 */ -> -7 2 -3 T*/ }T
3840 T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T
3841 T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T
3842
3843 T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T
3844 T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T
3845 T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T
3846 T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T
3847 T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T
3848 T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T
3849 T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T
3850 T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T
3851 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
3852 T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T
3853 T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T
3854 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
3855 T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T
3856 T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T
3857 T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T
3858 T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T
3859 T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T
3860 T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T
3861 T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T
3862
3863 \ ------------------------------------------------------------------------
3864 TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
3865
3866 HERE 1 ALLOT
3867 HERE
3868 CONSTANT 2NDA
3869 CONSTANT 1STA
3870 T{ 1STA 2NDA U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
3871 T{ 1STA 1+ -> 2NDA }T           \ ... BY ONE ADDRESS UNIT
3872 ( MISSING TEST: NEGATIVE ALLOT )
3873
3874 HERE 1 ,
3875 HERE 2 ,
3876 CONSTANT 2ND
3877 CONSTANT 1ST
3878 T{ 1ST 2ND U< -> <TRUE> }T          \ HERE MUST GROW WITH ALLOT
3879 T{ 1ST CELL+ -> 2ND }T          \ ... BY ONE CELL
3880 T{ 1ST 1 CELLS + -> 2ND }T
3881 T{ 1ST @ 2ND @ -> 1 2 }T
3882 T{ 5 1ST ! -> }T
3883 T{ 1ST @ 2ND @ -> 5 2 }T
3884 T{ 6 2ND ! -> }T
3885 T{ 1ST @ 2ND @ -> 5 6 }T
3886 T{ 1ST 2@ -> 6 5 }T
3887 T{ 2 1 1ST 2! -> }T
3888 T{ 1ST 2@ -> 2 1 }T
3889 T{ 1S 1ST !  1ST @ -> 1S }T     \ CAN STORE CELL-WIDE VALUE
3890
3891 HERE 1 C,
3892 HERE 2 C,
3893 CONSTANT 2NDC
3894 CONSTANT 1STC
3895 T{ 1STC 2NDC U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
3896 T{ 1STC CHAR+ -> 2NDC }T            \ ... BY ONE CHAR
3897 T{ 1STC 1 CHARS + -> 2NDC }T
3898 T{ 1STC C@ 2NDC C@ -> 1 2 }T
3899 T{ 3 1STC C! -> }T
3900 T{ 1STC C@ 2NDC C@ -> 3 2 }T
3901 T{ 4 2NDC C! -> }T
3902 T{ 1STC C@ 2NDC C@ -> 3 4 }T
3903
3904 ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
3905 CONSTANT A-ADDR  CONSTANT UA-ADDR
3906 T{ UA-ADDR ALIGNED -> A-ADDR }T
3907 T{    1 A-ADDR C!  A-ADDR C@ ->    1 }T
3908 T{ 1234 A-ADDR  !  A-ADDR  @ -> 1234 }T
3909 T{ 123 456 A-ADDR 2!  A-ADDR 2@ -> 123 456 }T
3910 T{ 2 A-ADDR CHAR+ C!  A-ADDR CHAR+ C@ -> 2 }T
3911 T{ 3 A-ADDR CELL+ C!  A-ADDR CELL+ C@ -> 3 }T
3912 T{ 1234 A-ADDR CELL+ !  A-ADDR CELL+ @ -> 1234 }T
3913 T{ 123 456 A-ADDR CELL+ 2!  A-ADDR CELL+ 2@ -> 123 456 }T
3914
3915 : BITS ( X -- U )
3916     0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
3917 ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
3918 T{ 1 CHARS 1 < -> <FALSE> }T
3919 T{ 1 CHARS 1 CELLS > -> <FALSE> }T
3920 ( TBD: HOW TO FIND NUMBER OF BITS? )
3921
3922 ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
3923 T{ 1 CELLS 1 < -> <FALSE> }T
3924 T{ 1 CELLS 1 CHARS MOD -> 0 }T
3925 T{ 1S BITS 10 < -> <FALSE> }T
3926
3927 T{ 0 1ST ! -> }T
3928 T{ 1 1ST +! -> }T
3929 T{ 1ST @ -> 1 }T
3930 T{ -1 1ST +! 1ST @ -> 0 }T
3931
3932 \ ------------------------------------------------------------------------
3933 TESTING CHAR [CHAR] [ ] BL S"
3934
3935 T{ BL -> 20 }T
3936 T{ CHAR X -> 58 }T
3937 T{ CHAR HELLO -> 48 }T
3938 T{ : GC1 [CHAR] X ; -> }T
3939 T{ : GC2 [CHAR] HELLO ; -> }T
3940 T{ GC1 -> 58 }T
3941 T{ GC2 -> 48 }T
3942 T{ : GC3 [ GC1 ] LITERAL ; -> }T
3943 T{ GC3 -> 58 }T
3944 T{ : GC4 S" XY" ; -> }T
3945 T{ GC4 SWAP DROP -> 2 }T
3946 T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T
3947
3948 \ ------------------------------------------------------------------------
3949 TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
3950
3951 T{ : GT1 123 ; -> }T
3952 T{ ' GT1 EXECUTE -> 123 }T
3953 T{ : GT2 ['] GT1 ; IMMEDIATE -> }T
3954 T{ GT2 EXECUTE -> 123 }T
3955 HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
3956 HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
3957 T{ GT1STRING FIND -> ' GT1 -1 }T
3958 T{ GT2STRING FIND -> ' GT2 1 }T
3959 ( HOW TO SEARCH FOR NON-EXISTENT WORD? )
3960 T{ : GT3 GT2 LITERAL ; -> }T
3961 T{ GT3 -> ' GT1 }T
3962 T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T
3963
3964 T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T
3965 T{ : GT5 GT4 ; -> }T
3966 T{ GT5 -> 123 }T
3967 T{ : GT6 345 ; IMMEDIATE -> }T
3968 T{ : GT7 POSTPONE GT6 ; -> }T
3969 T{ GT7 -> 345 }T
3970
3971 T{ : GT8 STATE @ ; IMMEDIATE -> }T
3972 T{ GT8 -> 0 }T
3973 T{ : GT9 GT8 LITERAL ; -> }T
3974 T{ GT9 0= -> <FALSE> }T
3975
3976 \ ------------------------------------------------------------------------
3977 TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
3978
3979 T{ : GI1 IF 123 THEN ; -> }T
3980 T{ : GI2 IF 123 ELSE 234 THEN ; -> }T
3981 T{ 0 GI1 -> }T
3982 T{ 1 GI1 -> 123 }T
3983 T{ -1 GI1 -> 123 }T
3984 T{ 0 GI2 -> 234 }T
3985 T{ 1 GI2 -> 123 }T
3986 T{ -1 GI1 -> 123 }T
3987
3988 T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T
3989 T{ 0 GI3 -> 0 1 2 3 4 5 }T
3990 T{ 4 GI3 -> 4 5 }T
3991 T{ 5 GI3 -> 5 }T
3992 T{ 6 GI3 -> 6 }T
3993
3994 T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T
3995 T{ 3 GI4 -> 3 4 5 6 }T
3996 T{ 5 GI4 -> 5 6 }T
3997 T{ 6 GI4 -> 6 7 }T
3998
3999 T{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T
4000 T{ 1 GI5 -> 1 345 }T
4001 T{ 2 GI5 -> 2 345 }T
4002 T{ 3 GI5 -> 3 4 5 123 }T
4003 T{ 4 GI5 -> 4 5 123 }T
4004 T{ 5 GI5 -> 5 123 }T
4005
4006 T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T
4007 T{ 0 GI6 -> 0 }T
4008 T{ 1 GI6 -> 0 1 }T
4009 T{ 2 GI6 -> 0 1 2 }T
4010 T{ 3 GI6 -> 0 1 2 3 }T
4011 T{ 4 GI6 -> 0 1 2 3 4 }T
4012
4013 \ ------------------------------------------------------------------------
4014 TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
4015
4016 T{ : GD1 DO I LOOP ; -> }T
4017 T{ 4 1 GD1 -> 1 2 3 }T
4018 T{ 2 -1 GD1 -> -1 0 1 }T
4019 T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T
4020
4021 T{ : GD2 DO I -1 +LOOP ; -> }T
4022 T{ 1 4 GD2 -> 4 3 2 1 }T
4023 T{ -1 2 GD2 -> 2 1 0 -1 }T
4024 T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T
4025
4026 T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T
4027 T{ 4 1 GD3 -> 1 2 3 }T
4028 T{ 2 -1 GD3 -> -1 0 1 }T
4029 T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T
4030
4031 T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T
4032 T{ 1 4 GD4 -> 4 3 2 1 }T
4033 T{ -1 2 GD4 -> 2 1 0 -1 }T
4034 T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T
4035
4036 T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T
4037 T{ 1 GD5 -> 123 }T
4038 T{ 5 GD5 -> 123 }T
4039 T{ 6 GD5 -> 234 }T
4040
4041 T{ : GD6  ( PAT: T{0 0}T,T{0 0}TT{1 0}TT{1 1}T,T{0 0}TT{1 0}TT{1 1}TT{2 0}TT{2 1}TT{2 2}T )
4042     0 SWAP 0 DO
4043         I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
4044     LOOP ; -> }T
4045 T{ 1 GD6 -> 1 }T
4046 T{ 2 GD6 -> 3 }T
4047 T{ 3 GD6 -> 4 1 2 }T
4048
4049 \ ------------------------------------------------------------------------
4050 TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
4051
4052 T{ 123 CONSTANT X123 -> }T
4053 T{ X123 -> 123 }T
4054 T{ : EQU CONSTANT ; -> }T
4055 T{ X123 EQU Y123 -> }T
4056 T{ Y123 -> 123 }T
4057
4058 T{ VARIABLE V1 -> }T
4059 T{ 123 V1 ! -> }T
4060 T{ V1 @ -> 123 }T
4061
4062 T{ : NOP : POSTPONE ; ; -> }T
4063 T{ NOP NOP1 NOP NOP2 -> }T
4064 T{ NOP1 -> }T
4065 T{ NOP2 -> }T
4066
4067 T{ : DOES1 DOES> @ 1 + ; -> }T
4068 T{ : DOES2 DOES> @ 2 + ; -> }T
4069 T{ CREATE CR1 -> }T
4070 T{ CR1 -> HERE }T
4071 T{ ' CR1 >BODY -> HERE }T
4072 T{ 1 , -> }T
4073 T{ CR1 @ -> 1 }T
4074 T{ DOES1 -> }T
4075 T{ CR1 -> 2 }T
4076 T{ DOES2 -> }T
4077 T{ CR1 -> 3 }T
4078
4079 T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T
4080 T{ WEIRD: W1 -> }T
4081 T{ ' W1 >BODY -> HERE }T
4082 T{ W1 -> HERE 1 + }T
4083 T{ W1 -> HERE 2 + }T
4084
4085 \ ------------------------------------------------------------------------
4086 TESTING EVALUATE
4087
4088 : GE1 S" 123" ; IMMEDIATE
4089 : GE2 S" 123 1+" ; IMMEDIATE
4090 : GE3 S" : GE4 345 ;" ;
4091 : GE5 EVALUATE ; IMMEDIATE
4092
4093 T{ GE1 EVALUATE -> 123 }T           ( TEST EVALUATE IN INTERP. STATE )
4094 T{ GE2 EVALUATE -> 124 }T
4095 T{ GE3 EVALUATE -> }T
4096 T{ GE4 -> 345 }T
4097
4098 T{ : GE6 GE1 GE5 ; -> }T            ( TEST EVALUATE IN COMPILE STATE )
4099 T{ GE6 -> 123 }T
4100 T{ : GE7 GE2 GE5 ; -> }T
4101 T{ GE7 -> 124 }T
4102
4103 \ ------------------------------------------------------------------------
4104 TESTING SOURCE >IN WORD
4105
4106 : GS1 S" SOURCE" 2DUP EVALUATE
4107         >R SWAP >R = R> R> = ;
4108 T{ GS1 -> <TRUE> <TRUE> }T
4109
4110 VARIABLE SCANS
4111 : RESCAN?  -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
4112
4113 T{ 2 SCANS !
4114 345 RESCAN?
4115 -> 345 345 }T
4116
4117 : GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
4118 T{ GS2 -> 123 123 123 123 123 }T
4119
4120 : GS3 WORD COUNT SWAP C@ ;
4121 T{ BL GS3 HELLO -> 5 CHAR H }T
4122 T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T
4123 T{ BL GS3
4124 DROP -> 0 }T                \ BLANK LINE RETURN ZERO-LENGTH STRING
4125
4126 : GS4 SOURCE >IN ! DROP ;
4127 T{ GS4 123 456
4128 -> }T
4129
4130 \ ------------------------------------------------------------------------
4131 TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
4132
4133 : S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
4134     >R SWAP R@ = IF          \ MAKE SURE STRINGS HAVE SAME LENGTH
4135         R> ?DUP IF            \ IF NON-EMPTY STRINGS
4136         0 DO
4137         OVER C@ OVER C@ - IF
4138             2DROP <FALSE> UNLOOP EXIT THEN
4139         SWAP CHAR+ SWAP CHAR+
4140             LOOP
4141         THEN
4142         2DROP <TRUE>          \ IF WE GET HERE, STRINGS MATCH
4143     ELSE
4144         R> DROP 2DROP <FALSE>     \ LENGTHS MISMATCH
4145     THEN ;
4146
4147 : GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
4148 T{ GP1 -> <TRUE> }T
4149
4150 : GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
4151 T{ GP2 -> <TRUE> }T
4152
4153 : GP3  <# 1 0 # # #> S" 01" S= ;
4154 T{ GP3 -> <TRUE> }T
4155
4156 : GP4  <# 1 0 #S #> S" 1" S= ;
4157 T{ GP4 -> <TRUE> }T
4158
4159 24 CONSTANT MAX-BASE            \ BASE 2 .. 36
4160 : COUNT-BITS
4161     0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
4162 COUNT-BITS 2* CONSTANT #BITS-UD     \ NUMBER OF BITS IN UD
4163
4164 : GP5
4165     BASE @ <TRUE>
4166     MAX-BASE 1+ 2 DO         \ FOR EACH POSSIBLE BASE
4167         I BASE !              \ TBD: ASSUMES BASE WORKS
4168         I 0 <# #S #> S" 10" S= AND
4169     LOOP
4170     SWAP BASE ! ;
4171 T{ GP5 -> <TRUE> }T
4172
4173 : GP6
4174     BASE @ >R  2 BASE !
4175     MAX-UINT MAX-UINT <# #S #>       \ MAXIMUM UD TO BINARY
4176     R> BASE !                \ S: C-ADDR U
4177     DUP #BITS-UD = SWAP
4178     0 DO                 \ S: C-ADDR FLAG
4179         OVER C@ [CHAR] 1 = AND        \ ALL ONES
4180         >R CHAR+ R>
4181     LOOP SWAP DROP ;
4182 T{ GP6 -> <TRUE> }T
4183
4184 : GP7
4185     BASE @ >R    MAX-BASE BASE !
4186     <TRUE>
4187     A 0 DO
4188         I 0 <# #S #>
4189         1 = SWAP C@ I 30 + = AND AND
4190     LOOP
4191     MAX-BASE A DO
4192         I 0 <# #S #>
4193         1 = SWAP C@ 41 I A - + = AND AND
4194     LOOP
4195     R> BASE ! ;
4196
4197 T{ GP7 -> <TRUE> }T
4198
4199 \ >NUMBER TESTS
4200 CREATE GN-BUF 0 C,
4201 : GN-STRING GN-BUF 1 ;
4202 : GN-CONSUMED   GN-BUF CHAR+ 0 ;
4203 : GN'       [CHAR] ' WORD CHAR+ C@ GN-BUF C!  GN-STRING ;
4204
4205 T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T
4206 T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T
4207 T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T
4208 T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T   \ SHOULD FAIL TO CONVERT THESE
4209 T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T
4210 T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T
4211
4212 : >NUMBER-BASED
4213     BASE @ >R BASE ! >NUMBER R> BASE ! ;
4214
4215 T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T
4216 T{ 0 0 GN' 2'  2 >NUMBER-BASED -> 0 0 GN-STRING }T
4217 T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T
4218 T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T
4219 T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T
4220 T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T
4221
4222 : GN1   \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
4223     BASE @ >R BASE !
4224     <# #S #>
4225     0 0 2SWAP >NUMBER SWAP DROP      \ RETURN LENGTH ONLY
4226     R> BASE ! ;
4227 T{ 0 0 2 GN1 -> 0 0 0 }T
4228 T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
4229 T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
4230 T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T
4231 T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T
4232 T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T
4233
4234 : GN2   \ ( -- 16 10 )
4235     BASE @ >R  HEX BASE @  DECIMAL BASE @  R> BASE ! ;
4236 T{ GN2 -> 10 A }T
4237
4238 \ ------------------------------------------------------------------------
4239 TESTING FILL MOVE
4240
4241 CREATE FBUF 00 C, 00 C, 00 C,
4242 CREATE SBUF 12 C, 34 C, 56 C,
4243 : SEEBUF FBUF C@  FBUF CHAR+ C@  FBUF CHAR+ CHAR+ C@ ;
4244
4245 T{ FBUF 0 20 FILL -> }T
4246 T{ SEEBUF -> 00 00 00 }T
4247
4248 T{ FBUF 1 20 FILL -> }T
4249 T{ SEEBUF -> 20 00 00 }T
4250
4251 T{ FBUF 3 20 FILL -> }T
4252 T{ SEEBUF -> 20 20 20 }T
4253
4254 T{ FBUF FBUF 3 CHARS MOVE -> }T     \ BIZARRE SPECIAL CASE
4255 T{ SEEBUF -> 20 20 20 }T
4256
4257 T{ SBUF FBUF 0 CHARS MOVE -> }T
4258 T{ SEEBUF -> 20 20 20 }T
4259
4260 T{ SBUF FBUF 1 CHARS MOVE -> }T
4261 T{ SEEBUF -> 12 20 20 }T
4262
4263 T{ SBUF FBUF 3 CHARS MOVE -> }T
4264 T{ SEEBUF -> 12 34 56 }T
4265
4266 T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T
4267 T{ SEEBUF -> 12 12 34 }T
4268
4269 T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T
4270 T{ SEEBUF -> 12 34 34 }T
4271
4272 \ ------------------------------------------------------------------------
4273 TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
4274
4275 : OUTPUT-TEST
4276     ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
4277     41 BL DO I EMIT LOOP CR
4278     61 41 DO I EMIT LOOP CR
4279     7F 61 DO I EMIT LOOP CR
4280     ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
4281     9 1+ 0 DO I . LOOP CR
4282     ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
4283     [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
4284     ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
4285     [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
4286     ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
4287     5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
4288     ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
4289     S" LINE 1" TYPE CR S" LINE 2" TYPE CR
4290     ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
4291     ."   SIGNED: " MIN-INT . MAX-INT . CR
4292     ." UNSIGNED: " 0 U. MAX-UINT U. CR
4293 ;
4294
4295 T{ OUTPUT-TEST -> }T
4296 \ ------------------------------------------------------------------------
4297 TESTING INPUT: ACCEPT
4298
4299 CREATE ABUF 80 CHARS ALLOT
4300
4301 : ACCEPT-TEST
4302     CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
4303     ABUF 80 ACCEPT
4304     CR ." RECEIVED: " [CHAR] " EMIT
4305     ABUF SWAP TYPE [CHAR] " EMIT CR
4306 ;
4307
4308 T{ ACCEPT-TEST -> }T
4309 Vingt fois sur le métier remettez votre ouvrage, ...
4310 \ ------------------------------------------------------------------------
4311 TESTING DICTIONARY SEARCH RULES
4312
4313 T{ : GDX   123 ; : GDX   GDX 234 ; -> }T
4314
4315 T{ GDX -> 123 234 }T
4316
4317 CR .( End of Core word set tests) CR
4318
4319
4320
4321 RST_STATE   ; so ANS_COMPLEMENT_xx_MPY is conserved ;
4322 \ NOECHO      ; if an error occurs, comment this line before new download to find it.
4323
4324
4325 \ From: John Hayes S1I
4326 \ Subject: tester.fr
4327 \ Date: Mon, 27 Nov 95 13:10:09 PST
4328
4329 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
4330 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
4331 \ VERSION 1.1
4332
4333 \ 22/1/09 The words { and } have been changed to T{ and }T respectively to
4334 \ agree with the Forth 200X file ttester.fs. This avoids clashes with
4335 \ locals using { ... } and the FSL use of }
4336
4337
4338 \ 13/05/14 jmt. added colorised error messages.
4339
4340
4341
4342  0 CONSTANT FALSE
4343 -1 CONSTANT TRUE
4344
4345 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
4346 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
4347 VARIABLE VERBOSE
4348     FALSE VERBOSE !
4349 \   TRUE VERBOSE !
4350
4351 \ : EMPTY-STACK ( ... -- )  \ EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
4352 \     DEPTH ?DUP
4353 \             IF DUP 0< IF NEGATE 0
4354 \             DO 0 LOOP
4355 \             ELSE 0 DO DROP LOOP THEN
4356 \             THEN ;
4357 \
4358 \ : ERROR     \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
4359 \         \ THE LINE THAT HAD THE ERROR.
4360 \     TYPE SOURCE TYPE CR          \ DISPLAY LINE CORRESPONDING TO ERROR
4361 \     EMPTY-STACK              \ THROW AWAY EVERY THING ELSE
4362 \     QUIT  \ *** Uncomment this line to QUIT on an error
4363 \ ;
4364
4365 VARIABLE ACTUAL-DEPTH           \ STACK RECORD
4366 CREATE ACTUAL-RESULTS 20 CELLS ALLOT
4367
4368 : T{        \ ( -- ) SYNTACTIC SUGAR.
4369     ;
4370
4371 : ->        \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
4372     DEPTH DUP ACTUAL-DEPTH !     \ RECORD DEPTH
4373     ?DUP IF              \ IF THERE IS SOMETHING ON STACK
4374         0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
4375     THEN ;
4376
4377 : }T        \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
4378             \ (ACTUAL) CONTENTS.
4379     DEPTH ACTUAL-DEPTH @ = IF   \ IF DEPTHS MATCH
4380         DEPTH ?DUP IF           \ IF THERE IS SOMETHING ON THE STACK
4381         0 DO                    \ FOR EACH STACK ITEM
4382             ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
4383 \           = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN   \ jmt
4384             = 0= IF ABORT" INCORRECT RESULT: " THEN           \ jmt : colorised message
4385         LOOP
4386         THEN
4387     ELSE                 \ DEPTH MISMATCH
4388 \       S" WRONG NUMBER OF RESULTS: " ERROR \ jmt
4389         ABORT" WRONG NUMBER OF RESULTS: "   \ jmt : colorised message
4390     THEN ;
4391
4392 : TESTING   \ ( -- ) TALKING COMMENT.
4393     SOURCE VERBOSE @
4394     IF DUP >R TYPE CR R> >IN !
4395     ELSE >IN ! DROP [CHAR] * EMIT
4396     THEN ;
4397
4398 \ From: John Hayes S1I
4399 \ Subject: core.fr
4400 \ Date: Mon, 27 Nov 95 13:10
4401
4402 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
4403 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
4404 \ VERSION 1.2
4405 \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
4406 \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
4407 \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
4408 \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
4409 \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
4410 \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
4411
4412 CR
4413 TESTING CORE WORDS
4414 HEX
4415
4416 \ ------------------------------------------------------------------------
4417 TESTING BASIC ASSUMPTIONS
4418
4419 T{ -> }T                    \ START WITH CLEAN SLATE
4420 ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
4421 T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T
4422 T{  0 BITSSET? -> 0 }T      ( ZERO IS ALL BITS CLEAR )
4423 T{  1 BITSSET? -> 0 0 }T        ( OTHER NUMBER HAVE AT LEAST ONE BIT )
4424 T{ -1 BITSSET? -> 0 0 }T
4425
4426 \ ------------------------------------------------------------------------
4427 TESTING BOOLEANS: INVERT AND OR XOR
4428
4429 T{ 0 0 AND -> 0 }T
4430 T{ 0 1 AND -> 0 }T
4431 T{ 1 0 AND -> 0 }T
4432 T{ 1 1 AND -> 1 }T
4433
4434 T{ 0 INVERT 1 AND -> 1 }T
4435 T{ 1 INVERT 1 AND -> 0 }T
4436
4437 0    CONSTANT 0S
4438 0 INVERT CONSTANT 1S
4439
4440 T{ 0S INVERT -> 1S }T
4441 T{ 1S INVERT -> 0S }T
4442
4443 T{ 0S 0S AND -> 0S }T
4444 T{ 0S 1S AND -> 0S }T
4445 T{ 1S 0S AND -> 0S }T
4446 T{ 1S 1S AND -> 1S }T
4447
4448 T{ 0S 0S OR -> 0S }T
4449 T{ 0S 1S OR -> 1S }T
4450 T{ 1S 0S OR -> 1S }T
4451 T{ 1S 1S OR -> 1S }T
4452
4453 T{ 0S 0S XOR -> 0S }T
4454 T{ 0S 1S XOR -> 1S }T
4455 T{ 1S 0S XOR -> 1S }T
4456 T{ 1S 1S XOR -> 0S }T
4457
4458 \ ------------------------------------------------------------------------
4459 TESTING 2* 2/ LSHIFT RSHIFT
4460
4461 ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
4462 1S 1 RSHIFT INVERT CONSTANT MSB
4463 T{ MSB BITSSET? -> 0 0 }T
4464
4465 T{ 0S 2* -> 0S }T
4466 T{ 1 2* -> 2 }T
4467 T{ 4000 2* -> 8000 }T
4468 T{ 1S 2* 1 XOR -> 1S }T
4469 T{ MSB 2* -> 0S }T
4470
4471 T{ 0S 2/ -> 0S }T
4472 T{ 1 2/ -> 0 }T
4473 T{ 4000 2/ -> 2000 }T
4474 T{ 1S 2/ -> 1S }T               \ MSB PROPOGATED
4475 T{ 1S 1 XOR 2/ -> 1S }T
4476 T{ MSB 2/ MSB AND -> MSB }T
4477
4478 T{ 1 0 LSHIFT -> 1 }T
4479 T{ 1 1 LSHIFT -> 2 }T
4480 T{ 1 2 LSHIFT -> 4 }T
4481 T{ 1 F LSHIFT -> 8000 }T            \ BIGGEST GUARANTEED SHIFT
4482 T{ 1S 1 LSHIFT 1 XOR -> 1S }T
4483 T{ MSB 1 LSHIFT -> 0 }T
4484
4485 T{ 1 0 RSHIFT -> 1 }T
4486 T{ 1 1 RSHIFT -> 0 }T
4487 T{ 2 1 RSHIFT -> 1 }T
4488 T{ 4 2 RSHIFT -> 1 }T
4489 T{ 8000 F RSHIFT -> 1 }T            \ BIGGEST
4490 T{ MSB 1 RSHIFT MSB AND -> 0 }T     \ RSHIFT ZERO FILLS MSBS
4491 T{ MSB 1 RSHIFT 2* -> MSB }T
4492
4493 \ ------------------------------------------------------------------------
4494 TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
4495 0 INVERT            CONSTANT MAX-UINT
4496 0 INVERT 1 RSHIFT       CONSTANT MAX-INT
4497 0 INVERT 1 RSHIFT INVERT    CONSTANT MIN-INT
4498 0 INVERT 1 RSHIFT       CONSTANT MID-UINT
4499 0 INVERT 1 RSHIFT INVERT    CONSTANT MID-UINT+1
4500
4501 0S CONSTANT <FALSE>
4502 1S CONSTANT <TRUE>
4503
4504 T{ 0 0= -> <TRUE> }T
4505 T{ 1 0= -> <FALSE> }T
4506 T{ 2 0= -> <FALSE> }T
4507 T{ -1 0= -> <FALSE> }T
4508 T{ MAX-UINT 0= -> <FALSE> }T
4509 T{ MIN-INT 0= -> <FALSE> }T
4510 T{ MAX-INT 0= -> <FALSE> }T
4511
4512 T{ 0 0 = -> <TRUE> }T
4513 T{ 1 1 = -> <TRUE> }T
4514 T{ -1 -1 = -> <TRUE> }T
4515 T{ 1 0 = -> <FALSE> }T
4516 T{ -1 0 = -> <FALSE> }T
4517 T{ 0 1 = -> <FALSE> }T
4518 T{ 0 -1 = -> <FALSE> }T
4519
4520 T{ 0 0< -> <FALSE> }T
4521 T{ -1 0< -> <TRUE> }T
4522 T{ MIN-INT 0< -> <TRUE> }T
4523 T{ 1 0< -> <FALSE> }T
4524 T{ MAX-INT 0< -> <FALSE> }T
4525
4526 T{ 0 1 < -> <TRUE> }T
4527 T{ 1 2 < -> <TRUE> }T
4528 T{ -1 0 < -> <TRUE> }T
4529 T{ -1 1 < -> <TRUE> }T
4530 T{ MIN-INT 0 < -> <TRUE> }T
4531 T{ MIN-INT MAX-INT < -> <TRUE> }T
4532 T{ 0 MAX-INT < -> <TRUE> }T
4533 T{ 0 0 < -> <FALSE> }T
4534 T{ 1 1 < -> <FALSE> }T
4535 T{ 1 0 < -> <FALSE> }T
4536 T{ 2 1 < -> <FALSE> }T
4537 T{ 0 -1 < -> <FALSE> }T
4538 T{ 1 -1 < -> <FALSE> }T
4539 T{ 0 MIN-INT < -> <FALSE> }T
4540 T{ MAX-INT MIN-INT < -> <FALSE> }T
4541 T{ MAX-INT 0 < -> <FALSE> }T
4542
4543 T{ 0 1 > -> <FALSE> }T
4544 T{ 1 2 > -> <FALSE> }T
4545 T{ -1 0 > -> <FALSE> }T
4546 T{ -1 1 > -> <FALSE> }T
4547 T{ MIN-INT 0 > -> <FALSE> }T
4548 T{ MIN-INT MAX-INT > -> <FALSE> }T
4549 T{ 0 MAX-INT > -> <FALSE> }T
4550 T{ 0 0 > -> <FALSE> }T
4551 T{ 1 1 > -> <FALSE> }T
4552 T{ 1 0 > -> <TRUE> }T
4553 T{ 2 1 > -> <TRUE> }T
4554 T{ 0 -1 > -> <TRUE> }T
4555 T{ 1 -1 > -> <TRUE> }T
4556 T{ 0 MIN-INT > -> <TRUE> }T
4557 T{ MAX-INT MIN-INT > -> <TRUE> }T
4558 T{ MAX-INT 0 > -> <TRUE> }T
4559
4560 T{ 0 1 U< -> <TRUE> }T
4561 T{ 1 2 U< -> <TRUE> }T
4562 T{ 0 MID-UINT U< -> <TRUE> }T
4563 T{ 0 MAX-UINT U< -> <TRUE> }T
4564 T{ MID-UINT MAX-UINT U< -> <TRUE> }T
4565 T{ 0 0 U< -> <FALSE> }T
4566 T{ 1 1 U< -> <FALSE> }T
4567 T{ 1 0 U< -> <FALSE> }T
4568 T{ 2 1 U< -> <FALSE> }T
4569 T{ MID-UINT 0 U< -> <FALSE> }T
4570 T{ MAX-UINT 0 U< -> <FALSE> }T
4571 T{ MAX-UINT MID-UINT U< -> <FALSE> }T
4572
4573 T{ 0 1 MIN -> 0 }T
4574 T{ 1 2 MIN -> 1 }T
4575 T{ -1 0 MIN -> -1 }T
4576 T{ -1 1 MIN -> -1 }T
4577 T{ MIN-INT 0 MIN -> MIN-INT }T
4578 T{ MIN-INT MAX-INT MIN -> MIN-INT }T
4579 T{ 0 MAX-INT MIN -> 0 }T
4580 T{ 0 0 MIN -> 0 }T
4581 T{ 1 1 MIN -> 1 }T
4582 T{ 1 0 MIN -> 0 }T
4583 T{ 2 1 MIN -> 1 }T
4584 T{ 0 -1 MIN -> -1 }T
4585 T{ 1 -1 MIN -> -1 }T
4586 T{ 0 MIN-INT MIN -> MIN-INT }T
4587 T{ MAX-INT MIN-INT MIN -> MIN-INT }T
4588 T{ MAX-INT 0 MIN -> 0 }T
4589
4590 T{ 0 1 MAX -> 1 }T
4591 T{ 1 2 MAX -> 2 }T
4592 T{ -1 0 MAX -> 0 }T
4593 T{ -1 1 MAX -> 1 }T
4594 T{ MIN-INT 0 MAX -> 0 }T
4595 T{ MIN-INT MAX-INT MAX -> MAX-INT }T
4596 T{ 0 MAX-INT MAX -> MAX-INT }T
4597 T{ 0 0 MAX -> 0 }T
4598 T{ 1 1 MAX -> 1 }T
4599 T{ 1 0 MAX -> 1 }T
4600 T{ 2 1 MAX -> 2 }T
4601 T{ 0 -1 MAX -> 0 }T
4602 T{ 1 -1 MAX -> 1 }T
4603 T{ 0 MIN-INT MAX -> 0 }T
4604 T{ MAX-INT MIN-INT MAX -> MAX-INT }T
4605 T{ MAX-INT 0 MAX -> MAX-INT }T
4606
4607 \ ------------------------------------------------------------------------
4608 TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
4609
4610 T{ 1 2 2DROP -> }T
4611 T{ 1 2 2DUP -> 1 2 1 2 }T
4612 T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T
4613 T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T
4614 T{ 0 ?DUP -> 0 }T
4615 T{ 1 ?DUP -> 1 1 }T
4616 T{ -1 ?DUP -> -1 -1 }T
4617 T{ DEPTH -> 0 }T
4618 T{ 0 DEPTH -> 0 1 }T
4619 T{ 0 1 DEPTH -> 0 1 2 }T
4620 T{ 0 DROP -> }T
4621 T{ 1 2 DROP -> 1 }T
4622 T{ 1 DUP -> 1 1 }T
4623 T{ 1 2 OVER -> 1 2 1 }T
4624 T{ 1 2 3 ROT -> 2 3 1 }T
4625 T{ 1 2 SWAP -> 2 1 }T
4626
4627 \ ------------------------------------------------------------------------
4628 TESTING >R R> R@
4629
4630 T{ : GR1 >R R> ; -> }T
4631 T{ : GR2 >R R@ R> DROP ; -> }T
4632 T{ 123 GR1 -> 123 }T
4633 T{ 123 GR2 -> 123 }T
4634 T{ 1S GR1 -> 1S }T   ( RETURN STACK HOLDS CELLS )
4635
4636 \ ------------------------------------------------------------------------
4637 TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
4638
4639 T{ 0 5 + -> 5 }T
4640 T{ 5 0 + -> 5 }T
4641 T{ 0 -5 + -> -5 }T
4642 T{ -5 0 + -> -5 }T
4643 T{ 1 2 + -> 3 }T
4644 T{ 1 -2 + -> -1 }T
4645 T{ -1 2 + -> 1 }T
4646 T{ -1 -2 + -> -3 }T
4647 T{ -1 1 + -> 0 }T
4648 T{ MID-UINT 1 + -> MID-UINT+1 }T
4649
4650 T{ 0 5 - -> -5 }T
4651 T{ 5 0 - -> 5 }T
4652 T{ 0 -5 - -> 5 }T
4653 T{ -5 0 - -> -5 }T
4654 T{ 1 2 - -> -1 }T
4655 T{ 1 -2 - -> 3 }T
4656 T{ -1 2 - -> -3 }T
4657 T{ -1 -2 - -> 1 }T
4658 T{ 0 1 - -> -1 }T
4659 T{ MID-UINT+1 1 - -> MID-UINT }T
4660
4661 T{ 0 1+ -> 1 }T
4662 T{ -1 1+ -> 0 }T
4663 T{ 1 1+ -> 2 }T
4664 T{ MID-UINT 1+ -> MID-UINT+1 }T
4665
4666 T{ 2 1- -> 1 }T
4667 T{ 1 1- -> 0 }T
4668 T{ 0 1- -> -1 }T
4669 T{ MID-UINT+1 1- -> MID-UINT }T
4670
4671 T{ 0 NEGATE -> 0 }T
4672 T{ 1 NEGATE -> -1 }T
4673 T{ -1 NEGATE -> 1 }T
4674 T{ 2 NEGATE -> -2 }T
4675 T{ -2 NEGATE -> 2 }T
4676
4677 T{ 0 ABS -> 0 }T
4678 T{ 1 ABS -> 1 }T
4679 T{ -1 ABS -> 1 }T
4680 T{ MIN-INT ABS -> MID-UINT+1 }T
4681
4682 \ ------------------------------------------------------------------------
4683 TESTING MULTIPLY: S>D * M* UM*
4684
4685 T{ 0 S>D -> 0 0 }T
4686 T{ 1 S>D -> 1 0 }T
4687 T{ 2 S>D -> 2 0 }T
4688 T{ -1 S>D -> -1 -1 }T
4689 T{ -2 S>D -> -2 -1 }T
4690 T{ MIN-INT S>D -> MIN-INT -1 }T
4691 T{ MAX-INT S>D -> MAX-INT 0 }T
4692
4693 T{ 0 0 M* -> 0 S>D }T
4694 T{ 0 1 M* -> 0 S>D }T
4695 T{ 1 0 M* -> 0 S>D }T
4696 T{ 1 2 M* -> 2 S>D }T
4697 T{ 2 1 M* -> 2 S>D }T
4698 T{ 3 3 M* -> 9 S>D }T
4699 T{ -3 3 M* -> -9 S>D }T
4700 T{ 3 -3 M* -> -9 S>D }T
4701 T{ -3 -3 M* -> 9 S>D }T
4702 T{ 0 MIN-INT M* -> 0 S>D }T
4703 T{ 1 MIN-INT M* -> MIN-INT S>D }T
4704 T{ 2 MIN-INT M* -> 0 1S }T
4705 T{ 0 MAX-INT M* -> 0 S>D }T
4706 T{ 1 MAX-INT M* -> MAX-INT S>D }T
4707 T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T
4708 T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T
4709 T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T
4710 T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T
4711
4712 T{ 0 0 * -> 0 }T                \ TEST IDENTITIES
4713 T{ 0 1 * -> 0 }T
4714 T{ 1 0 * -> 0 }T
4715 T{ 1 2 * -> 2 }T
4716 T{ 2 1 * -> 2 }T
4717 T{ 3 3 * -> 9 }T
4718 T{ -3 3 * -> -9 }T
4719 T{ 3 -3 * -> -9 }T
4720 T{ -3 -3 * -> 9 }T
4721
4722 T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T
4723 T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T
4724 T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T
4725
4726 T{ 0 0 UM* -> 0 0 }T
4727 T{ 0 1 UM* -> 0 0 }T
4728 T{ 1 0 UM* -> 0 0 }T
4729 T{ 1 2 UM* -> 2 0 }T
4730 T{ 2 1 UM* -> 2 0 }T
4731 T{ 3 3 UM* -> 9 0 }T
4732
4733 T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T
4734 T{ MID-UINT+1 2 UM* -> 0 1 }T
4735 T{ MID-UINT+1 4 UM* -> 0 2 }T
4736 T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T
4737 T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T
4738
4739 \ ------------------------------------------------------------------------
4740 TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
4741
4742 T{ 0 S>D 1 FM/MOD -> 0 0 }T
4743 T{ 1 S>D 1 FM/MOD -> 0 1 }T
4744 T{ 2 S>D 1 FM/MOD -> 0 2 }T
4745 T{ -1 S>D 1 FM/MOD -> 0 -1 }T
4746 T{ -2 S>D 1 FM/MOD -> 0 -2 }T
4747 T{ 0 S>D -1 FM/MOD -> 0 0 }T
4748 T{ 1 S>D -1 FM/MOD -> 0 -1 }T
4749 T{ 2 S>D -1 FM/MOD -> 0 -2 }T
4750 T{ -1 S>D -1 FM/MOD -> 0 1 }T
4751 T{ -2 S>D -1 FM/MOD -> 0 2 }T
4752 T{ 2 S>D 2 FM/MOD -> 0 1 }T
4753 T{ -1 S>D -1 FM/MOD -> 0 1 }T
4754 T{ -2 S>D -2 FM/MOD -> 0 1 }T
4755 T{  7 S>D  3 FM/MOD -> 1 2 }T
4756 T{  7 S>D -3 FM/MOD -> -2 -3 }T
4757 T{ -7 S>D  3 FM/MOD -> 2 -3 }T
4758 T{ -7 S>D -3 FM/MOD -> -1 2 }T
4759 T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T
4760 T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T
4761 T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T
4762 T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T
4763 T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T
4764 T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T
4765 T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T
4766 T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T
4767 T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T
4768 T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T
4769 T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T
4770 T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T
4771 T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T
4772 T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T
4773 T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T
4774 T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T
4775 T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T
4776
4777 T{ 0 S>D 1 SM/REM -> 0 0 }T
4778 T{ 1 S>D 1 SM/REM -> 0 1 }T
4779 T{ 2 S>D 1 SM/REM -> 0 2 }T
4780 T{ -1 S>D 1 SM/REM -> 0 -1 }T
4781 T{ -2 S>D 1 SM/REM -> 0 -2 }T
4782 T{ 0 S>D -1 SM/REM -> 0 0 }T
4783 T{ 1 S>D -1 SM/REM -> 0 -1 }T
4784 T{ 2 S>D -1 SM/REM -> 0 -2 }T
4785 T{ -1 S>D -1 SM/REM -> 0 1 }T
4786 T{ -2 S>D -1 SM/REM -> 0 2 }T
4787 T{ 2 S>D 2 SM/REM -> 0 1 }T
4788 T{ -1 S>D -1 SM/REM -> 0 1 }T
4789 T{ -2 S>D -2 SM/REM -> 0 1 }T
4790 T{  7 S>D  3 SM/REM -> 1 2 }T
4791 T{  7 S>D -3 SM/REM -> 1 -2 }T
4792 T{ -7 S>D  3 SM/REM -> -1 -2 }T
4793 T{ -7 S>D -3 SM/REM -> -1 2 }T
4794 T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T
4795 T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T
4796 T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T
4797 T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T
4798 T{ 1S 1 4 SM/REM -> 3 MAX-INT }T
4799 T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T
4800 T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T
4801 T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T
4802 T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T
4803 T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T
4804 T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T
4805 T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T
4806 T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T
4807
4808 T{ 0 0 1 UM/MOD -> 0 0 }T
4809 T{ 1 0 1 UM/MOD -> 0 1 }T
4810 T{ 1 0 2 UM/MOD -> 1 0 }T
4811 T{ 3 0 2 UM/MOD -> 1 1 }T
4812 T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T
4813 T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T
4814 T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T
4815
4816 : IFFLOORED
4817     [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
4818
4819 : IFSYM
4820     [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
4821
4822 \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
4823 \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
4824
4825 IFFLOORED : T/MOD  >R S>D R> FM/MOD ;
4826 IFFLOORED : T/     T/MOD SWAP DROP ;
4827 IFFLOORED : TMOD   T/MOD DROP ;
4828 IFFLOORED : T*/MOD >R M* R> FM/MOD ;
4829 IFFLOORED : T*/    T*/MOD SWAP DROP ;
4830 IFSYM     : T/MOD  >R S>D R> SM/REM ;
4831 IFSYM     : T/     T/MOD SWAP DROP ;
4832 IFSYM     : TMOD   T/MOD DROP ;
4833 IFSYM     : T*/MOD >R M* R> SM/REM ;
4834 IFSYM     : T*/    T*/MOD SWAP DROP ;
4835
4836 T{ 0 1 /MOD -> 0 1 T/MOD }T
4837 T{ 1 1 /MOD -> 1 1 T/MOD }T
4838 T{ 2 1 /MOD -> 2 1 T/MOD }T
4839 T{ -1 1 /MOD -> -1 1 T/MOD }T
4840 T{ -2 1 /MOD -> -2 1 T/MOD }T
4841 T{ 0 -1 /MOD -> 0 -1 T/MOD }T
4842 T{ 1 -1 /MOD -> 1 -1 T/MOD }T
4843 T{ 2 -1 /MOD -> 2 -1 T/MOD }T
4844 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
4845 T{ -2 -1 /MOD -> -2 -1 T/MOD }T
4846 T{ 2 2 /MOD -> 2 2 T/MOD }T
4847 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
4848 T{ -2 -2 /MOD -> -2 -2 T/MOD }T
4849 T{ 7 3 /MOD -> 7 3 T/MOD }T
4850 T{ 7 -3 /MOD -> 7 -3 T/MOD }T
4851 T{ -7 3 /MOD -> -7 3 T/MOD }T
4852 T{ -7 -3 /MOD -> -7 -3 T/MOD }T
4853 T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T
4854 T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T
4855 T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T
4856 T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T
4857
4858 T{ 0 1 / -> 0 1 T/ }T
4859 T{ 1 1 / -> 1 1 T/ }T
4860 T{ 2 1 / -> 2 1 T/ }T
4861 T{ -1 1 / -> -1 1 T/ }T
4862 T{ -2 1 / -> -2 1 T/ }T
4863 T{ 0 -1 / -> 0 -1 T/ }T
4864 T{ 1 -1 / -> 1 -1 T/ }T
4865 T{ 2 -1 / -> 2 -1 T/ }T
4866 T{ -1 -1 / -> -1 -1 T/ }T
4867 T{ -2 -1 / -> -2 -1 T/ }T
4868 T{ 2 2 / -> 2 2 T/ }T
4869 T{ -1 -1 / -> -1 -1 T/ }T
4870 T{ -2 -2 / -> -2 -2 T/ }T
4871 T{ 7 3 / -> 7 3 T/ }T
4872 T{ 7 -3 / -> 7 -3 T/ }T
4873 T{ -7 3 / -> -7 3 T/ }T
4874 T{ -7 -3 / -> -7 -3 T/ }T
4875 T{ MAX-INT 1 / -> MAX-INT 1 T/ }T
4876 T{ MIN-INT 1 / -> MIN-INT 1 T/ }T
4877 T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T
4878 T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T
4879
4880 T{ 0 1 MOD -> 0 1 TMOD }T
4881 T{ 1 1 MOD -> 1 1 TMOD }T
4882 T{ 2 1 MOD -> 2 1 TMOD }T
4883 T{ -1 1 MOD -> -1 1 TMOD }T
4884 T{ -2 1 MOD -> -2 1 TMOD }T
4885 T{ 0 -1 MOD -> 0 -1 TMOD }T
4886 T{ 1 -1 MOD -> 1 -1 TMOD }T
4887 T{ 2 -1 MOD -> 2 -1 TMOD }T
4888 T{ -1 -1 MOD -> -1 -1 TMOD }T
4889 T{ -2 -1 MOD -> -2 -1 TMOD }T
4890 T{ 2 2 MOD -> 2 2 TMOD }T
4891 T{ -1 -1 MOD -> -1 -1 TMOD }T
4892 T{ -2 -2 MOD -> -2 -2 TMOD }T
4893 T{ 7 3 MOD -> 7 3 TMOD }T
4894 T{ 7 -3 MOD -> 7 -3 TMOD }T
4895 T{ -7 3 MOD -> -7 3 TMOD }T
4896 T{ -7 -3 MOD -> -7 -3 TMOD }T
4897 T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T
4898 T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T
4899 T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T
4900 T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T
4901
4902 T{ 0 2 1 */ -> 0 2 1 T*/ }T
4903 T{ 1 2 1 */ -> 1 2 1 T*/ }T
4904 T{ 2 2 1 */ -> 2 2 1 T*/ }T
4905 T{ -1 2 1 */ -> -1 2 1 T*/ }T
4906 T{ -2 2 1 */ -> -2 2 1 T*/ }T
4907 T{ 0 2 -1 */ -> 0 2 -1 T*/ }T
4908 T{ 1 2 -1 */ -> 1 2 -1 T*/ }T
4909 T{ 2 2 -1 */ -> 2 2 -1 T*/ }T
4910 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
4911 T{ -2 2 -1 */ -> -2 2 -1 T*/ }T
4912 T{ 2 2 2 */ -> 2 2 2 T*/ }T
4913 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
4914 T{ -2 2 -2 */ -> -2 2 -2 T*/ }T
4915 T{ 7 2 3 */ -> 7 2 3 T*/ }T
4916 T{ 7 2 -3 */ -> 7 2 -3 T*/ }T
4917 T{ -7 2 3 */ -> -7 2 3 T*/ }T
4918 T{ -7 2 -3 */ -> -7 2 -3 T*/ }T
4919 T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T
4920 T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T
4921
4922 T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T
4923 T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T
4924 T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T
4925 T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T
4926 T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T
4927 T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T
4928 T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T
4929 T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T
4930 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
4931 T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T
4932 T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T
4933 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
4934 T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T
4935 T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T
4936 T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T
4937 T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T
4938 T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T
4939 T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T
4940 T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T
4941
4942 \ ------------------------------------------------------------------------
4943 TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
4944
4945 HERE 1 ALLOT
4946 HERE
4947 CONSTANT 2NDA
4948 CONSTANT 1STA
4949 T{ 1STA 2NDA U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
4950 T{ 1STA 1+ -> 2NDA }T           \ ... BY ONE ADDRESS UNIT
4951 ( MISSING TEST: NEGATIVE ALLOT )
4952
4953 HERE 1 ,
4954 HERE 2 ,
4955 CONSTANT 2ND
4956 CONSTANT 1ST
4957 T{ 1ST 2ND U< -> <TRUE> }T          \ HERE MUST GROW WITH ALLOT
4958 T{ 1ST CELL+ -> 2ND }T          \ ... BY ONE CELL
4959 T{ 1ST 1 CELLS + -> 2ND }T
4960 T{ 1ST @ 2ND @ -> 1 2 }T
4961 T{ 5 1ST ! -> }T
4962 T{ 1ST @ 2ND @ -> 5 2 }T
4963 T{ 6 2ND ! -> }T
4964 T{ 1ST @ 2ND @ -> 5 6 }T
4965 T{ 1ST 2@ -> 6 5 }T
4966 T{ 2 1 1ST 2! -> }T
4967 T{ 1ST 2@ -> 2 1 }T
4968 T{ 1S 1ST !  1ST @ -> 1S }T     \ CAN STORE CELL-WIDE VALUE
4969
4970 HERE 1 C,
4971 HERE 2 C,
4972 CONSTANT 2NDC
4973 CONSTANT 1STC
4974 T{ 1STC 2NDC U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
4975 T{ 1STC CHAR+ -> 2NDC }T            \ ... BY ONE CHAR
4976 T{ 1STC 1 CHARS + -> 2NDC }T
4977 T{ 1STC C@ 2NDC C@ -> 1 2 }T
4978 T{ 3 1STC C! -> }T
4979 T{ 1STC C@ 2NDC C@ -> 3 2 }T
4980 T{ 4 2NDC C! -> }T
4981 T{ 1STC C@ 2NDC C@ -> 3 4 }T
4982
4983 ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
4984 CONSTANT A-ADDR  CONSTANT UA-ADDR
4985 T{ UA-ADDR ALIGNED -> A-ADDR }T
4986 T{    1 A-ADDR C!  A-ADDR C@ ->    1 }T
4987 T{ 1234 A-ADDR  !  A-ADDR  @ -> 1234 }T
4988 T{ 123 456 A-ADDR 2!  A-ADDR 2@ -> 123 456 }T
4989 T{ 2 A-ADDR CHAR+ C!  A-ADDR CHAR+ C@ -> 2 }T
4990 T{ 3 A-ADDR CELL+ C!  A-ADDR CELL+ C@ -> 3 }T
4991 T{ 1234 A-ADDR CELL+ !  A-ADDR CELL+ @ -> 1234 }T
4992 T{ 123 456 A-ADDR CELL+ 2!  A-ADDR CELL+ 2@ -> 123 456 }T
4993
4994 : BITS ( X -- U )
4995     0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
4996 ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
4997 T{ 1 CHARS 1 < -> <FALSE> }T
4998 T{ 1 CHARS 1 CELLS > -> <FALSE> }T
4999 ( TBD: HOW TO FIND NUMBER OF BITS? )
5000
5001 ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
5002 T{ 1 CELLS 1 < -> <FALSE> }T
5003 T{ 1 CELLS 1 CHARS MOD -> 0 }T
5004 T{ 1S BITS 10 < -> <FALSE> }T
5005
5006 T{ 0 1ST ! -> }T
5007 T{ 1 1ST +! -> }T
5008 T{ 1ST @ -> 1 }T
5009 T{ -1 1ST +! 1ST @ -> 0 }T
5010
5011 \ ------------------------------------------------------------------------
5012 TESTING CHAR [CHAR] [ ] BL S"
5013
5014 T{ BL -> 20 }T
5015 T{ CHAR X -> 58 }T
5016 T{ CHAR HELLO -> 48 }T
5017 T{ : GC1 [CHAR] X ; -> }T
5018 T{ : GC2 [CHAR] HELLO ; -> }T
5019 T{ GC1 -> 58 }T
5020 T{ GC2 -> 48 }T
5021 T{ : GC3 [ GC1 ] LITERAL ; -> }T
5022 T{ GC3 -> 58 }T
5023 T{ : GC4 S" XY" ; -> }T
5024 T{ GC4 SWAP DROP -> 2 }T
5025 T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T
5026
5027 \ ------------------------------------------------------------------------
5028 TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
5029
5030 T{ : GT1 123 ; -> }T
5031 T{ ' GT1 EXECUTE -> 123 }T
5032 T{ : GT2 ['] GT1 ; IMMEDIATE -> }T
5033 T{ GT2 EXECUTE -> 123 }T
5034 HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
5035 HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
5036 T{ GT1STRING FIND -> ' GT1 -1 }T
5037 T{ GT2STRING FIND -> ' GT2 1 }T
5038 ( HOW TO SEARCH FOR NON-EXISTENT WORD? )
5039 T{ : GT3 GT2 LITERAL ; -> }T
5040 T{ GT3 -> ' GT1 }T
5041 T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T
5042
5043 T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T
5044 T{ : GT5 GT4 ; -> }T
5045 T{ GT5 -> 123 }T
5046 T{ : GT6 345 ; IMMEDIATE -> }T
5047 T{ : GT7 POSTPONE GT6 ; -> }T
5048 T{ GT7 -> 345 }T
5049
5050 T{ : GT8 STATE @ ; IMMEDIATE -> }T
5051 T{ GT8 -> 0 }T
5052 T{ : GT9 GT8 LITERAL ; -> }T
5053 T{ GT9 0= -> <FALSE> }T
5054
5055 \ ------------------------------------------------------------------------
5056 TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
5057
5058 T{ : GI1 IF 123 THEN ; -> }T
5059 T{ : GI2 IF 123 ELSE 234 THEN ; -> }T
5060 T{ 0 GI1 -> }T
5061 T{ 1 GI1 -> 123 }T
5062 T{ -1 GI1 -> 123 }T
5063 T{ 0 GI2 -> 234 }T
5064 T{ 1 GI2 -> 123 }T
5065 T{ -1 GI1 -> 123 }T
5066
5067 T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T
5068 T{ 0 GI3 -> 0 1 2 3 4 5 }T
5069 T{ 4 GI3 -> 4 5 }T
5070 T{ 5 GI3 -> 5 }T
5071 T{ 6 GI3 -> 6 }T
5072
5073 T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T
5074 T{ 3 GI4 -> 3 4 5 6 }T
5075 T{ 5 GI4 -> 5 6 }T
5076 T{ 6 GI4 -> 6 7 }T
5077
5078 T{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T
5079 T{ 1 GI5 -> 1 345 }T
5080 T{ 2 GI5 -> 2 345 }T
5081 T{ 3 GI5 -> 3 4 5 123 }T
5082 T{ 4 GI5 -> 4 5 123 }T
5083 T{ 5 GI5 -> 5 123 }T
5084
5085 T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T
5086 T{ 0 GI6 -> 0 }T
5087 T{ 1 GI6 -> 0 1 }T
5088 T{ 2 GI6 -> 0 1 2 }T
5089 T{ 3 GI6 -> 0 1 2 3 }T
5090 T{ 4 GI6 -> 0 1 2 3 4 }T
5091
5092 \ ------------------------------------------------------------------------
5093 TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
5094
5095 T{ : GD1 DO I LOOP ; -> }T
5096 T{ 4 1 GD1 -> 1 2 3 }T
5097 T{ 2 -1 GD1 -> -1 0 1 }T
5098 T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T
5099
5100 T{ : GD2 DO I -1 +LOOP ; -> }T
5101 T{ 1 4 GD2 -> 4 3 2 1 }T
5102 T{ -1 2 GD2 -> 2 1 0 -1 }T
5103 T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T
5104
5105 T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T
5106 T{ 4 1 GD3 -> 1 2 3 }T
5107 T{ 2 -1 GD3 -> -1 0 1 }T
5108 T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T
5109
5110 T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T
5111 T{ 1 4 GD4 -> 4 3 2 1 }T
5112 T{ -1 2 GD4 -> 2 1 0 -1 }T
5113 T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T
5114
5115 T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T
5116 T{ 1 GD5 -> 123 }T
5117 T{ 5 GD5 -> 123 }T
5118 T{ 6 GD5 -> 234 }T
5119
5120 T{ : GD6  ( PAT: T{0 0}T,T{0 0}TT{1 0}TT{1 1}T,T{0 0}TT{1 0}TT{1 1}TT{2 0}TT{2 1}TT{2 2}T )
5121     0 SWAP 0 DO
5122         I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
5123     LOOP ; -> }T
5124 T{ 1 GD6 -> 1 }T
5125 T{ 2 GD6 -> 3 }T
5126 T{ 3 GD6 -> 4 1 2 }T
5127
5128 \ ------------------------------------------------------------------------
5129 TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
5130
5131 T{ 123 CONSTANT X123 -> }T
5132 T{ X123 -> 123 }T
5133 T{ : EQU CONSTANT ; -> }T
5134 T{ X123 EQU Y123 -> }T
5135 T{ Y123 -> 123 }T
5136
5137 T{ VARIABLE V1 -> }T
5138 T{ 123 V1 ! -> }T
5139 T{ V1 @ -> 123 }T
5140
5141 T{ : NOP : POSTPONE ; ; -> }T
5142 T{ NOP NOP1 NOP NOP2 -> }T
5143 T{ NOP1 -> }T
5144 T{ NOP2 -> }T
5145
5146 T{ : DOES1 DOES> @ 1 + ; -> }T
5147 T{ : DOES2 DOES> @ 2 + ; -> }T
5148 T{ CREATE CR1 -> }T
5149 T{ CR1 -> HERE }T
5150 T{ ' CR1 >BODY -> HERE }T
5151 T{ 1 , -> }T
5152 T{ CR1 @ -> 1 }T
5153 T{ DOES1 -> }T
5154 T{ CR1 -> 2 }T
5155 T{ DOES2 -> }T
5156 T{ CR1 -> 3 }T
5157
5158 T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T
5159 T{ WEIRD: W1 -> }T
5160 T{ ' W1 >BODY -> HERE }T
5161 T{ W1 -> HERE 1 + }T
5162 T{ W1 -> HERE 2 + }T
5163
5164 \ ------------------------------------------------------------------------
5165 TESTING EVALUATE
5166
5167 : GE1 S" 123" ; IMMEDIATE
5168 : GE2 S" 123 1+" ; IMMEDIATE
5169 : GE3 S" : GE4 345 ;" ;
5170 : GE5 EVALUATE ; IMMEDIATE
5171
5172 T{ GE1 EVALUATE -> 123 }T           ( TEST EVALUATE IN INTERP. STATE )
5173 T{ GE2 EVALUATE -> 124 }T
5174 T{ GE3 EVALUATE -> }T
5175 T{ GE4 -> 345 }T
5176
5177 T{ : GE6 GE1 GE5 ; -> }T            ( TEST EVALUATE IN COMPILE STATE )
5178 T{ GE6 -> 123 }T
5179 T{ : GE7 GE2 GE5 ; -> }T
5180 T{ GE7 -> 124 }T
5181
5182 \ ------------------------------------------------------------------------
5183 TESTING SOURCE >IN WORD
5184
5185 : GS1 S" SOURCE" 2DUP EVALUATE
5186         >R SWAP >R = R> R> = ;
5187 T{ GS1 -> <TRUE> <TRUE> }T
5188
5189 VARIABLE SCANS
5190 : RESCAN?  -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
5191
5192 T{ 2 SCANS !
5193 345 RESCAN?
5194 -> 345 345 }T
5195
5196 : GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
5197 T{ GS2 -> 123 123 123 123 123 }T
5198
5199 : GS3 WORD COUNT SWAP C@ ;
5200 T{ BL GS3 HELLO -> 5 CHAR H }T
5201 T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T
5202 T{ BL GS3
5203 DROP -> 0 }T                \ BLANK LINE RETURN ZERO-LENGTH STRING
5204
5205 : GS4 SOURCE >IN ! DROP ;
5206 T{ GS4 123 456
5207 -> }T
5208
5209 \ ------------------------------------------------------------------------
5210 TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
5211
5212 : S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
5213     >R SWAP R@ = IF          \ MAKE SURE STRINGS HAVE SAME LENGTH
5214         R> ?DUP IF            \ IF NON-EMPTY STRINGS
5215         0 DO
5216         OVER C@ OVER C@ - IF
5217             2DROP <FALSE> UNLOOP EXIT THEN
5218         SWAP CHAR+ SWAP CHAR+
5219             LOOP
5220         THEN
5221         2DROP <TRUE>          \ IF WE GET HERE, STRINGS MATCH
5222     ELSE
5223         R> DROP 2DROP <FALSE>     \ LENGTHS MISMATCH
5224     THEN ;
5225
5226 : GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
5227 T{ GP1 -> <TRUE> }T
5228
5229 : GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
5230 T{ GP2 -> <TRUE> }T
5231
5232 : GP3  <# 1 0 # # #> S" 01" S= ;
5233 T{ GP3 -> <TRUE> }T
5234
5235 : GP4  <# 1 0 #S #> S" 1" S= ;
5236 T{ GP4 -> <TRUE> }T
5237
5238 24 CONSTANT MAX-BASE            \ BASE 2 .. 36
5239 : COUNT-BITS
5240     0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
5241 COUNT-BITS 2* CONSTANT #BITS-UD     \ NUMBER OF BITS IN UD
5242
5243 : GP5
5244     BASE @ <TRUE>
5245     MAX-BASE 1+ 2 DO         \ FOR EACH POSSIBLE BASE
5246         I BASE !              \ TBD: ASSUMES BASE WORKS
5247         I 0 <# #S #> S" 10" S= AND
5248     LOOP
5249     SWAP BASE ! ;
5250 T{ GP5 -> <TRUE> }T
5251
5252 : GP6
5253     BASE @ >R  2 BASE !
5254     MAX-UINT MAX-UINT <# #S #>       \ MAXIMUM UD TO BINARY
5255     R> BASE !                \ S: C-ADDR U
5256     DUP #BITS-UD = SWAP
5257     0 DO                 \ S: C-ADDR FLAG
5258         OVER C@ [CHAR] 1 = AND        \ ALL ONES
5259         >R CHAR+ R>
5260     LOOP SWAP DROP ;
5261 T{ GP6 -> <TRUE> }T
5262
5263 : GP7
5264     BASE @ >R    MAX-BASE BASE !
5265     <TRUE>
5266     A 0 DO
5267         I 0 <# #S #>
5268         1 = SWAP C@ I 30 + = AND AND
5269     LOOP
5270     MAX-BASE A DO
5271         I 0 <# #S #>
5272         1 = SWAP C@ 41 I A - + = AND AND
5273     LOOP
5274     R> BASE ! ;
5275
5276 T{ GP7 -> <TRUE> }T
5277
5278 \ >NUMBER TESTS
5279 CREATE GN-BUF 0 C,
5280 : GN-STRING GN-BUF 1 ;
5281 : GN-CONSUMED   GN-BUF CHAR+ 0 ;
5282 : GN'       [CHAR] ' WORD CHAR+ C@ GN-BUF C!  GN-STRING ;
5283
5284 T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T
5285 T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T
5286 T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T
5287 T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T   \ SHOULD FAIL TO CONVERT THESE
5288 T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T
5289 T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T
5290
5291 : >NUMBER-BASED
5292     BASE @ >R BASE ! >NUMBER R> BASE ! ;
5293
5294 T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T
5295 T{ 0 0 GN' 2'  2 >NUMBER-BASED -> 0 0 GN-STRING }T
5296 T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T
5297 T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T
5298 T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T
5299 T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T
5300
5301 : GN1   \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
5302     BASE @ >R BASE !
5303     <# #S #>
5304     0 0 2SWAP >NUMBER SWAP DROP      \ RETURN LENGTH ONLY
5305     R> BASE ! ;
5306 T{ 0 0 2 GN1 -> 0 0 0 }T
5307 T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
5308 T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
5309 T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T
5310 T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T
5311 T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T
5312
5313 : GN2   \ ( -- 16 10 )
5314     BASE @ >R  HEX BASE @  DECIMAL BASE @  R> BASE ! ;
5315 T{ GN2 -> 10 A }T
5316
5317 \ ------------------------------------------------------------------------
5318 TESTING FILL MOVE
5319
5320 CREATE FBUF 00 C, 00 C, 00 C,
5321 CREATE SBUF 12 C, 34 C, 56 C,
5322 : SEEBUF FBUF C@  FBUF CHAR+ C@  FBUF CHAR+ CHAR+ C@ ;
5323
5324 T{ FBUF 0 20 FILL -> }T
5325 T{ SEEBUF -> 00 00 00 }T
5326
5327 T{ FBUF 1 20 FILL -> }T
5328 T{ SEEBUF -> 20 00 00 }T
5329
5330 T{ FBUF 3 20 FILL -> }T
5331 T{ SEEBUF -> 20 20 20 }T
5332
5333 T{ FBUF FBUF 3 CHARS MOVE -> }T     \ BIZARRE SPECIAL CASE
5334 T{ SEEBUF -> 20 20 20 }T
5335
5336 T{ SBUF FBUF 0 CHARS MOVE -> }T
5337 T{ SEEBUF -> 20 20 20 }T
5338
5339 T{ SBUF FBUF 1 CHARS MOVE -> }T
5340 T{ SEEBUF -> 12 20 20 }T
5341
5342 T{ SBUF FBUF 3 CHARS MOVE -> }T
5343 T{ SEEBUF -> 12 34 56 }T
5344
5345 T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T
5346 T{ SEEBUF -> 12 12 34 }T
5347
5348 T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T
5349 T{ SEEBUF -> 12 34 34 }T
5350
5351 \ ------------------------------------------------------------------------
5352 TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
5353
5354 : OUTPUT-TEST
5355     ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
5356     41 BL DO I EMIT LOOP CR
5357     61 41 DO I EMIT LOOP CR
5358     7F 61 DO I EMIT LOOP CR
5359     ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
5360     9 1+ 0 DO I . LOOP CR
5361     ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
5362     [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
5363     ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
5364     [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
5365     ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
5366     5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
5367     ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
5368     S" LINE 1" TYPE CR S" LINE 2" TYPE CR
5369     ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
5370     ."   SIGNED: " MIN-INT . MAX-INT . CR
5371     ." UNSIGNED: " 0 U. MAX-UINT U. CR
5372 ;
5373
5374 T{ OUTPUT-TEST -> }T
5375 \ ------------------------------------------------------------------------
5376 TESTING INPUT: ACCEPT
5377
5378 CREATE ABUF 80 CHARS ALLOT
5379
5380 : ACCEPT-TEST
5381     CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
5382     ABUF 80 ACCEPT
5383     CR ." RECEIVED: " [CHAR] " EMIT
5384     ABUF SWAP TYPE [CHAR] " EMIT CR
5385 ;
5386
5387 T{ ACCEPT-TEST -> }T
5388 Vingt fois sur le métier remettez votre ouvrage, ...
5389 \ ------------------------------------------------------------------------
5390 TESTING DICTIONARY SEARCH RULES
5391
5392 T{ : GDX   123 ; : GDX   GDX 234 ; -> }T
5393
5394 T{ GDX -> 123 234 }T
5395
5396 CR .( End of Core word set tests) CR
5397
5398
5399
5400 RST_STATE   ; so ANS_COMPLEMENT_xx_MPY is conserved ;
5401 \ NOECHO      ; if an error occurs, comment this line before new download to find it.
5402
5403
5404 \ From: John Hayes S1I
5405 \ Subject: tester.fr
5406 \ Date: Mon, 27 Nov 95 13:10:09 PST
5407
5408 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
5409 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
5410 \ VERSION 1.1
5411
5412 \ 22/1/09 The words { and } have been changed to T{ and }T respectively to
5413 \ agree with the Forth 200X file ttester.fs. This avoids clashes with
5414 \ locals using { ... } and the FSL use of }
5415
5416
5417 \ 13/05/14 jmt. added colorised error messages.
5418
5419
5420
5421  0 CONSTANT FALSE
5422 -1 CONSTANT TRUE
5423
5424 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
5425 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
5426 VARIABLE VERBOSE
5427     FALSE VERBOSE !
5428 \   TRUE VERBOSE !
5429
5430 \ : EMPTY-STACK ( ... -- )  \ EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
5431 \     DEPTH ?DUP
5432 \             IF DUP 0< IF NEGATE 0
5433 \             DO 0 LOOP
5434 \             ELSE 0 DO DROP LOOP THEN
5435 \             THEN ;
5436 \
5437 \ : ERROR     \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
5438 \         \ THE LINE THAT HAD THE ERROR.
5439 \     TYPE SOURCE TYPE CR          \ DISPLAY LINE CORRESPONDING TO ERROR
5440 \     EMPTY-STACK              \ THROW AWAY EVERY THING ELSE
5441 \     QUIT  \ *** Uncomment this line to QUIT on an error
5442 \ ;
5443
5444 VARIABLE ACTUAL-DEPTH           \ STACK RECORD
5445 CREATE ACTUAL-RESULTS 20 CELLS ALLOT
5446
5447 : T{        \ ( -- ) SYNTACTIC SUGAR.
5448     ;
5449
5450 : ->        \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
5451     DEPTH DUP ACTUAL-DEPTH !     \ RECORD DEPTH
5452     ?DUP IF              \ IF THERE IS SOMETHING ON STACK
5453         0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
5454     THEN ;
5455
5456 : }T        \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
5457             \ (ACTUAL) CONTENTS.
5458     DEPTH ACTUAL-DEPTH @ = IF   \ IF DEPTHS MATCH
5459         DEPTH ?DUP IF           \ IF THERE IS SOMETHING ON THE STACK
5460         0 DO                    \ FOR EACH STACK ITEM
5461             ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
5462 \           = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN   \ jmt
5463             = 0= IF ABORT" INCORRECT RESULT: " THEN           \ jmt : colorised message
5464         LOOP
5465         THEN
5466     ELSE                 \ DEPTH MISMATCH
5467 \       S" WRONG NUMBER OF RESULTS: " ERROR \ jmt
5468         ABORT" WRONG NUMBER OF RESULTS: "   \ jmt : colorised message
5469     THEN ;
5470
5471 : TESTING   \ ( -- ) TALKING COMMENT.
5472     SOURCE VERBOSE @
5473     IF DUP >R TYPE CR R> >IN !
5474     ELSE >IN ! DROP [CHAR] * EMIT
5475     THEN ;
5476
5477 \ From: John Hayes S1I
5478 \ Subject: core.fr
5479 \ Date: Mon, 27 Nov 95 13:10
5480
5481 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
5482 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
5483 \ VERSION 1.2
5484 \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
5485 \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
5486 \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
5487 \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
5488 \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
5489 \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
5490
5491 CR
5492 TESTING CORE WORDS
5493 HEX
5494
5495 \ ------------------------------------------------------------------------
5496 TESTING BASIC ASSUMPTIONS
5497
5498 T{ -> }T                    \ START WITH CLEAN SLATE
5499 ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
5500 T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T
5501 T{  0 BITSSET? -> 0 }T      ( ZERO IS ALL BITS CLEAR )
5502 T{  1 BITSSET? -> 0 0 }T        ( OTHER NUMBER HAVE AT LEAST ONE BIT )
5503 T{ -1 BITSSET? -> 0 0 }T
5504
5505 \ ------------------------------------------------------------------------
5506 TESTING BOOLEANS: INVERT AND OR XOR
5507
5508 T{ 0 0 AND -> 0 }T
5509 T{ 0 1 AND -> 0 }T
5510 T{ 1 0 AND -> 0 }T
5511 T{ 1 1 AND -> 1 }T
5512
5513 T{ 0 INVERT 1 AND -> 1 }T
5514 T{ 1 INVERT 1 AND -> 0 }T
5515
5516 0    CONSTANT 0S
5517 0 INVERT CONSTANT 1S
5518
5519 T{ 0S INVERT -> 1S }T
5520 T{ 1S INVERT -> 0S }T
5521
5522 T{ 0S 0S AND -> 0S }T
5523 T{ 0S 1S AND -> 0S }T
5524 T{ 1S 0S AND -> 0S }T
5525 T{ 1S 1S AND -> 1S }T
5526
5527 T{ 0S 0S OR -> 0S }T
5528 T{ 0S 1S OR -> 1S }T
5529 T{ 1S 0S OR -> 1S }T
5530 T{ 1S 1S OR -> 1S }T
5531
5532 T{ 0S 0S XOR -> 0S }T
5533 T{ 0S 1S XOR -> 1S }T
5534 T{ 1S 0S XOR -> 1S }T
5535 T{ 1S 1S XOR -> 0S }T
5536
5537 \ ------------------------------------------------------------------------
5538 TESTING 2* 2/ LSHIFT RSHIFT
5539
5540 ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
5541 1S 1 RSHIFT INVERT CONSTANT MSB
5542 T{ MSB BITSSET? -> 0 0 }T
5543
5544 T{ 0S 2* -> 0S }T
5545 T{ 1 2* -> 2 }T
5546 T{ 4000 2* -> 8000 }T
5547 T{ 1S 2* 1 XOR -> 1S }T
5548 T{ MSB 2* -> 0S }T
5549
5550 T{ 0S 2/ -> 0S }T
5551 T{ 1 2/ -> 0 }T
5552 T{ 4000 2/ -> 2000 }T
5553 T{ 1S 2/ -> 1S }T               \ MSB PROPOGATED
5554 T{ 1S 1 XOR 2/ -> 1S }T
5555 T{ MSB 2/ MSB AND -> MSB }T
5556
5557 T{ 1 0 LSHIFT -> 1 }T
5558 T{ 1 1 LSHIFT -> 2 }T
5559 T{ 1 2 LSHIFT -> 4 }T
5560 T{ 1 F LSHIFT -> 8000 }T            \ BIGGEST GUARANTEED SHIFT
5561 T{ 1S 1 LSHIFT 1 XOR -> 1S }T
5562 T{ MSB 1 LSHIFT -> 0 }T
5563
5564 T{ 1 0 RSHIFT -> 1 }T
5565 T{ 1 1 RSHIFT -> 0 }T
5566 T{ 2 1 RSHIFT -> 1 }T
5567 T{ 4 2 RSHIFT -> 1 }T
5568 T{ 8000 F RSHIFT -> 1 }T            \ BIGGEST
5569 T{ MSB 1 RSHIFT MSB AND -> 0 }T     \ RSHIFT ZERO FILLS MSBS
5570 T{ MSB 1 RSHIFT 2* -> MSB }T
5571
5572 \ ------------------------------------------------------------------------
5573 TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
5574 0 INVERT            CONSTANT MAX-UINT
5575 0 INVERT 1 RSHIFT       CONSTANT MAX-INT
5576 0 INVERT 1 RSHIFT INVERT    CONSTANT MIN-INT
5577 0 INVERT 1 RSHIFT       CONSTANT MID-UINT
5578 0 INVERT 1 RSHIFT INVERT    CONSTANT MID-UINT+1
5579
5580 0S CONSTANT <FALSE>
5581 1S CONSTANT <TRUE>
5582
5583 T{ 0 0= -> <TRUE> }T
5584 T{ 1 0= -> <FALSE> }T
5585 T{ 2 0= -> <FALSE> }T
5586 T{ -1 0= -> <FALSE> }T
5587 T{ MAX-UINT 0= -> <FALSE> }T
5588 T{ MIN-INT 0= -> <FALSE> }T
5589 T{ MAX-INT 0= -> <FALSE> }T
5590
5591 T{ 0 0 = -> <TRUE> }T
5592 T{ 1 1 = -> <TRUE> }T
5593 T{ -1 -1 = -> <TRUE> }T
5594 T{ 1 0 = -> <FALSE> }T
5595 T{ -1 0 = -> <FALSE> }T
5596 T{ 0 1 = -> <FALSE> }T
5597 T{ 0 -1 = -> <FALSE> }T
5598
5599 T{ 0 0< -> <FALSE> }T
5600 T{ -1 0< -> <TRUE> }T
5601 T{ MIN-INT 0< -> <TRUE> }T
5602 T{ 1 0< -> <FALSE> }T
5603 T{ MAX-INT 0< -> <FALSE> }T
5604
5605 T{ 0 1 < -> <TRUE> }T
5606 T{ 1 2 < -> <TRUE> }T
5607 T{ -1 0 < -> <TRUE> }T
5608 T{ -1 1 < -> <TRUE> }T
5609 T{ MIN-INT 0 < -> <TRUE> }T
5610 T{ MIN-INT MAX-INT < -> <TRUE> }T
5611 T{ 0 MAX-INT < -> <TRUE> }T
5612 T{ 0 0 < -> <FALSE> }T
5613 T{ 1 1 < -> <FALSE> }T
5614 T{ 1 0 < -> <FALSE> }T
5615 T{ 2 1 < -> <FALSE> }T
5616 T{ 0 -1 < -> <FALSE> }T
5617 T{ 1 -1 < -> <FALSE> }T
5618 T{ 0 MIN-INT < -> <FALSE> }T
5619 T{ MAX-INT MIN-INT < -> <FALSE> }T
5620 T{ MAX-INT 0 < -> <FALSE> }T
5621
5622 T{ 0 1 > -> <FALSE> }T
5623 T{ 1 2 > -> <FALSE> }T
5624 T{ -1 0 > -> <FALSE> }T
5625 T{ -1 1 > -> <FALSE> }T
5626 T{ MIN-INT 0 > -> <FALSE> }T
5627 T{ MIN-INT MAX-INT > -> <FALSE> }T
5628 T{ 0 MAX-INT > -> <FALSE> }T
5629 T{ 0 0 > -> <FALSE> }T
5630 T{ 1 1 > -> <FALSE> }T
5631 T{ 1 0 > -> <TRUE> }T
5632 T{ 2 1 > -> <TRUE> }T
5633 T{ 0 -1 > -> <TRUE> }T
5634 T{ 1 -1 > -> <TRUE> }T
5635 T{ 0 MIN-INT > -> <TRUE> }T
5636 T{ MAX-INT MIN-INT > -> <TRUE> }T
5637 T{ MAX-INT 0 > -> <TRUE> }T
5638
5639 T{ 0 1 U< -> <TRUE> }T
5640 T{ 1 2 U< -> <TRUE> }T
5641 T{ 0 MID-UINT U< -> <TRUE> }T
5642 T{ 0 MAX-UINT U< -> <TRUE> }T
5643 T{ MID-UINT MAX-UINT U< -> <TRUE> }T
5644 T{ 0 0 U< -> <FALSE> }T
5645 T{ 1 1 U< -> <FALSE> }T
5646 T{ 1 0 U< -> <FALSE> }T
5647 T{ 2 1 U< -> <FALSE> }T
5648 T{ MID-UINT 0 U< -> <FALSE> }T
5649 T{ MAX-UINT 0 U< -> <FALSE> }T
5650 T{ MAX-UINT MID-UINT U< -> <FALSE> }T
5651
5652 T{ 0 1 MIN -> 0 }T
5653 T{ 1 2 MIN -> 1 }T
5654 T{ -1 0 MIN -> -1 }T
5655 T{ -1 1 MIN -> -1 }T
5656 T{ MIN-INT 0 MIN -> MIN-INT }T
5657 T{ MIN-INT MAX-INT MIN -> MIN-INT }T
5658 T{ 0 MAX-INT MIN -> 0 }T
5659 T{ 0 0 MIN -> 0 }T
5660 T{ 1 1 MIN -> 1 }T
5661 T{ 1 0 MIN -> 0 }T
5662 T{ 2 1 MIN -> 1 }T
5663 T{ 0 -1 MIN -> -1 }T
5664 T{ 1 -1 MIN -> -1 }T
5665 T{ 0 MIN-INT MIN -> MIN-INT }T
5666 T{ MAX-INT MIN-INT MIN -> MIN-INT }T
5667 T{ MAX-INT 0 MIN -> 0 }T
5668
5669 T{ 0 1 MAX -> 1 }T
5670 T{ 1 2 MAX -> 2 }T
5671 T{ -1 0 MAX -> 0 }T
5672 T{ -1 1 MAX -> 1 }T
5673 T{ MIN-INT 0 MAX -> 0 }T
5674 T{ MIN-INT MAX-INT MAX -> MAX-INT }T
5675 T{ 0 MAX-INT MAX -> MAX-INT }T
5676 T{ 0 0 MAX -> 0 }T
5677 T{ 1 1 MAX -> 1 }T
5678 T{ 1 0 MAX -> 1 }T
5679 T{ 2 1 MAX -> 2 }T
5680 T{ 0 -1 MAX -> 0 }T
5681 T{ 1 -1 MAX -> 1 }T
5682 T{ 0 MIN-INT MAX -> 0 }T
5683 T{ MAX-INT MIN-INT MAX -> MAX-INT }T
5684 T{ MAX-INT 0 MAX -> MAX-INT }T
5685
5686 \ ------------------------------------------------------------------------
5687 TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
5688
5689 T{ 1 2 2DROP -> }T
5690 T{ 1 2 2DUP -> 1 2 1 2 }T
5691 T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T
5692 T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T
5693 T{ 0 ?DUP -> 0 }T
5694 T{ 1 ?DUP -> 1 1 }T
5695 T{ -1 ?DUP -> -1 -1 }T
5696 T{ DEPTH -> 0 }T
5697 T{ 0 DEPTH -> 0 1 }T
5698 T{ 0 1 DEPTH -> 0 1 2 }T
5699 T{ 0 DROP -> }T
5700 T{ 1 2 DROP -> 1 }T
5701 T{ 1 DUP -> 1 1 }T
5702 T{ 1 2 OVER -> 1 2 1 }T
5703 T{ 1 2 3 ROT -> 2 3 1 }T
5704 T{ 1 2 SWAP -> 2 1 }T
5705
5706 \ ------------------------------------------------------------------------
5707 TESTING >R R> R@
5708
5709 T{ : GR1 >R R> ; -> }T
5710 T{ : GR2 >R R@ R> DROP ; -> }T
5711 T{ 123 GR1 -> 123 }T
5712 T{ 123 GR2 -> 123 }T
5713 T{ 1S GR1 -> 1S }T   ( RETURN STACK HOLDS CELLS )
5714
5715 \ ------------------------------------------------------------------------
5716 TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
5717
5718 T{ 0 5 + -> 5 }T
5719 T{ 5 0 + -> 5 }T
5720 T{ 0 -5 + -> -5 }T
5721 T{ -5 0 + -> -5 }T
5722 T{ 1 2 + -> 3 }T
5723 T{ 1 -2 + -> -1 }T
5724 T{ -1 2 + -> 1 }T
5725 T{ -1 -2 + -> -3 }T
5726 T{ -1 1 + -> 0 }T
5727 T{ MID-UINT 1 + -> MID-UINT+1 }T
5728
5729 T{ 0 5 - -> -5 }T
5730 T{ 5 0 - -> 5 }T
5731 T{ 0 -5 - -> 5 }T
5732 T{ -5 0 - -> -5 }T
5733 T{ 1 2 - -> -1 }T
5734 T{ 1 -2 - -> 3 }T
5735 T{ -1 2 - -> -3 }T
5736 T{ -1 -2 - -> 1 }T
5737 T{ 0 1 - -> -1 }T
5738 T{ MID-UINT+1 1 - -> MID-UINT }T
5739
5740 T{ 0 1+ -> 1 }T
5741 T{ -1 1+ -> 0 }T
5742 T{ 1 1+ -> 2 }T
5743 T{ MID-UINT 1+ -> MID-UINT+1 }T
5744
5745 T{ 2 1- -> 1 }T
5746 T{ 1 1- -> 0 }T
5747 T{ 0 1- -> -1 }T
5748 T{ MID-UINT+1 1- -> MID-UINT }T
5749
5750 T{ 0 NEGATE -> 0 }T
5751 T{ 1 NEGATE -> -1 }T
5752 T{ -1 NEGATE -> 1 }T
5753 T{ 2 NEGATE -> -2 }T
5754 T{ -2 NEGATE -> 2 }T
5755
5756 T{ 0 ABS -> 0 }T
5757 T{ 1 ABS -> 1 }T
5758 T{ -1 ABS -> 1 }T
5759 T{ MIN-INT ABS -> MID-UINT+1 }T
5760
5761 \ ------------------------------------------------------------------------
5762 TESTING MULTIPLY: S>D * M* UM*
5763
5764 T{ 0 S>D -> 0 0 }T
5765 T{ 1 S>D -> 1 0 }T
5766 T{ 2 S>D -> 2 0 }T
5767 T{ -1 S>D -> -1 -1 }T
5768 T{ -2 S>D -> -2 -1 }T
5769 T{ MIN-INT S>D -> MIN-INT -1 }T
5770 T{ MAX-INT S>D -> MAX-INT 0 }T
5771
5772 T{ 0 0 M* -> 0 S>D }T
5773 T{ 0 1 M* -> 0 S>D }T
5774 T{ 1 0 M* -> 0 S>D }T
5775 T{ 1 2 M* -> 2 S>D }T
5776 T{ 2 1 M* -> 2 S>D }T
5777 T{ 3 3 M* -> 9 S>D }T
5778 T{ -3 3 M* -> -9 S>D }T
5779 T{ 3 -3 M* -> -9 S>D }T
5780 T{ -3 -3 M* -> 9 S>D }T
5781 T{ 0 MIN-INT M* -> 0 S>D }T
5782 T{ 1 MIN-INT M* -> MIN-INT S>D }T
5783 T{ 2 MIN-INT M* -> 0 1S }T
5784 T{ 0 MAX-INT M* -> 0 S>D }T
5785 T{ 1 MAX-INT M* -> MAX-INT S>D }T
5786 T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T
5787 T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T
5788 T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T
5789 T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T
5790
5791 T{ 0 0 * -> 0 }T                \ TEST IDENTITIES
5792 T{ 0 1 * -> 0 }T
5793 T{ 1 0 * -> 0 }T
5794 T{ 1 2 * -> 2 }T
5795 T{ 2 1 * -> 2 }T
5796 T{ 3 3 * -> 9 }T
5797 T{ -3 3 * -> -9 }T
5798 T{ 3 -3 * -> -9 }T
5799 T{ -3 -3 * -> 9 }T
5800
5801 T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T
5802 T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T
5803 T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T
5804
5805 T{ 0 0 UM* -> 0 0 }T
5806 T{ 0 1 UM* -> 0 0 }T
5807 T{ 1 0 UM* -> 0 0 }T
5808 T{ 1 2 UM* -> 2 0 }T
5809 T{ 2 1 UM* -> 2 0 }T
5810 T{ 3 3 UM* -> 9 0 }T
5811
5812 T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T
5813 T{ MID-UINT+1 2 UM* -> 0 1 }T
5814 T{ MID-UINT+1 4 UM* -> 0 2 }T
5815 T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T
5816 T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T
5817
5818 \ ------------------------------------------------------------------------
5819 TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
5820
5821 T{ 0 S>D 1 FM/MOD -> 0 0 }T
5822 T{ 1 S>D 1 FM/MOD -> 0 1 }T
5823 T{ 2 S>D 1 FM/MOD -> 0 2 }T
5824 T{ -1 S>D 1 FM/MOD -> 0 -1 }T
5825 T{ -2 S>D 1 FM/MOD -> 0 -2 }T
5826 T{ 0 S>D -1 FM/MOD -> 0 0 }T
5827 T{ 1 S>D -1 FM/MOD -> 0 -1 }T
5828 T{ 2 S>D -1 FM/MOD -> 0 -2 }T
5829 T{ -1 S>D -1 FM/MOD -> 0 1 }T
5830 T{ -2 S>D -1 FM/MOD -> 0 2 }T
5831 T{ 2 S>D 2 FM/MOD -> 0 1 }T
5832 T{ -1 S>D -1 FM/MOD -> 0 1 }T
5833 T{ -2 S>D -2 FM/MOD -> 0 1 }T
5834 T{  7 S>D  3 FM/MOD -> 1 2 }T
5835 T{  7 S>D -3 FM/MOD -> -2 -3 }T
5836 T{ -7 S>D  3 FM/MOD -> 2 -3 }T
5837 T{ -7 S>D -3 FM/MOD -> -1 2 }T
5838 T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T
5839 T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T
5840 T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T
5841 T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T
5842 T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T
5843 T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T
5844 T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T
5845 T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T
5846 T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T
5847 T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T
5848 T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T
5849 T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T
5850 T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T
5851 T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T
5852 T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T
5853 T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T
5854 T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T
5855
5856 T{ 0 S>D 1 SM/REM -> 0 0 }T
5857 T{ 1 S>D 1 SM/REM -> 0 1 }T
5858 T{ 2 S>D 1 SM/REM -> 0 2 }T
5859 T{ -1 S>D 1 SM/REM -> 0 -1 }T
5860 T{ -2 S>D 1 SM/REM -> 0 -2 }T
5861 T{ 0 S>D -1 SM/REM -> 0 0 }T
5862 T{ 1 S>D -1 SM/REM -> 0 -1 }T
5863 T{ 2 S>D -1 SM/REM -> 0 -2 }T
5864 T{ -1 S>D -1 SM/REM -> 0 1 }T
5865 T{ -2 S>D -1 SM/REM -> 0 2 }T
5866 T{ 2 S>D 2 SM/REM -> 0 1 }T
5867 T{ -1 S>D -1 SM/REM -> 0 1 }T
5868 T{ -2 S>D -2 SM/REM -> 0 1 }T
5869 T{  7 S>D  3 SM/REM -> 1 2 }T
5870 T{  7 S>D -3 SM/REM -> 1 -2 }T
5871 T{ -7 S>D  3 SM/REM -> -1 -2 }T
5872 T{ -7 S>D -3 SM/REM -> -1 2 }T
5873 T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T
5874 T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T
5875 T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T
5876 T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T
5877 T{ 1S 1 4 SM/REM -> 3 MAX-INT }T
5878 T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T
5879 T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T
5880 T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T
5881 T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T
5882 T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T
5883 T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T
5884 T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T
5885 T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T
5886
5887 T{ 0 0 1 UM/MOD -> 0 0 }T
5888 T{ 1 0 1 UM/MOD -> 0 1 }T
5889 T{ 1 0 2 UM/MOD -> 1 0 }T
5890 T{ 3 0 2 UM/MOD -> 1 1 }T
5891 T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T
5892 T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T
5893 T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T
5894
5895 : IFFLOORED
5896     [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
5897
5898 : IFSYM
5899     [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
5900
5901 \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
5902 \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
5903
5904 IFFLOORED : T/MOD  >R S>D R> FM/MOD ;
5905 IFFLOORED : T/     T/MOD SWAP DROP ;
5906 IFFLOORED : TMOD   T/MOD DROP ;
5907 IFFLOORED : T*/MOD >R M* R> FM/MOD ;
5908 IFFLOORED : T*/    T*/MOD SWAP DROP ;
5909 IFSYM     : T/MOD  >R S>D R> SM/REM ;
5910 IFSYM     : T/     T/MOD SWAP DROP ;
5911 IFSYM     : TMOD   T/MOD DROP ;
5912 IFSYM     : T*/MOD >R M* R> SM/REM ;
5913 IFSYM     : T*/    T*/MOD SWAP DROP ;
5914
5915 T{ 0 1 /MOD -> 0 1 T/MOD }T
5916 T{ 1 1 /MOD -> 1 1 T/MOD }T
5917 T{ 2 1 /MOD -> 2 1 T/MOD }T
5918 T{ -1 1 /MOD -> -1 1 T/MOD }T
5919 T{ -2 1 /MOD -> -2 1 T/MOD }T
5920 T{ 0 -1 /MOD -> 0 -1 T/MOD }T
5921 T{ 1 -1 /MOD -> 1 -1 T/MOD }T
5922 T{ 2 -1 /MOD -> 2 -1 T/MOD }T
5923 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
5924 T{ -2 -1 /MOD -> -2 -1 T/MOD }T
5925 T{ 2 2 /MOD -> 2 2 T/MOD }T
5926 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
5927 T{ -2 -2 /MOD -> -2 -2 T/MOD }T
5928 T{ 7 3 /MOD -> 7 3 T/MOD }T
5929 T{ 7 -3 /MOD -> 7 -3 T/MOD }T
5930 T{ -7 3 /MOD -> -7 3 T/MOD }T
5931 T{ -7 -3 /MOD -> -7 -3 T/MOD }T
5932 T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T
5933 T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T
5934 T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T
5935 T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T
5936
5937 T{ 0 1 / -> 0 1 T/ }T
5938 T{ 1 1 / -> 1 1 T/ }T
5939 T{ 2 1 / -> 2 1 T/ }T
5940 T{ -1 1 / -> -1 1 T/ }T
5941 T{ -2 1 / -> -2 1 T/ }T
5942 T{ 0 -1 / -> 0 -1 T/ }T
5943 T{ 1 -1 / -> 1 -1 T/ }T
5944 T{ 2 -1 / -> 2 -1 T/ }T
5945 T{ -1 -1 / -> -1 -1 T/ }T
5946 T{ -2 -1 / -> -2 -1 T/ }T
5947 T{ 2 2 / -> 2 2 T/ }T
5948 T{ -1 -1 / -> -1 -1 T/ }T
5949 T{ -2 -2 / -> -2 -2 T/ }T
5950 T{ 7 3 / -> 7 3 T/ }T
5951 T{ 7 -3 / -> 7 -3 T/ }T
5952 T{ -7 3 / -> -7 3 T/ }T
5953 T{ -7 -3 / -> -7 -3 T/ }T
5954 T{ MAX-INT 1 / -> MAX-INT 1 T/ }T
5955 T{ MIN-INT 1 / -> MIN-INT 1 T/ }T
5956 T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T
5957 T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T
5958
5959 T{ 0 1 MOD -> 0 1 TMOD }T
5960 T{ 1 1 MOD -> 1 1 TMOD }T
5961 T{ 2 1 MOD -> 2 1 TMOD }T
5962 T{ -1 1 MOD -> -1 1 TMOD }T
5963 T{ -2 1 MOD -> -2 1 TMOD }T
5964 T{ 0 -1 MOD -> 0 -1 TMOD }T
5965 T{ 1 -1 MOD -> 1 -1 TMOD }T
5966 T{ 2 -1 MOD -> 2 -1 TMOD }T
5967 T{ -1 -1 MOD -> -1 -1 TMOD }T
5968 T{ -2 -1 MOD -> -2 -1 TMOD }T
5969 T{ 2 2 MOD -> 2 2 TMOD }T
5970 T{ -1 -1 MOD -> -1 -1 TMOD }T
5971 T{ -2 -2 MOD -> -2 -2 TMOD }T
5972 T{ 7 3 MOD -> 7 3 TMOD }T
5973 T{ 7 -3 MOD -> 7 -3 TMOD }T
5974 T{ -7 3 MOD -> -7 3 TMOD }T
5975 T{ -7 -3 MOD -> -7 -3 TMOD }T
5976 T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T
5977 T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T
5978 T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T
5979 T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T
5980
5981 T{ 0 2 1 */ -> 0 2 1 T*/ }T
5982 T{ 1 2 1 */ -> 1 2 1 T*/ }T
5983 T{ 2 2 1 */ -> 2 2 1 T*/ }T
5984 T{ -1 2 1 */ -> -1 2 1 T*/ }T
5985 T{ -2 2 1 */ -> -2 2 1 T*/ }T
5986 T{ 0 2 -1 */ -> 0 2 -1 T*/ }T
5987 T{ 1 2 -1 */ -> 1 2 -1 T*/ }T
5988 T{ 2 2 -1 */ -> 2 2 -1 T*/ }T
5989 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
5990 T{ -2 2 -1 */ -> -2 2 -1 T*/ }T
5991 T{ 2 2 2 */ -> 2 2 2 T*/ }T
5992 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
5993 T{ -2 2 -2 */ -> -2 2 -2 T*/ }T
5994 T{ 7 2 3 */ -> 7 2 3 T*/ }T
5995 T{ 7 2 -3 */ -> 7 2 -3 T*/ }T
5996 T{ -7 2 3 */ -> -7 2 3 T*/ }T
5997 T{ -7 2 -3 */ -> -7 2 -3 T*/ }T
5998 T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T
5999 T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T
6000
6001 T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T
6002 T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T
6003 T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T
6004 T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T
6005 T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T
6006 T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T
6007 T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T
6008 T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T
6009 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
6010 T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T
6011 T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T
6012 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
6013 T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T
6014 T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T
6015 T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T
6016 T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T
6017 T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T
6018 T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T
6019 T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T
6020
6021 \ ------------------------------------------------------------------------
6022 TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
6023
6024 HERE 1 ALLOT
6025 HERE
6026 CONSTANT 2NDA
6027 CONSTANT 1STA
6028 T{ 1STA 2NDA U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
6029 T{ 1STA 1+ -> 2NDA }T           \ ... BY ONE ADDRESS UNIT
6030 ( MISSING TEST: NEGATIVE ALLOT )
6031
6032 HERE 1 ,
6033 HERE 2 ,
6034 CONSTANT 2ND
6035 CONSTANT 1ST
6036 T{ 1ST 2ND U< -> <TRUE> }T          \ HERE MUST GROW WITH ALLOT
6037 T{ 1ST CELL+ -> 2ND }T          \ ... BY ONE CELL
6038 T{ 1ST 1 CELLS + -> 2ND }T
6039 T{ 1ST @ 2ND @ -> 1 2 }T
6040 T{ 5 1ST ! -> }T
6041 T{ 1ST @ 2ND @ -> 5 2 }T
6042 T{ 6 2ND ! -> }T
6043 T{ 1ST @ 2ND @ -> 5 6 }T
6044 T{ 1ST 2@ -> 6 5 }T
6045 T{ 2 1 1ST 2! -> }T
6046 T{ 1ST 2@ -> 2 1 }T
6047 T{ 1S 1ST !  1ST @ -> 1S }T     \ CAN STORE CELL-WIDE VALUE
6048
6049 HERE 1 C,
6050 HERE 2 C,
6051 CONSTANT 2NDC
6052 CONSTANT 1STC
6053 T{ 1STC 2NDC U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
6054 T{ 1STC CHAR+ -> 2NDC }T            \ ... BY ONE CHAR
6055 T{ 1STC 1 CHARS + -> 2NDC }T
6056 T{ 1STC C@ 2NDC C@ -> 1 2 }T
6057 T{ 3 1STC C! -> }T
6058 T{ 1STC C@ 2NDC C@ -> 3 2 }T
6059 T{ 4 2NDC C! -> }T
6060 T{ 1STC C@ 2NDC C@ -> 3 4 }T
6061
6062 ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
6063 CONSTANT A-ADDR  CONSTANT UA-ADDR
6064 T{ UA-ADDR ALIGNED -> A-ADDR }T
6065 T{    1 A-ADDR C!  A-ADDR C@ ->    1 }T
6066 T{ 1234 A-ADDR  !  A-ADDR  @ -> 1234 }T
6067 T{ 123 456 A-ADDR 2!  A-ADDR 2@ -> 123 456 }T
6068 T{ 2 A-ADDR CHAR+ C!  A-ADDR CHAR+ C@ -> 2 }T
6069 T{ 3 A-ADDR CELL+ C!  A-ADDR CELL+ C@ -> 3 }T
6070 T{ 1234 A-ADDR CELL+ !  A-ADDR CELL+ @ -> 1234 }T
6071 T{ 123 456 A-ADDR CELL+ 2!  A-ADDR CELL+ 2@ -> 123 456 }T
6072
6073 : BITS ( X -- U )
6074     0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
6075 ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
6076 T{ 1 CHARS 1 < -> <FALSE> }T
6077 T{ 1 CHARS 1 CELLS > -> <FALSE> }T
6078 ( TBD: HOW TO FIND NUMBER OF BITS? )
6079
6080 ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
6081 T{ 1 CELLS 1 < -> <FALSE> }T
6082 T{ 1 CELLS 1 CHARS MOD -> 0 }T
6083 T{ 1S BITS 10 < -> <FALSE> }T
6084
6085 T{ 0 1ST ! -> }T
6086 T{ 1 1ST +! -> }T
6087 T{ 1ST @ -> 1 }T
6088 T{ -1 1ST +! 1ST @ -> 0 }T
6089
6090 \ ------------------------------------------------------------------------
6091 TESTING CHAR [CHAR] [ ] BL S"
6092
6093 T{ BL -> 20 }T
6094 T{ CHAR X -> 58 }T
6095 T{ CHAR HELLO -> 48 }T
6096 T{ : GC1 [CHAR] X ; -> }T
6097 T{ : GC2 [CHAR] HELLO ; -> }T
6098 T{ GC1 -> 58 }T
6099 T{ GC2 -> 48 }T
6100 T{ : GC3 [ GC1 ] LITERAL ; -> }T
6101 T{ GC3 -> 58 }T
6102 T{ : GC4 S" XY" ; -> }T
6103 T{ GC4 SWAP DROP -> 2 }T
6104 T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T
6105
6106 \ ------------------------------------------------------------------------
6107 TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
6108
6109 T{ : GT1 123 ; -> }T
6110 T{ ' GT1 EXECUTE -> 123 }T
6111 T{ : GT2 ['] GT1 ; IMMEDIATE -> }T
6112 T{ GT2 EXECUTE -> 123 }T
6113 HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
6114 HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
6115 T{ GT1STRING FIND -> ' GT1 -1 }T
6116 T{ GT2STRING FIND -> ' GT2 1 }T
6117 ( HOW TO SEARCH FOR NON-EXISTENT WORD? )
6118 T{ : GT3 GT2 LITERAL ; -> }T
6119 T{ GT3 -> ' GT1 }T
6120 T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T
6121
6122 T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T
6123 T{ : GT5 GT4 ; -> }T
6124 T{ GT5 -> 123 }T
6125 T{ : GT6 345 ; IMMEDIATE -> }T
6126 T{ : GT7 POSTPONE GT6 ; -> }T
6127 T{ GT7 -> 345 }T
6128
6129 T{ : GT8 STATE @ ; IMMEDIATE -> }T
6130 T{ GT8 -> 0 }T
6131 T{ : GT9 GT8 LITERAL ; -> }T
6132 T{ GT9 0= -> <FALSE> }T
6133
6134 \ ------------------------------------------------------------------------
6135 TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
6136
6137 T{ : GI1 IF 123 THEN ; -> }T
6138 T{ : GI2 IF 123 ELSE 234 THEN ; -> }T
6139 T{ 0 GI1 -> }T
6140 T{ 1 GI1 -> 123 }T
6141 T{ -1 GI1 -> 123 }T
6142 T{ 0 GI2 -> 234 }T
6143 T{ 1 GI2 -> 123 }T
6144 T{ -1 GI1 -> 123 }T
6145
6146 T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T
6147 T{ 0 GI3 -> 0 1 2 3 4 5 }T
6148 T{ 4 GI3 -> 4 5 }T
6149 T{ 5 GI3 -> 5 }T
6150 T{ 6 GI3 -> 6 }T
6151
6152 T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T
6153 T{ 3 GI4 -> 3 4 5 6 }T
6154 T{ 5 GI4 -> 5 6 }T
6155 T{ 6 GI4 -> 6 7 }T
6156
6157 T{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T
6158 T{ 1 GI5 -> 1 345 }T
6159 T{ 2 GI5 -> 2 345 }T
6160 T{ 3 GI5 -> 3 4 5 123 }T
6161 T{ 4 GI5 -> 4 5 123 }T
6162 T{ 5 GI5 -> 5 123 }T
6163
6164 T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T
6165 T{ 0 GI6 -> 0 }T
6166 T{ 1 GI6 -> 0 1 }T
6167 T{ 2 GI6 -> 0 1 2 }T
6168 T{ 3 GI6 -> 0 1 2 3 }T
6169 T{ 4 GI6 -> 0 1 2 3 4 }T
6170
6171 \ ------------------------------------------------------------------------
6172 TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
6173
6174 T{ : GD1 DO I LOOP ; -> }T
6175 T{ 4 1 GD1 -> 1 2 3 }T
6176 T{ 2 -1 GD1 -> -1 0 1 }T
6177 T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T
6178
6179 T{ : GD2 DO I -1 +LOOP ; -> }T
6180 T{ 1 4 GD2 -> 4 3 2 1 }T
6181 T{ -1 2 GD2 -> 2 1 0 -1 }T
6182 T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T
6183
6184 T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T
6185 T{ 4 1 GD3 -> 1 2 3 }T
6186 T{ 2 -1 GD3 -> -1 0 1 }T
6187 T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T
6188
6189 T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T
6190 T{ 1 4 GD4 -> 4 3 2 1 }T
6191 T{ -1 2 GD4 -> 2 1 0 -1 }T
6192 T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T
6193
6194 T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T
6195 T{ 1 GD5 -> 123 }T
6196 T{ 5 GD5 -> 123 }T
6197 T{ 6 GD5 -> 234 }T
6198
6199 T{ : GD6  ( PAT: T{0 0}T,T{0 0}TT{1 0}TT{1 1}T,T{0 0}TT{1 0}TT{1 1}TT{2 0}TT{2 1}TT{2 2}T )
6200     0 SWAP 0 DO
6201         I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
6202     LOOP ; -> }T
6203 T{ 1 GD6 -> 1 }T
6204 T{ 2 GD6 -> 3 }T
6205 T{ 3 GD6 -> 4 1 2 }T
6206
6207 \ ------------------------------------------------------------------------
6208 TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
6209
6210 T{ 123 CONSTANT X123 -> }T
6211 T{ X123 -> 123 }T
6212 T{ : EQU CONSTANT ; -> }T
6213 T{ X123 EQU Y123 -> }T
6214 T{ Y123 -> 123 }T
6215
6216 T{ VARIABLE V1 -> }T
6217 T{ 123 V1 ! -> }T
6218 T{ V1 @ -> 123 }T
6219
6220 T{ : NOP : POSTPONE ; ; -> }T
6221 T{ NOP NOP1 NOP NOP2 -> }T
6222 T{ NOP1 -> }T
6223 T{ NOP2 -> }T
6224
6225 T{ : DOES1 DOES> @ 1 + ; -> }T
6226 T{ : DOES2 DOES> @ 2 + ; -> }T
6227 T{ CREATE CR1 -> }T
6228 T{ CR1 -> HERE }T
6229 T{ ' CR1 >BODY -> HERE }T
6230 T{ 1 , -> }T
6231 T{ CR1 @ -> 1 }T
6232 T{ DOES1 -> }T
6233 T{ CR1 -> 2 }T
6234 T{ DOES2 -> }T
6235 T{ CR1 -> 3 }T
6236
6237 T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T
6238 T{ WEIRD: W1 -> }T
6239 T{ ' W1 >BODY -> HERE }T
6240 T{ W1 -> HERE 1 + }T
6241 T{ W1 -> HERE 2 + }T
6242
6243 \ ------------------------------------------------------------------------
6244 TESTING EVALUATE
6245
6246 : GE1 S" 123" ; IMMEDIATE
6247 : GE2 S" 123 1+" ; IMMEDIATE
6248 : GE3 S" : GE4 345 ;" ;
6249 : GE5 EVALUATE ; IMMEDIATE
6250
6251 T{ GE1 EVALUATE -> 123 }T           ( TEST EVALUATE IN INTERP. STATE )
6252 T{ GE2 EVALUATE -> 124 }T
6253 T{ GE3 EVALUATE -> }T
6254 T{ GE4 -> 345 }T
6255
6256 T{ : GE6 GE1 GE5 ; -> }T            ( TEST EVALUATE IN COMPILE STATE )
6257 T{ GE6 -> 123 }T
6258 T{ : GE7 GE2 GE5 ; -> }T
6259 T{ GE7 -> 124 }T
6260
6261 \ ------------------------------------------------------------------------
6262 TESTING SOURCE >IN WORD
6263
6264 : GS1 S" SOURCE" 2DUP EVALUATE
6265         >R SWAP >R = R> R> = ;
6266 T{ GS1 -> <TRUE> <TRUE> }T
6267
6268 VARIABLE SCANS
6269 : RESCAN?  -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
6270
6271 T{ 2 SCANS !
6272 345 RESCAN?
6273 -> 345 345 }T
6274
6275 : GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
6276 T{ GS2 -> 123 123 123 123 123 }T
6277
6278 : GS3 WORD COUNT SWAP C@ ;
6279 T{ BL GS3 HELLO -> 5 CHAR H }T
6280 T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T
6281 T{ BL GS3
6282 DROP -> 0 }T                \ BLANK LINE RETURN ZERO-LENGTH STRING
6283
6284 : GS4 SOURCE >IN ! DROP ;
6285 T{ GS4 123 456
6286 -> }T
6287
6288 \ ------------------------------------------------------------------------
6289 TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
6290
6291 : S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
6292     >R SWAP R@ = IF          \ MAKE SURE STRINGS HAVE SAME LENGTH
6293         R> ?DUP IF            \ IF NON-EMPTY STRINGS
6294         0 DO
6295         OVER C@ OVER C@ - IF
6296             2DROP <FALSE> UNLOOP EXIT THEN
6297         SWAP CHAR+ SWAP CHAR+
6298             LOOP
6299         THEN
6300         2DROP <TRUE>          \ IF WE GET HERE, STRINGS MATCH
6301     ELSE
6302         R> DROP 2DROP <FALSE>     \ LENGTHS MISMATCH
6303     THEN ;
6304
6305 : GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
6306 T{ GP1 -> <TRUE> }T
6307
6308 : GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
6309 T{ GP2 -> <TRUE> }T
6310
6311 : GP3  <# 1 0 # # #> S" 01" S= ;
6312 T{ GP3 -> <TRUE> }T
6313
6314 : GP4  <# 1 0 #S #> S" 1" S= ;
6315 T{ GP4 -> <TRUE> }T
6316
6317 24 CONSTANT MAX-BASE            \ BASE 2 .. 36
6318 : COUNT-BITS
6319     0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
6320 COUNT-BITS 2* CONSTANT #BITS-UD     \ NUMBER OF BITS IN UD
6321
6322 : GP5
6323     BASE @ <TRUE>
6324     MAX-BASE 1+ 2 DO         \ FOR EACH POSSIBLE BASE
6325         I BASE !              \ TBD: ASSUMES BASE WORKS
6326         I 0 <# #S #> S" 10" S= AND
6327     LOOP
6328     SWAP BASE ! ;
6329 T{ GP5 -> <TRUE> }T
6330
6331 : GP6
6332     BASE @ >R  2 BASE !
6333     MAX-UINT MAX-UINT <# #S #>       \ MAXIMUM UD TO BINARY
6334     R> BASE !                \ S: C-ADDR U
6335     DUP #BITS-UD = SWAP
6336     0 DO                 \ S: C-ADDR FLAG
6337         OVER C@ [CHAR] 1 = AND        \ ALL ONES
6338         >R CHAR+ R>
6339     LOOP SWAP DROP ;
6340 T{ GP6 -> <TRUE> }T
6341
6342 : GP7
6343     BASE @ >R    MAX-BASE BASE !
6344     <TRUE>
6345     A 0 DO
6346         I 0 <# #S #>
6347         1 = SWAP C@ I 30 + = AND AND
6348     LOOP
6349     MAX-BASE A DO
6350         I 0 <# #S #>
6351         1 = SWAP C@ 41 I A - + = AND AND
6352     LOOP
6353     R> BASE ! ;
6354
6355 T{ GP7 -> <TRUE> }T
6356
6357 \ >NUMBER TESTS
6358 CREATE GN-BUF 0 C,
6359 : GN-STRING GN-BUF 1 ;
6360 : GN-CONSUMED   GN-BUF CHAR+ 0 ;
6361 : GN'       [CHAR] ' WORD CHAR+ C@ GN-BUF C!  GN-STRING ;
6362
6363 T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T
6364 T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T
6365 T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T
6366 T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T   \ SHOULD FAIL TO CONVERT THESE
6367 T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T
6368 T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T
6369
6370 : >NUMBER-BASED
6371     BASE @ >R BASE ! >NUMBER R> BASE ! ;
6372
6373 T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T
6374 T{ 0 0 GN' 2'  2 >NUMBER-BASED -> 0 0 GN-STRING }T
6375 T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T
6376 T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T
6377 T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T
6378 T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T
6379
6380 : GN1   \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
6381     BASE @ >R BASE !
6382     <# #S #>
6383     0 0 2SWAP >NUMBER SWAP DROP      \ RETURN LENGTH ONLY
6384     R> BASE ! ;
6385 T{ 0 0 2 GN1 -> 0 0 0 }T
6386 T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
6387 T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
6388 T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T
6389 T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T
6390 T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T
6391
6392 : GN2   \ ( -- 16 10 )
6393     BASE @ >R  HEX BASE @  DECIMAL BASE @  R> BASE ! ;
6394 T{ GN2 -> 10 A }T
6395
6396 \ ------------------------------------------------------------------------
6397 TESTING FILL MOVE
6398
6399 CREATE FBUF 00 C, 00 C, 00 C,
6400 CREATE SBUF 12 C, 34 C, 56 C,
6401 : SEEBUF FBUF C@  FBUF CHAR+ C@  FBUF CHAR+ CHAR+ C@ ;
6402
6403 T{ FBUF 0 20 FILL -> }T
6404 T{ SEEBUF -> 00 00 00 }T
6405
6406 T{ FBUF 1 20 FILL -> }T
6407 T{ SEEBUF -> 20 00 00 }T
6408
6409 T{ FBUF 3 20 FILL -> }T
6410 T{ SEEBUF -> 20 20 20 }T
6411
6412 T{ FBUF FBUF 3 CHARS MOVE -> }T     \ BIZARRE SPECIAL CASE
6413 T{ SEEBUF -> 20 20 20 }T
6414
6415 T{ SBUF FBUF 0 CHARS MOVE -> }T
6416 T{ SEEBUF -> 20 20 20 }T
6417
6418 T{ SBUF FBUF 1 CHARS MOVE -> }T
6419 T{ SEEBUF -> 12 20 20 }T
6420
6421 T{ SBUF FBUF 3 CHARS MOVE -> }T
6422 T{ SEEBUF -> 12 34 56 }T
6423
6424 T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T
6425 T{ SEEBUF -> 12 12 34 }T
6426
6427 T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T
6428 T{ SEEBUF -> 12 34 34 }T
6429
6430 \ ------------------------------------------------------------------------
6431 TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
6432
6433 : OUTPUT-TEST
6434     ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
6435     41 BL DO I EMIT LOOP CR
6436     61 41 DO I EMIT LOOP CR
6437     7F 61 DO I EMIT LOOP CR
6438     ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
6439     9 1+ 0 DO I . LOOP CR
6440     ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
6441     [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
6442     ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
6443     [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
6444     ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
6445     5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
6446     ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
6447     S" LINE 1" TYPE CR S" LINE 2" TYPE CR
6448     ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
6449     ."   SIGNED: " MIN-INT . MAX-INT . CR
6450     ." UNSIGNED: " 0 U. MAX-UINT U. CR
6451 ;
6452
6453 T{ OUTPUT-TEST -> }T
6454 \ ------------------------------------------------------------------------
6455 TESTING INPUT: ACCEPT
6456
6457 CREATE ABUF 80 CHARS ALLOT
6458
6459 : ACCEPT-TEST
6460     CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
6461     ABUF 80 ACCEPT
6462     CR ." RECEIVED: " [CHAR] " EMIT
6463     ABUF SWAP TYPE [CHAR] " EMIT CR
6464 ;
6465
6466 T{ ACCEPT-TEST -> }T
6467 Vingt fois sur le métier remettez votre ouvrage, ...
6468 \ ------------------------------------------------------------------------
6469 TESTING DICTIONARY SEARCH RULES
6470
6471 T{ : GDX   123 ; : GDX   GDX 234 ; -> }T
6472
6473 T{ GDX -> 123 234 }T
6474
6475 CR .( End of Core word set tests) CR
6476
6477
6478
6479 RST_STATE   ; so ANS_COMPLEMENT_xx_MPY is conserved ;
6480 \ NOECHO      ; if an error occurs, comment this line before new download to find it.
6481
6482
6483 \ From: John Hayes S1I
6484 \ Subject: tester.fr
6485 \ Date: Mon, 27 Nov 95 13:10:09 PST
6486
6487 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
6488 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
6489 \ VERSION 1.1
6490
6491 \ 22/1/09 The words { and } have been changed to T{ and }T respectively to
6492 \ agree with the Forth 200X file ttester.fs. This avoids clashes with
6493 \ locals using { ... } and the FSL use of }
6494
6495
6496 \ 13/05/14 jmt. added colorised error messages.
6497
6498
6499
6500  0 CONSTANT FALSE
6501 -1 CONSTANT TRUE
6502
6503 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
6504 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
6505 VARIABLE VERBOSE
6506     FALSE VERBOSE !
6507 \   TRUE VERBOSE !
6508
6509 \ : EMPTY-STACK ( ... -- )  \ EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
6510 \     DEPTH ?DUP
6511 \             IF DUP 0< IF NEGATE 0
6512 \             DO 0 LOOP
6513 \             ELSE 0 DO DROP LOOP THEN
6514 \             THEN ;
6515 \
6516 \ : ERROR     \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
6517 \         \ THE LINE THAT HAD THE ERROR.
6518 \     TYPE SOURCE TYPE CR          \ DISPLAY LINE CORRESPONDING TO ERROR
6519 \     EMPTY-STACK              \ THROW AWAY EVERY THING ELSE
6520 \     QUIT  \ *** Uncomment this line to QUIT on an error
6521 \ ;
6522
6523 VARIABLE ACTUAL-DEPTH           \ STACK RECORD
6524 CREATE ACTUAL-RESULTS 20 CELLS ALLOT
6525
6526 : T{        \ ( -- ) SYNTACTIC SUGAR.
6527     ;
6528
6529 : ->        \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
6530     DEPTH DUP ACTUAL-DEPTH !     \ RECORD DEPTH
6531     ?DUP IF              \ IF THERE IS SOMETHING ON STACK
6532         0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
6533     THEN ;
6534
6535 : }T        \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
6536             \ (ACTUAL) CONTENTS.
6537     DEPTH ACTUAL-DEPTH @ = IF   \ IF DEPTHS MATCH
6538         DEPTH ?DUP IF           \ IF THERE IS SOMETHING ON THE STACK
6539         0 DO                    \ FOR EACH STACK ITEM
6540             ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
6541 \           = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN   \ jmt
6542             = 0= IF ABORT" INCORRECT RESULT: " THEN           \ jmt : colorised message
6543         LOOP
6544         THEN
6545     ELSE                 \ DEPTH MISMATCH
6546 \       S" WRONG NUMBER OF RESULTS: " ERROR \ jmt
6547         ABORT" WRONG NUMBER OF RESULTS: "   \ jmt : colorised message
6548     THEN ;
6549
6550 : TESTING   \ ( -- ) TALKING COMMENT.
6551     SOURCE VERBOSE @
6552     IF DUP >R TYPE CR R> >IN !
6553     ELSE >IN ! DROP [CHAR] * EMIT
6554     THEN ;
6555
6556 \ From: John Hayes S1I
6557 \ Subject: core.fr
6558 \ Date: Mon, 27 Nov 95 13:10
6559
6560 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
6561 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
6562 \ VERSION 1.2
6563 \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
6564 \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
6565 \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
6566 \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
6567 \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
6568 \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
6569
6570 CR
6571 TESTING CORE WORDS
6572 HEX
6573
6574 \ ------------------------------------------------------------------------
6575 TESTING BASIC ASSUMPTIONS
6576
6577 T{ -> }T                    \ START WITH CLEAN SLATE
6578 ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
6579 T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T
6580 T{  0 BITSSET? -> 0 }T      ( ZERO IS ALL BITS CLEAR )
6581 T{  1 BITSSET? -> 0 0 }T        ( OTHER NUMBER HAVE AT LEAST ONE BIT )
6582 T{ -1 BITSSET? -> 0 0 }T
6583
6584 \ ------------------------------------------------------------------------
6585 TESTING BOOLEANS: INVERT AND OR XOR
6586
6587 T{ 0 0 AND -> 0 }T
6588 T{ 0 1 AND -> 0 }T
6589 T{ 1 0 AND -> 0 }T
6590 T{ 1 1 AND -> 1 }T
6591
6592 T{ 0 INVERT 1 AND -> 1 }T
6593 T{ 1 INVERT 1 AND -> 0 }T
6594
6595 0    CONSTANT 0S
6596 0 INVERT CONSTANT 1S
6597
6598 T{ 0S INVERT -> 1S }T
6599 T{ 1S INVERT -> 0S }T
6600
6601 T{ 0S 0S AND -> 0S }T
6602 T{ 0S 1S AND -> 0S }T
6603 T{ 1S 0S AND -> 0S }T
6604 T{ 1S 1S AND -> 1S }T
6605
6606 T{ 0S 0S OR -> 0S }T
6607 T{ 0S 1S OR -> 1S }T
6608 T{ 1S 0S OR -> 1S }T
6609 T{ 1S 1S OR -> 1S }T
6610
6611 T{ 0S 0S XOR -> 0S }T
6612 T{ 0S 1S XOR -> 1S }T
6613 T{ 1S 0S XOR -> 1S }T
6614 T{ 1S 1S XOR -> 0S }T
6615
6616 \ ------------------------------------------------------------------------
6617 TESTING 2* 2/ LSHIFT RSHIFT
6618
6619 ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
6620 1S 1 RSHIFT INVERT CONSTANT MSB
6621 T{ MSB BITSSET? -> 0 0 }T
6622
6623 T{ 0S 2* -> 0S }T
6624 T{ 1 2* -> 2 }T
6625 T{ 4000 2* -> 8000 }T
6626 T{ 1S 2* 1 XOR -> 1S }T
6627 T{ MSB 2* -> 0S }T
6628
6629 T{ 0S 2/ -> 0S }T
6630 T{ 1 2/ -> 0 }T
6631 T{ 4000 2/ -> 2000 }T
6632 T{ 1S 2/ -> 1S }T               \ MSB PROPOGATED
6633 T{ 1S 1 XOR 2/ -> 1S }T
6634 T{ MSB 2/ MSB AND -> MSB }T
6635
6636 T{ 1 0 LSHIFT -> 1 }T
6637 T{ 1 1 LSHIFT -> 2 }T
6638 T{ 1 2 LSHIFT -> 4 }T
6639 T{ 1 F LSHIFT -> 8000 }T            \ BIGGEST GUARANTEED SHIFT
6640 T{ 1S 1 LSHIFT 1 XOR -> 1S }T
6641 T{ MSB 1 LSHIFT -> 0 }T
6642
6643 T{ 1 0 RSHIFT -> 1 }T
6644 T{ 1 1 RSHIFT -> 0 }T
6645 T{ 2 1 RSHIFT -> 1 }T
6646 T{ 4 2 RSHIFT -> 1 }T
6647 T{ 8000 F RSHIFT -> 1 }T            \ BIGGEST
6648 T{ MSB 1 RSHIFT MSB AND -> 0 }T     \ RSHIFT ZERO FILLS MSBS
6649 T{ MSB 1 RSHIFT 2* -> MSB }T
6650
6651 \ ------------------------------------------------------------------------
6652 TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
6653 0 INVERT            CONSTANT MAX-UINT
6654 0 INVERT 1 RSHIFT       CONSTANT MAX-INT
6655 0 INVERT 1 RSHIFT INVERT    CONSTANT MIN-INT
6656 0 INVERT 1 RSHIFT       CONSTANT MID-UINT
6657 0 INVERT 1 RSHIFT INVERT    CONSTANT MID-UINT+1
6658
6659 0S CONSTANT <FALSE>
6660 1S CONSTANT <TRUE>
6661
6662 T{ 0 0= -> <TRUE> }T
6663 T{ 1 0= -> <FALSE> }T
6664 T{ 2 0= -> <FALSE> }T
6665 T{ -1 0= -> <FALSE> }T
6666 T{ MAX-UINT 0= -> <FALSE> }T
6667 T{ MIN-INT 0= -> <FALSE> }T
6668 T{ MAX-INT 0= -> <FALSE> }T
6669
6670 T{ 0 0 = -> <TRUE> }T
6671 T{ 1 1 = -> <TRUE> }T
6672 T{ -1 -1 = -> <TRUE> }T
6673 T{ 1 0 = -> <FALSE> }T
6674 T{ -1 0 = -> <FALSE> }T
6675 T{ 0 1 = -> <FALSE> }T
6676 T{ 0 -1 = -> <FALSE> }T
6677
6678 T{ 0 0< -> <FALSE> }T
6679 T{ -1 0< -> <TRUE> }T
6680 T{ MIN-INT 0< -> <TRUE> }T
6681 T{ 1 0< -> <FALSE> }T
6682 T{ MAX-INT 0< -> <FALSE> }T
6683
6684 T{ 0 1 < -> <TRUE> }T
6685 T{ 1 2 < -> <TRUE> }T
6686 T{ -1 0 < -> <TRUE> }T
6687 T{ -1 1 < -> <TRUE> }T
6688 T{ MIN-INT 0 < -> <TRUE> }T
6689 T{ MIN-INT MAX-INT < -> <TRUE> }T
6690 T{ 0 MAX-INT < -> <TRUE> }T
6691 T{ 0 0 < -> <FALSE> }T
6692 T{ 1 1 < -> <FALSE> }T
6693 T{ 1 0 < -> <FALSE> }T
6694 T{ 2 1 < -> <FALSE> }T
6695 T{ 0 -1 < -> <FALSE> }T
6696 T{ 1 -1 < -> <FALSE> }T
6697 T{ 0 MIN-INT < -> <FALSE> }T
6698 T{ MAX-INT MIN-INT < -> <FALSE> }T
6699 T{ MAX-INT 0 < -> <FALSE> }T
6700
6701 T{ 0 1 > -> <FALSE> }T
6702 T{ 1 2 > -> <FALSE> }T
6703 T{ -1 0 > -> <FALSE> }T
6704 T{ -1 1 > -> <FALSE> }T
6705 T{ MIN-INT 0 > -> <FALSE> }T
6706 T{ MIN-INT MAX-INT > -> <FALSE> }T
6707 T{ 0 MAX-INT > -> <FALSE> }T
6708 T{ 0 0 > -> <FALSE> }T
6709 T{ 1 1 > -> <FALSE> }T
6710 T{ 1 0 > -> <TRUE> }T
6711 T{ 2 1 > -> <TRUE> }T
6712 T{ 0 -1 > -> <TRUE> }T
6713 T{ 1 -1 > -> <TRUE> }T
6714 T{ 0 MIN-INT > -> <TRUE> }T
6715 T{ MAX-INT MIN-INT > -> <TRUE> }T
6716 T{ MAX-INT 0 > -> <TRUE> }T
6717
6718 T{ 0 1 U< -> <TRUE> }T
6719 T{ 1 2 U< -> <TRUE> }T
6720 T{ 0 MID-UINT U< -> <TRUE> }T
6721 T{ 0 MAX-UINT U< -> <TRUE> }T
6722 T{ MID-UINT MAX-UINT U< -> <TRUE> }T
6723 T{ 0 0 U< -> <FALSE> }T
6724 T{ 1 1 U< -> <FALSE> }T
6725 T{ 1 0 U< -> <FALSE> }T
6726 T{ 2 1 U< -> <FALSE> }T
6727 T{ MID-UINT 0 U< -> <FALSE> }T
6728 T{ MAX-UINT 0 U< -> <FALSE> }T
6729 T{ MAX-UINT MID-UINT U< -> <FALSE> }T
6730
6731 T{ 0 1 MIN -> 0 }T
6732 T{ 1 2 MIN -> 1 }T
6733 T{ -1 0 MIN -> -1 }T
6734 T{ -1 1 MIN -> -1 }T
6735 T{ MIN-INT 0 MIN -> MIN-INT }T
6736 T{ MIN-INT MAX-INT MIN -> MIN-INT }T
6737 T{ 0 MAX-INT MIN -> 0 }T
6738 T{ 0 0 MIN -> 0 }T
6739 T{ 1 1 MIN -> 1 }T
6740 T{ 1 0 MIN -> 0 }T
6741 T{ 2 1 MIN -> 1 }T
6742 T{ 0 -1 MIN -> -1 }T
6743 T{ 1 -1 MIN -> -1 }T
6744 T{ 0 MIN-INT MIN -> MIN-INT }T
6745 T{ MAX-INT MIN-INT MIN -> MIN-INT }T
6746 T{ MAX-INT 0 MIN -> 0 }T
6747
6748 T{ 0 1 MAX -> 1 }T
6749 T{ 1 2 MAX -> 2 }T
6750 T{ -1 0 MAX -> 0 }T
6751 T{ -1 1 MAX -> 1 }T
6752 T{ MIN-INT 0 MAX -> 0 }T
6753 T{ MIN-INT MAX-INT MAX -> MAX-INT }T
6754 T{ 0 MAX-INT MAX -> MAX-INT }T
6755 T{ 0 0 MAX -> 0 }T
6756 T{ 1 1 MAX -> 1 }T
6757 T{ 1 0 MAX -> 1 }T
6758 T{ 2 1 MAX -> 2 }T
6759 T{ 0 -1 MAX -> 0 }T
6760 T{ 1 -1 MAX -> 1 }T
6761 T{ 0 MIN-INT MAX -> 0 }T
6762 T{ MAX-INT MIN-INT MAX -> MAX-INT }T
6763 T{ MAX-INT 0 MAX -> MAX-INT }T
6764
6765 \ ------------------------------------------------------------------------
6766 TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
6767
6768 T{ 1 2 2DROP -> }T
6769 T{ 1 2 2DUP -> 1 2 1 2 }T
6770 T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T
6771 T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T
6772 T{ 0 ?DUP -> 0 }T
6773 T{ 1 ?DUP -> 1 1 }T
6774 T{ -1 ?DUP -> -1 -1 }T
6775 T{ DEPTH -> 0 }T
6776 T{ 0 DEPTH -> 0 1 }T
6777 T{ 0 1 DEPTH -> 0 1 2 }T
6778 T{ 0 DROP -> }T
6779 T{ 1 2 DROP -> 1 }T
6780 T{ 1 DUP -> 1 1 }T
6781 T{ 1 2 OVER -> 1 2 1 }T
6782 T{ 1 2 3 ROT -> 2 3 1 }T
6783 T{ 1 2 SWAP -> 2 1 }T
6784
6785 \ ------------------------------------------------------------------------
6786 TESTING >R R> R@
6787
6788 T{ : GR1 >R R> ; -> }T
6789 T{ : GR2 >R R@ R> DROP ; -> }T
6790 T{ 123 GR1 -> 123 }T
6791 T{ 123 GR2 -> 123 }T
6792 T{ 1S GR1 -> 1S }T   ( RETURN STACK HOLDS CELLS )
6793
6794 \ ------------------------------------------------------------------------
6795 TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
6796
6797 T{ 0 5 + -> 5 }T
6798 T{ 5 0 + -> 5 }T
6799 T{ 0 -5 + -> -5 }T
6800 T{ -5 0 + -> -5 }T
6801 T{ 1 2 + -> 3 }T
6802 T{ 1 -2 + -> -1 }T
6803 T{ -1 2 + -> 1 }T
6804 T{ -1 -2 + -> -3 }T
6805 T{ -1 1 + -> 0 }T
6806 T{ MID-UINT 1 + -> MID-UINT+1 }T
6807
6808 T{ 0 5 - -> -5 }T
6809 T{ 5 0 - -> 5 }T
6810 T{ 0 -5 - -> 5 }T
6811 T{ -5 0 - -> -5 }T
6812 T{ 1 2 - -> -1 }T
6813 T{ 1 -2 - -> 3 }T
6814 T{ -1 2 - -> -3 }T
6815 T{ -1 -2 - -> 1 }T
6816 T{ 0 1 - -> -1 }T
6817 T{ MID-UINT+1 1 - -> MID-UINT }T
6818
6819 T{ 0 1+ -> 1 }T
6820 T{ -1 1+ -> 0 }T
6821 T{ 1 1+ -> 2 }T
6822 T{ MID-UINT 1+ -> MID-UINT+1 }T
6823
6824 T{ 2 1- -> 1 }T
6825 T{ 1 1- -> 0 }T
6826 T{ 0 1- -> -1 }T
6827 T{ MID-UINT+1 1- -> MID-UINT }T
6828
6829 T{ 0 NEGATE -> 0 }T
6830 T{ 1 NEGATE -> -1 }T
6831 T{ -1 NEGATE -> 1 }T
6832 T{ 2 NEGATE -> -2 }T
6833 T{ -2 NEGATE -> 2 }T
6834
6835 T{ 0 ABS -> 0 }T
6836 T{ 1 ABS -> 1 }T
6837 T{ -1 ABS -> 1 }T
6838 T{ MIN-INT ABS -> MID-UINT+1 }T
6839
6840 \ ------------------------------------------------------------------------
6841 TESTING MULTIPLY: S>D * M* UM*
6842
6843 T{ 0 S>D -> 0 0 }T
6844 T{ 1 S>D -> 1 0 }T
6845 T{ 2 S>D -> 2 0 }T
6846 T{ -1 S>D -> -1 -1 }T
6847 T{ -2 S>D -> -2 -1 }T
6848 T{ MIN-INT S>D -> MIN-INT -1 }T
6849 T{ MAX-INT S>D -> MAX-INT 0 }T
6850
6851 T{ 0 0 M* -> 0 S>D }T
6852 T{ 0 1 M* -> 0 S>D }T
6853 T{ 1 0 M* -> 0 S>D }T
6854 T{ 1 2 M* -> 2 S>D }T
6855 T{ 2 1 M* -> 2 S>D }T
6856 T{ 3 3 M* -> 9 S>D }T
6857 T{ -3 3 M* -> -9 S>D }T
6858 T{ 3 -3 M* -> -9 S>D }T
6859 T{ -3 -3 M* -> 9 S>D }T
6860 T{ 0 MIN-INT M* -> 0 S>D }T
6861 T{ 1 MIN-INT M* -> MIN-INT S>D }T
6862 T{ 2 MIN-INT M* -> 0 1S }T
6863 T{ 0 MAX-INT M* -> 0 S>D }T
6864 T{ 1 MAX-INT M* -> MAX-INT S>D }T
6865 T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T
6866 T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T
6867 T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T
6868 T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T
6869
6870 T{ 0 0 * -> 0 }T                \ TEST IDENTITIES
6871 T{ 0 1 * -> 0 }T
6872 T{ 1 0 * -> 0 }T
6873 T{ 1 2 * -> 2 }T
6874 T{ 2 1 * -> 2 }T
6875 T{ 3 3 * -> 9 }T
6876 T{ -3 3 * -> -9 }T
6877 T{ 3 -3 * -> -9 }T
6878 T{ -3 -3 * -> 9 }T
6879
6880 T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T
6881 T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T
6882 T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T
6883
6884 T{ 0 0 UM* -> 0 0 }T
6885 T{ 0 1 UM* -> 0 0 }T
6886 T{ 1 0 UM* -> 0 0 }T
6887 T{ 1 2 UM* -> 2 0 }T
6888 T{ 2 1 UM* -> 2 0 }T
6889 T{ 3 3 UM* -> 9 0 }T
6890
6891 T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T
6892 T{ MID-UINT+1 2 UM* -> 0 1 }T
6893 T{ MID-UINT+1 4 UM* -> 0 2 }T
6894 T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T
6895 T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T
6896
6897 \ ------------------------------------------------------------------------
6898 TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
6899
6900 T{ 0 S>D 1 FM/MOD -> 0 0 }T
6901 T{ 1 S>D 1 FM/MOD -> 0 1 }T
6902 T{ 2 S>D 1 FM/MOD -> 0 2 }T
6903 T{ -1 S>D 1 FM/MOD -> 0 -1 }T
6904 T{ -2 S>D 1 FM/MOD -> 0 -2 }T
6905 T{ 0 S>D -1 FM/MOD -> 0 0 }T
6906 T{ 1 S>D -1 FM/MOD -> 0 -1 }T
6907 T{ 2 S>D -1 FM/MOD -> 0 -2 }T
6908 T{ -1 S>D -1 FM/MOD -> 0 1 }T
6909 T{ -2 S>D -1 FM/MOD -> 0 2 }T
6910 T{ 2 S>D 2 FM/MOD -> 0 1 }T
6911 T{ -1 S>D -1 FM/MOD -> 0 1 }T
6912 T{ -2 S>D -2 FM/MOD -> 0 1 }T
6913 T{  7 S>D  3 FM/MOD -> 1 2 }T
6914 T{  7 S>D -3 FM/MOD -> -2 -3 }T
6915 T{ -7 S>D  3 FM/MOD -> 2 -3 }T
6916 T{ -7 S>D -3 FM/MOD -> -1 2 }T
6917 T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T
6918 T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T
6919 T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T
6920 T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T
6921 T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T
6922 T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T
6923 T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T
6924 T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T
6925 T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T
6926 T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T
6927 T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T
6928 T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T
6929 T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T
6930 T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T
6931 T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T
6932 T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T
6933 T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T
6934
6935 T{ 0 S>D 1 SM/REM -> 0 0 }T
6936 T{ 1 S>D 1 SM/REM -> 0 1 }T
6937 T{ 2 S>D 1 SM/REM -> 0 2 }T
6938 T{ -1 S>D 1 SM/REM -> 0 -1 }T
6939 T{ -2 S>D 1 SM/REM -> 0 -2 }T
6940 T{ 0 S>D -1 SM/REM -> 0 0 }T
6941 T{ 1 S>D -1 SM/REM -> 0 -1 }T
6942 T{ 2 S>D -1 SM/REM -> 0 -2 }T
6943 T{ -1 S>D -1 SM/REM -> 0 1 }T
6944 T{ -2 S>D -1 SM/REM -> 0 2 }T
6945 T{ 2 S>D 2 SM/REM -> 0 1 }T
6946 T{ -1 S>D -1 SM/REM -> 0 1 }T
6947 T{ -2 S>D -2 SM/REM -> 0 1 }T
6948 T{  7 S>D  3 SM/REM -> 1 2 }T
6949 T{  7 S>D -3 SM/REM -> 1 -2 }T
6950 T{ -7 S>D  3 SM/REM -> -1 -2 }T
6951 T{ -7 S>D -3 SM/REM -> -1 2 }T
6952 T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T
6953 T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T
6954 T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T
6955 T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T
6956 T{ 1S 1 4 SM/REM -> 3 MAX-INT }T
6957 T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T
6958 T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T
6959 T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T
6960 T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T
6961 T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T
6962 T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T
6963 T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T
6964 T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T
6965
6966 T{ 0 0 1 UM/MOD -> 0 0 }T
6967 T{ 1 0 1 UM/MOD -> 0 1 }T
6968 T{ 1 0 2 UM/MOD -> 1 0 }T
6969 T{ 3 0 2 UM/MOD -> 1 1 }T
6970 T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T
6971 T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T
6972 T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T
6973
6974 : IFFLOORED
6975     [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
6976
6977 : IFSYM
6978     [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
6979
6980 \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
6981 \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
6982
6983 IFFLOORED : T/MOD  >R S>D R> FM/MOD ;
6984 IFFLOORED : T/     T/MOD SWAP DROP ;
6985 IFFLOORED : TMOD   T/MOD DROP ;
6986 IFFLOORED : T*/MOD >R M* R> FM/MOD ;
6987 IFFLOORED : T*/    T*/MOD SWAP DROP ;
6988 IFSYM     : T/MOD  >R S>D R> SM/REM ;
6989 IFSYM     : T/     T/MOD SWAP DROP ;
6990 IFSYM     : TMOD   T/MOD DROP ;
6991 IFSYM     : T*/MOD >R M* R> SM/REM ;
6992 IFSYM     : T*/    T*/MOD SWAP DROP ;
6993
6994 T{ 0 1 /MOD -> 0 1 T/MOD }T
6995 T{ 1 1 /MOD -> 1 1 T/MOD }T
6996 T{ 2 1 /MOD -> 2 1 T/MOD }T
6997 T{ -1 1 /MOD -> -1 1 T/MOD }T
6998 T{ -2 1 /MOD -> -2 1 T/MOD }T
6999 T{ 0 -1 /MOD -> 0 -1 T/MOD }T
7000 T{ 1 -1 /MOD -> 1 -1 T/MOD }T
7001 T{ 2 -1 /MOD -> 2 -1 T/MOD }T
7002 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
7003 T{ -2 -1 /MOD -> -2 -1 T/MOD }T
7004 T{ 2 2 /MOD -> 2 2 T/MOD }T
7005 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
7006 T{ -2 -2 /MOD -> -2 -2 T/MOD }T
7007 T{ 7 3 /MOD -> 7 3 T/MOD }T
7008 T{ 7 -3 /MOD -> 7 -3 T/MOD }T
7009 T{ -7 3 /MOD -> -7 3 T/MOD }T
7010 T{ -7 -3 /MOD -> -7 -3 T/MOD }T
7011 T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T
7012 T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T
7013 T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T
7014 T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T
7015
7016 T{ 0 1 / -> 0 1 T/ }T
7017 T{ 1 1 / -> 1 1 T/ }T
7018 T{ 2 1 / -> 2 1 T/ }T
7019 T{ -1 1 / -> -1 1 T/ }T
7020 T{ -2 1 / -> -2 1 T/ }T
7021 T{ 0 -1 / -> 0 -1 T/ }T
7022 T{ 1 -1 / -> 1 -1 T/ }T
7023 T{ 2 -1 / -> 2 -1 T/ }T
7024 T{ -1 -1 / -> -1 -1 T/ }T
7025 T{ -2 -1 / -> -2 -1 T/ }T
7026 T{ 2 2 / -> 2 2 T/ }T
7027 T{ -1 -1 / -> -1 -1 T/ }T
7028 T{ -2 -2 / -> -2 -2 T/ }T
7029 T{ 7 3 / -> 7 3 T/ }T
7030 T{ 7 -3 / -> 7 -3 T/ }T
7031 T{ -7 3 / -> -7 3 T/ }T
7032 T{ -7 -3 / -> -7 -3 T/ }T
7033 T{ MAX-INT 1 / -> MAX-INT 1 T/ }T
7034 T{ MIN-INT 1 / -> MIN-INT 1 T/ }T
7035 T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T
7036 T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T
7037
7038 T{ 0 1 MOD -> 0 1 TMOD }T
7039 T{ 1 1 MOD -> 1 1 TMOD }T
7040 T{ 2 1 MOD -> 2 1 TMOD }T
7041 T{ -1 1 MOD -> -1 1 TMOD }T
7042 T{ -2 1 MOD -> -2 1 TMOD }T
7043 T{ 0 -1 MOD -> 0 -1 TMOD }T
7044 T{ 1 -1 MOD -> 1 -1 TMOD }T
7045 T{ 2 -1 MOD -> 2 -1 TMOD }T
7046 T{ -1 -1 MOD -> -1 -1 TMOD }T
7047 T{ -2 -1 MOD -> -2 -1 TMOD }T
7048 T{ 2 2 MOD -> 2 2 TMOD }T
7049 T{ -1 -1 MOD -> -1 -1 TMOD }T
7050 T{ -2 -2 MOD -> -2 -2 TMOD }T
7051 T{ 7 3 MOD -> 7 3 TMOD }T
7052 T{ 7 -3 MOD -> 7 -3 TMOD }T
7053 T{ -7 3 MOD -> -7 3 TMOD }T
7054 T{ -7 -3 MOD -> -7 -3 TMOD }T
7055 T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T
7056 T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T
7057 T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T
7058 T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T
7059
7060 T{ 0 2 1 */ -> 0 2 1 T*/ }T
7061 T{ 1 2 1 */ -> 1 2 1 T*/ }T
7062 T{ 2 2 1 */ -> 2 2 1 T*/ }T
7063 T{ -1 2 1 */ -> -1 2 1 T*/ }T
7064 T{ -2 2 1 */ -> -2 2 1 T*/ }T
7065 T{ 0 2 -1 */ -> 0 2 -1 T*/ }T
7066 T{ 1 2 -1 */ -> 1 2 -1 T*/ }T
7067 T{ 2 2 -1 */ -> 2 2 -1 T*/ }T
7068 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
7069 T{ -2 2 -1 */ -> -2 2 -1 T*/ }T
7070 T{ 2 2 2 */ -> 2 2 2 T*/ }T
7071 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
7072 T{ -2 2 -2 */ -> -2 2 -2 T*/ }T
7073 T{ 7 2 3 */ -> 7 2 3 T*/ }T
7074 T{ 7 2 -3 */ -> 7 2 -3 T*/ }T
7075 T{ -7 2 3 */ -> -7 2 3 T*/ }T
7076 T{ -7 2 -3 */ -> -7 2 -3 T*/ }T
7077 T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T
7078 T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T
7079
7080 T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T
7081 T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T
7082 T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T
7083 T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T
7084 T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T
7085 T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T
7086 T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T
7087 T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T
7088 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
7089 T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T
7090 T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T
7091 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
7092 T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T
7093 T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T
7094 T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T
7095 T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T
7096 T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T
7097 T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T
7098 T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T
7099
7100 \ ------------------------------------------------------------------------
7101 TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
7102
7103 HERE 1 ALLOT
7104 HERE
7105 CONSTANT 2NDA
7106 CONSTANT 1STA
7107 T{ 1STA 2NDA U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
7108 T{ 1STA 1+ -> 2NDA }T           \ ... BY ONE ADDRESS UNIT
7109 ( MISSING TEST: NEGATIVE ALLOT )
7110
7111 HERE 1 ,
7112 HERE 2 ,
7113 CONSTANT 2ND
7114 CONSTANT 1ST
7115 T{ 1ST 2ND U< -> <TRUE> }T          \ HERE MUST GROW WITH ALLOT
7116 T{ 1ST CELL+ -> 2ND }T          \ ... BY ONE CELL
7117 T{ 1ST 1 CELLS + -> 2ND }T
7118 T{ 1ST @ 2ND @ -> 1 2 }T
7119 T{ 5 1ST ! -> }T
7120 T{ 1ST @ 2ND @ -> 5 2 }T
7121 T{ 6 2ND ! -> }T
7122 T{ 1ST @ 2ND @ -> 5 6 }T
7123 T{ 1ST 2@ -> 6 5 }T
7124 T{ 2 1 1ST 2! -> }T
7125 T{ 1ST 2@ -> 2 1 }T
7126 T{ 1S 1ST !  1ST @ -> 1S }T     \ CAN STORE CELL-WIDE VALUE
7127
7128 HERE 1 C,
7129 HERE 2 C,
7130 CONSTANT 2NDC
7131 CONSTANT 1STC
7132 T{ 1STC 2NDC U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
7133 T{ 1STC CHAR+ -> 2NDC }T            \ ... BY ONE CHAR
7134 T{ 1STC 1 CHARS + -> 2NDC }T
7135 T{ 1STC C@ 2NDC C@ -> 1 2 }T
7136 T{ 3 1STC C! -> }T
7137 T{ 1STC C@ 2NDC C@ -> 3 2 }T
7138 T{ 4 2NDC C! -> }T
7139 T{ 1STC C@ 2NDC C@ -> 3 4 }T
7140
7141 ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
7142 CONSTANT A-ADDR  CONSTANT UA-ADDR
7143 T{ UA-ADDR ALIGNED -> A-ADDR }T
7144 T{    1 A-ADDR C!  A-ADDR C@ ->    1 }T
7145 T{ 1234 A-ADDR  !  A-ADDR  @ -> 1234 }T
7146 T{ 123 456 A-ADDR 2!  A-ADDR 2@ -> 123 456 }T
7147 T{ 2 A-ADDR CHAR+ C!  A-ADDR CHAR+ C@ -> 2 }T
7148 T{ 3 A-ADDR CELL+ C!  A-ADDR CELL+ C@ -> 3 }T
7149 T{ 1234 A-ADDR CELL+ !  A-ADDR CELL+ @ -> 1234 }T
7150 T{ 123 456 A-ADDR CELL+ 2!  A-ADDR CELL+ 2@ -> 123 456 }T
7151
7152 : BITS ( X -- U )
7153     0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
7154 ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
7155 T{ 1 CHARS 1 < -> <FALSE> }T
7156 T{ 1 CHARS 1 CELLS > -> <FALSE> }T
7157 ( TBD: HOW TO FIND NUMBER OF BITS? )
7158
7159 ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
7160 T{ 1 CELLS 1 < -> <FALSE> }T
7161 T{ 1 CELLS 1 CHARS MOD -> 0 }T
7162 T{ 1S BITS 10 < -> <FALSE> }T
7163
7164 T{ 0 1ST ! -> }T
7165 T{ 1 1ST +! -> }T
7166 T{ 1ST @ -> 1 }T
7167 T{ -1 1ST +! 1ST @ -> 0 }T
7168
7169 \ ------------------------------------------------------------------------
7170 TESTING CHAR [CHAR] [ ] BL S"
7171
7172 T{ BL -> 20 }T
7173 T{ CHAR X -> 58 }T
7174 T{ CHAR HELLO -> 48 }T
7175 T{ : GC1 [CHAR] X ; -> }T
7176 T{ : GC2 [CHAR] HELLO ; -> }T
7177 T{ GC1 -> 58 }T
7178 T{ GC2 -> 48 }T
7179 T{ : GC3 [ GC1 ] LITERAL ; -> }T
7180 T{ GC3 -> 58 }T
7181 T{ : GC4 S" XY" ; -> }T
7182 T{ GC4 SWAP DROP -> 2 }T
7183 T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T
7184
7185 \ ------------------------------------------------------------------------
7186 TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
7187
7188 T{ : GT1 123 ; -> }T
7189 T{ ' GT1 EXECUTE -> 123 }T
7190 T{ : GT2 ['] GT1 ; IMMEDIATE -> }T
7191 T{ GT2 EXECUTE -> 123 }T
7192 HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
7193 HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
7194 T{ GT1STRING FIND -> ' GT1 -1 }T
7195 T{ GT2STRING FIND -> ' GT2 1 }T
7196 ( HOW TO SEARCH FOR NON-EXISTENT WORD? )
7197 T{ : GT3 GT2 LITERAL ; -> }T
7198 T{ GT3 -> ' GT1 }T
7199 T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T
7200
7201 T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T
7202 T{ : GT5 GT4 ; -> }T
7203 T{ GT5 -> 123 }T
7204 T{ : GT6 345 ; IMMEDIATE -> }T
7205 T{ : GT7 POSTPONE GT6 ; -> }T
7206 T{ GT7 -> 345 }T
7207
7208 T{ : GT8 STATE @ ; IMMEDIATE -> }T
7209 T{ GT8 -> 0 }T
7210 T{ : GT9 GT8 LITERAL ; -> }T
7211 T{ GT9 0= -> <FALSE> }T
7212
7213 \ ------------------------------------------------------------------------
7214 TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
7215
7216 T{ : GI1 IF 123 THEN ; -> }T
7217 T{ : GI2 IF 123 ELSE 234 THEN ; -> }T
7218 T{ 0 GI1 -> }T
7219 T{ 1 GI1 -> 123 }T
7220 T{ -1 GI1 -> 123 }T
7221 T{ 0 GI2 -> 234 }T
7222 T{ 1 GI2 -> 123 }T
7223 T{ -1 GI1 -> 123 }T
7224
7225 T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T
7226 T{ 0 GI3 -> 0 1 2 3 4 5 }T
7227 T{ 4 GI3 -> 4 5 }T
7228 T{ 5 GI3 -> 5 }T
7229 T{ 6 GI3 -> 6 }T
7230
7231 T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T
7232 T{ 3 GI4 -> 3 4 5 6 }T
7233 T{ 5 GI4 -> 5 6 }T
7234 T{ 6 GI4 -> 6 7 }T
7235
7236 T{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T
7237 T{ 1 GI5 -> 1 345 }T
7238 T{ 2 GI5 -> 2 345 }T
7239 T{ 3 GI5 -> 3 4 5 123 }T
7240 T{ 4 GI5 -> 4 5 123 }T
7241 T{ 5 GI5 -> 5 123 }T
7242
7243 T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T
7244 T{ 0 GI6 -> 0 }T
7245 T{ 1 GI6 -> 0 1 }T
7246 T{ 2 GI6 -> 0 1 2 }T
7247 T{ 3 GI6 -> 0 1 2 3 }T
7248 T{ 4 GI6 -> 0 1 2 3 4 }T
7249
7250 \ ------------------------------------------------------------------------
7251 TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
7252
7253 T{ : GD1 DO I LOOP ; -> }T
7254 T{ 4 1 GD1 -> 1 2 3 }T
7255 T{ 2 -1 GD1 -> -1 0 1 }T
7256 T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T
7257
7258 T{ : GD2 DO I -1 +LOOP ; -> }T
7259 T{ 1 4 GD2 -> 4 3 2 1 }T
7260 T{ -1 2 GD2 -> 2 1 0 -1 }T
7261 T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T
7262
7263 T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T
7264 T{ 4 1 GD3 -> 1 2 3 }T
7265 T{ 2 -1 GD3 -> -1 0 1 }T
7266 T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T
7267
7268 T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T
7269 T{ 1 4 GD4 -> 4 3 2 1 }T
7270 T{ -1 2 GD4 -> 2 1 0 -1 }T
7271 T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T
7272
7273 T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T
7274 T{ 1 GD5 -> 123 }T
7275 T{ 5 GD5 -> 123 }T
7276 T{ 6 GD5 -> 234 }T
7277
7278 T{ : GD6  ( PAT: T{0 0}T,T{0 0}TT{1 0}TT{1 1}T,T{0 0}TT{1 0}TT{1 1}TT{2 0}TT{2 1}TT{2 2}T )
7279     0 SWAP 0 DO
7280         I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
7281     LOOP ; -> }T
7282 T{ 1 GD6 -> 1 }T
7283 T{ 2 GD6 -> 3 }T
7284 T{ 3 GD6 -> 4 1 2 }T
7285
7286 \ ------------------------------------------------------------------------
7287 TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
7288
7289 T{ 123 CONSTANT X123 -> }T
7290 T{ X123 -> 123 }T
7291 T{ : EQU CONSTANT ; -> }T
7292 T{ X123 EQU Y123 -> }T
7293 T{ Y123 -> 123 }T
7294
7295 T{ VARIABLE V1 -> }T
7296 T{ 123 V1 ! -> }T
7297 T{ V1 @ -> 123 }T
7298
7299 T{ : NOP : POSTPONE ; ; -> }T
7300 T{ NOP NOP1 NOP NOP2 -> }T
7301 T{ NOP1 -> }T
7302 T{ NOP2 -> }T
7303
7304 T{ : DOES1 DOES> @ 1 + ; -> }T
7305 T{ : DOES2 DOES> @ 2 + ; -> }T
7306 T{ CREATE CR1 -> }T
7307 T{ CR1 -> HERE }T
7308 T{ ' CR1 >BODY -> HERE }T
7309 T{ 1 , -> }T
7310 T{ CR1 @ -> 1 }T
7311 T{ DOES1 -> }T
7312 T{ CR1 -> 2 }T
7313 T{ DOES2 -> }T
7314 T{ CR1 -> 3 }T
7315
7316 T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T
7317 T{ WEIRD: W1 -> }T
7318 T{ ' W1 >BODY -> HERE }T
7319 T{ W1 -> HERE 1 + }T
7320 T{ W1 -> HERE 2 + }T
7321
7322 \ ------------------------------------------------------------------------
7323 TESTING EVALUATE
7324
7325 : GE1 S" 123" ; IMMEDIATE
7326 : GE2 S" 123 1+" ; IMMEDIATE
7327 : GE3 S" : GE4 345 ;" ;
7328 : GE5 EVALUATE ; IMMEDIATE
7329
7330 T{ GE1 EVALUATE -> 123 }T           ( TEST EVALUATE IN INTERP. STATE )
7331 T{ GE2 EVALUATE -> 124 }T
7332 T{ GE3 EVALUATE -> }T
7333 T{ GE4 -> 345 }T
7334
7335 T{ : GE6 GE1 GE5 ; -> }T            ( TEST EVALUATE IN COMPILE STATE )
7336 T{ GE6 -> 123 }T
7337 T{ : GE7 GE2 GE5 ; -> }T
7338 T{ GE7 -> 124 }T
7339
7340 \ ------------------------------------------------------------------------
7341 TESTING SOURCE >IN WORD
7342
7343 : GS1 S" SOURCE" 2DUP EVALUATE
7344         >R SWAP >R = R> R> = ;
7345 T{ GS1 -> <TRUE> <TRUE> }T
7346
7347 VARIABLE SCANS
7348 : RESCAN?  -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
7349
7350 T{ 2 SCANS !
7351 345 RESCAN?
7352 -> 345 345 }T
7353
7354 : GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
7355 T{ GS2 -> 123 123 123 123 123 }T
7356
7357 : GS3 WORD COUNT SWAP C@ ;
7358 T{ BL GS3 HELLO -> 5 CHAR H }T
7359 T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T
7360 T{ BL GS3
7361 DROP -> 0 }T                \ BLANK LINE RETURN ZERO-LENGTH STRING
7362
7363 : GS4 SOURCE >IN ! DROP ;
7364 T{ GS4 123 456
7365 -> }T
7366
7367 \ ------------------------------------------------------------------------
7368 TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
7369
7370 : S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
7371     >R SWAP R@ = IF          \ MAKE SURE STRINGS HAVE SAME LENGTH
7372         R> ?DUP IF            \ IF NON-EMPTY STRINGS
7373         0 DO
7374         OVER C@ OVER C@ - IF
7375             2DROP <FALSE> UNLOOP EXIT THEN
7376         SWAP CHAR+ SWAP CHAR+
7377             LOOP
7378         THEN
7379         2DROP <TRUE>          \ IF WE GET HERE, STRINGS MATCH
7380     ELSE
7381         R> DROP 2DROP <FALSE>     \ LENGTHS MISMATCH
7382     THEN ;
7383
7384 : GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
7385 T{ GP1 -> <TRUE> }T
7386
7387 : GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
7388 T{ GP2 -> <TRUE> }T
7389
7390 : GP3  <# 1 0 # # #> S" 01" S= ;
7391 T{ GP3 -> <TRUE> }T
7392
7393 : GP4  <# 1 0 #S #> S" 1" S= ;
7394 T{ GP4 -> <TRUE> }T
7395
7396 24 CONSTANT MAX-BASE            \ BASE 2 .. 36
7397 : COUNT-BITS
7398     0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
7399 COUNT-BITS 2* CONSTANT #BITS-UD     \ NUMBER OF BITS IN UD
7400
7401 : GP5
7402     BASE @ <TRUE>
7403     MAX-BASE 1+ 2 DO         \ FOR EACH POSSIBLE BASE
7404         I BASE !              \ TBD: ASSUMES BASE WORKS
7405         I 0 <# #S #> S" 10" S= AND
7406     LOOP
7407     SWAP BASE ! ;
7408 T{ GP5 -> <TRUE> }T
7409
7410 : GP6
7411     BASE @ >R  2 BASE !
7412     MAX-UINT MAX-UINT <# #S #>       \ MAXIMUM UD TO BINARY
7413     R> BASE !                \ S: C-ADDR U
7414     DUP #BITS-UD = SWAP
7415     0 DO                 \ S: C-ADDR FLAG
7416         OVER C@ [CHAR] 1 = AND        \ ALL ONES
7417         >R CHAR+ R>
7418     LOOP SWAP DROP ;
7419 T{ GP6 -> <TRUE> }T
7420
7421 : GP7
7422     BASE @ >R    MAX-BASE BASE !
7423     <TRUE>
7424     A 0 DO
7425         I 0 <# #S #>
7426         1 = SWAP C@ I 30 + = AND AND
7427     LOOP
7428     MAX-BASE A DO
7429         I 0 <# #S #>
7430         1 = SWAP C@ 41 I A - + = AND AND
7431     LOOP
7432     R> BASE ! ;
7433
7434 T{ GP7 -> <TRUE> }T
7435
7436 \ >NUMBER TESTS
7437 CREATE GN-BUF 0 C,
7438 : GN-STRING GN-BUF 1 ;
7439 : GN-CONSUMED   GN-BUF CHAR+ 0 ;
7440 : GN'       [CHAR] ' WORD CHAR+ C@ GN-BUF C!  GN-STRING ;
7441
7442 T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T
7443 T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T
7444 T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T
7445 T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T   \ SHOULD FAIL TO CONVERT THESE
7446 T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T
7447 T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T
7448
7449 : >NUMBER-BASED
7450     BASE @ >R BASE ! >NUMBER R> BASE ! ;
7451
7452 T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T
7453 T{ 0 0 GN' 2'  2 >NUMBER-BASED -> 0 0 GN-STRING }T
7454 T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T
7455 T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T
7456 T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T
7457 T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T
7458
7459 : GN1   \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
7460     BASE @ >R BASE !
7461     <# #S #>
7462     0 0 2SWAP >NUMBER SWAP DROP      \ RETURN LENGTH ONLY
7463     R> BASE ! ;
7464 T{ 0 0 2 GN1 -> 0 0 0 }T
7465 T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
7466 T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
7467 T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T
7468 T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T
7469 T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T
7470
7471 : GN2   \ ( -- 16 10 )
7472     BASE @ >R  HEX BASE @  DECIMAL BASE @  R> BASE ! ;
7473 T{ GN2 -> 10 A }T
7474
7475 \ ------------------------------------------------------------------------
7476 TESTING FILL MOVE
7477
7478 CREATE FBUF 00 C, 00 C, 00 C,
7479 CREATE SBUF 12 C, 34 C, 56 C,
7480 : SEEBUF FBUF C@  FBUF CHAR+ C@  FBUF CHAR+ CHAR+ C@ ;
7481
7482 T{ FBUF 0 20 FILL -> }T
7483 T{ SEEBUF -> 00 00 00 }T
7484
7485 T{ FBUF 1 20 FILL -> }T
7486 T{ SEEBUF -> 20 00 00 }T
7487
7488 T{ FBUF 3 20 FILL -> }T
7489 T{ SEEBUF -> 20 20 20 }T
7490
7491 T{ FBUF FBUF 3 CHARS MOVE -> }T     \ BIZARRE SPECIAL CASE
7492 T{ SEEBUF -> 20 20 20 }T
7493
7494 T{ SBUF FBUF 0 CHARS MOVE -> }T
7495 T{ SEEBUF -> 20 20 20 }T
7496
7497 T{ SBUF FBUF 1 CHARS MOVE -> }T
7498 T{ SEEBUF -> 12 20 20 }T
7499
7500 T{ SBUF FBUF 3 CHARS MOVE -> }T
7501 T{ SEEBUF -> 12 34 56 }T
7502
7503 T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T
7504 T{ SEEBUF -> 12 12 34 }T
7505
7506 T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T
7507 T{ SEEBUF -> 12 34 34 }T
7508
7509 \ ------------------------------------------------------------------------
7510 TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
7511
7512 : OUTPUT-TEST
7513     ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
7514     41 BL DO I EMIT LOOP CR
7515     61 41 DO I EMIT LOOP CR
7516     7F 61 DO I EMIT LOOP CR
7517     ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
7518     9 1+ 0 DO I . LOOP CR
7519     ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
7520     [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
7521     ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
7522     [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
7523     ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
7524     5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
7525     ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
7526     S" LINE 1" TYPE CR S" LINE 2" TYPE CR
7527     ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
7528     ."   SIGNED: " MIN-INT . MAX-INT . CR
7529     ." UNSIGNED: " 0 U. MAX-UINT U. CR
7530 ;
7531
7532 T{ OUTPUT-TEST -> }T
7533 \ ------------------------------------------------------------------------
7534 TESTING INPUT: ACCEPT
7535
7536 CREATE ABUF 80 CHARS ALLOT
7537
7538 : ACCEPT-TEST
7539     CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
7540     ABUF 80 ACCEPT
7541     CR ." RECEIVED: " [CHAR] " EMIT
7542     ABUF SWAP TYPE [CHAR] " EMIT CR
7543 ;
7544
7545 T{ ACCEPT-TEST -> }T
7546 Vingt fois sur le métier remettez votre ouvrage, ...
7547 \ ------------------------------------------------------------------------
7548 TESTING DICTIONARY SEARCH RULES
7549
7550 T{ : GDX   123 ; : GDX   GDX 234 ; -> }T
7551
7552 T{ GDX -> 123 234 }T
7553
7554 CR .( End of Core word set tests) CR
7555
7556
7557
7558 RST_STATE   ; so ANS_COMPLEMENT_xx_MPY is conserved ;
7559 \ NOECHO      ; if an error occurs, comment this line before new download to find it.
7560
7561
7562 \ From: John Hayes S1I
7563 \ Subject: tester.fr
7564 \ Date: Mon, 27 Nov 95 13:10:09 PST
7565
7566 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
7567 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
7568 \ VERSION 1.1
7569
7570 \ 22/1/09 The words { and } have been changed to T{ and }T respectively to
7571 \ agree with the Forth 200X file ttester.fs. This avoids clashes with
7572 \ locals using { ... } and the FSL use of }
7573
7574
7575 \ 13/05/14 jmt. added colorised error messages.
7576
7577
7578
7579  0 CONSTANT FALSE
7580 -1 CONSTANT TRUE
7581
7582 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
7583 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
7584 VARIABLE VERBOSE
7585     FALSE VERBOSE !
7586 \   TRUE VERBOSE !
7587
7588 \ : EMPTY-STACK ( ... -- )  \ EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
7589 \     DEPTH ?DUP
7590 \             IF DUP 0< IF NEGATE 0
7591 \             DO 0 LOOP
7592 \             ELSE 0 DO DROP LOOP THEN
7593 \             THEN ;
7594 \
7595 \ : ERROR     \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
7596 \         \ THE LINE THAT HAD THE ERROR.
7597 \     TYPE SOURCE TYPE CR          \ DISPLAY LINE CORRESPONDING TO ERROR
7598 \     EMPTY-STACK              \ THROW AWAY EVERY THING ELSE
7599 \     QUIT  \ *** Uncomment this line to QUIT on an error
7600 \ ;
7601
7602 VARIABLE ACTUAL-DEPTH           \ STACK RECORD
7603 CREATE ACTUAL-RESULTS 20 CELLS ALLOT
7604
7605 : T{        \ ( -- ) SYNTACTIC SUGAR.
7606     ;
7607
7608 : ->        \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
7609     DEPTH DUP ACTUAL-DEPTH !     \ RECORD DEPTH
7610     ?DUP IF              \ IF THERE IS SOMETHING ON STACK
7611         0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
7612     THEN ;
7613
7614 : }T        \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
7615             \ (ACTUAL) CONTENTS.
7616     DEPTH ACTUAL-DEPTH @ = IF   \ IF DEPTHS MATCH
7617         DEPTH ?DUP IF           \ IF THERE IS SOMETHING ON THE STACK
7618         0 DO                    \ FOR EACH STACK ITEM
7619             ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
7620 \           = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN   \ jmt
7621             = 0= IF ABORT" INCORRECT RESULT: " THEN           \ jmt : colorised message
7622         LOOP
7623         THEN
7624     ELSE                 \ DEPTH MISMATCH
7625 \       S" WRONG NUMBER OF RESULTS: " ERROR \ jmt
7626         ABORT" WRONG NUMBER OF RESULTS: "   \ jmt : colorised message
7627     THEN ;
7628
7629 : TESTING   \ ( -- ) TALKING COMMENT.
7630     SOURCE VERBOSE @
7631     IF DUP >R TYPE CR R> >IN !
7632     ELSE >IN ! DROP [CHAR] * EMIT
7633     THEN ;
7634
7635 \ From: John Hayes S1I
7636 \ Subject: core.fr
7637 \ Date: Mon, 27 Nov 95 13:10
7638
7639 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
7640 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
7641 \ VERSION 1.2
7642 \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
7643 \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
7644 \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
7645 \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
7646 \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
7647 \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
7648
7649 CR
7650 TESTING CORE WORDS
7651 HEX
7652
7653 \ ------------------------------------------------------------------------
7654 TESTING BASIC ASSUMPTIONS
7655
7656 T{ -> }T                    \ START WITH CLEAN SLATE
7657 ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
7658 T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T
7659 T{  0 BITSSET? -> 0 }T      ( ZERO IS ALL BITS CLEAR )
7660 T{  1 BITSSET? -> 0 0 }T        ( OTHER NUMBER HAVE AT LEAST ONE BIT )
7661 T{ -1 BITSSET? -> 0 0 }T
7662
7663 \ ------------------------------------------------------------------------
7664 TESTING BOOLEANS: INVERT AND OR XOR
7665
7666 T{ 0 0 AND -> 0 }T
7667 T{ 0 1 AND -> 0 }T
7668 T{ 1 0 AND -> 0 }T
7669 T{ 1 1 AND -> 1 }T
7670
7671 T{ 0 INVERT 1 AND -> 1 }T
7672 T{ 1 INVERT 1 AND -> 0 }T
7673
7674 0    CONSTANT 0S
7675 0 INVERT CONSTANT 1S
7676
7677 T{ 0S INVERT -> 1S }T
7678 T{ 1S INVERT -> 0S }T
7679
7680 T{ 0S 0S AND -> 0S }T
7681 T{ 0S 1S AND -> 0S }T
7682 T{ 1S 0S AND -> 0S }T
7683 T{ 1S 1S AND -> 1S }T
7684
7685 T{ 0S 0S OR -> 0S }T
7686 T{ 0S 1S OR -> 1S }T
7687 T{ 1S 0S OR -> 1S }T
7688 T{ 1S 1S OR -> 1S }T
7689
7690 T{ 0S 0S XOR -> 0S }T
7691 T{ 0S 1S XOR -> 1S }T
7692 T{ 1S 0S XOR -> 1S }T
7693 T{ 1S 1S XOR -> 0S }T
7694
7695 \ ------------------------------------------------------------------------
7696 TESTING 2* 2/ LSHIFT RSHIFT
7697
7698 ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
7699 1S 1 RSHIFT INVERT CONSTANT MSB
7700 T{ MSB BITSSET? -> 0 0 }T
7701
7702 T{ 0S 2* -> 0S }T
7703 T{ 1 2* -> 2 }T
7704 T{ 4000 2* -> 8000 }T
7705 T{ 1S 2* 1 XOR -> 1S }T
7706 T{ MSB 2* -> 0S }T
7707
7708 T{ 0S 2/ -> 0S }T
7709 T{ 1 2/ -> 0 }T
7710 T{ 4000 2/ -> 2000 }T
7711 T{ 1S 2/ -> 1S }T               \ MSB PROPOGATED
7712 T{ 1S 1 XOR 2/ -> 1S }T
7713 T{ MSB 2/ MSB AND -> MSB }T
7714
7715 T{ 1 0 LSHIFT -> 1 }T
7716 T{ 1 1 LSHIFT -> 2 }T
7717 T{ 1 2 LSHIFT -> 4 }T
7718 T{ 1 F LSHIFT -> 8000 }T            \ BIGGEST GUARANTEED SHIFT
7719 T{ 1S 1 LSHIFT 1 XOR -> 1S }T
7720 T{ MSB 1 LSHIFT -> 0 }T
7721
7722 T{ 1 0 RSHIFT -> 1 }T
7723 T{ 1 1 RSHIFT -> 0 }T
7724 T{ 2 1 RSHIFT -> 1 }T
7725 T{ 4 2 RSHIFT -> 1 }T
7726 T{ 8000 F RSHIFT -> 1 }T            \ BIGGEST
7727 T{ MSB 1 RSHIFT MSB AND -> 0 }T     \ RSHIFT ZERO FILLS MSBS
7728 T{ MSB 1 RSHIFT 2* -> MSB }T
7729
7730 \ ------------------------------------------------------------------------
7731 TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
7732 0 INVERT            CONSTANT MAX-UINT
7733 0 INVERT 1 RSHIFT       CONSTANT MAX-INT
7734 0 INVERT 1 RSHIFT INVERT    CONSTANT MIN-INT
7735 0 INVERT 1 RSHIFT       CONSTANT MID-UINT
7736 0 INVERT 1 RSHIFT INVERT    CONSTANT MID-UINT+1
7737
7738 0S CONSTANT <FALSE>
7739 1S CONSTANT <TRUE>
7740
7741 T{ 0 0= -> <TRUE> }T
7742 T{ 1 0= -> <FALSE> }T
7743 T{ 2 0= -> <FALSE> }T
7744 T{ -1 0= -> <FALSE> }T
7745 T{ MAX-UINT 0= -> <FALSE> }T
7746 T{ MIN-INT 0= -> <FALSE> }T
7747 T{ MAX-INT 0= -> <FALSE> }T
7748
7749 T{ 0 0 = -> <TRUE> }T
7750 T{ 1 1 = -> <TRUE> }T
7751 T{ -1 -1 = -> <TRUE> }T
7752 T{ 1 0 = -> <FALSE> }T
7753 T{ -1 0 = -> <FALSE> }T
7754 T{ 0 1 = -> <FALSE> }T
7755 T{ 0 -1 = -> <FALSE> }T
7756
7757 T{ 0 0< -> <FALSE> }T
7758 T{ -1 0< -> <TRUE> }T
7759 T{ MIN-INT 0< -> <TRUE> }T
7760 T{ 1 0< -> <FALSE> }T
7761 T{ MAX-INT 0< -> <FALSE> }T
7762
7763 T{ 0 1 < -> <TRUE> }T
7764 T{ 1 2 < -> <TRUE> }T
7765 T{ -1 0 < -> <TRUE> }T
7766 T{ -1 1 < -> <TRUE> }T
7767 T{ MIN-INT 0 < -> <TRUE> }T
7768 T{ MIN-INT MAX-INT < -> <TRUE> }T
7769 T{ 0 MAX-INT < -> <TRUE> }T
7770 T{ 0 0 < -> <FALSE> }T
7771 T{ 1 1 < -> <FALSE> }T
7772 T{ 1 0 < -> <FALSE> }T
7773 T{ 2 1 < -> <FALSE> }T
7774 T{ 0 -1 < -> <FALSE> }T
7775 T{ 1 -1 < -> <FALSE> }T
7776 T{ 0 MIN-INT < -> <FALSE> }T
7777 T{ MAX-INT MIN-INT < -> <FALSE> }T
7778 T{ MAX-INT 0 < -> <FALSE> }T
7779
7780 T{ 0 1 > -> <FALSE> }T
7781 T{ 1 2 > -> <FALSE> }T
7782 T{ -1 0 > -> <FALSE> }T
7783 T{ -1 1 > -> <FALSE> }T
7784 T{ MIN-INT 0 > -> <FALSE> }T
7785 T{ MIN-INT MAX-INT > -> <FALSE> }T
7786 T{ 0 MAX-INT > -> <FALSE> }T
7787 T{ 0 0 > -> <FALSE> }T
7788 T{ 1 1 > -> <FALSE> }T
7789 T{ 1 0 > -> <TRUE> }T
7790 T{ 2 1 > -> <TRUE> }T
7791 T{ 0 -1 > -> <TRUE> }T
7792 T{ 1 -1 > -> <TRUE> }T
7793 T{ 0 MIN-INT > -> <TRUE> }T
7794 T{ MAX-INT MIN-INT > -> <TRUE> }T
7795 T{ MAX-INT 0 > -> <TRUE> }T
7796
7797 T{ 0 1 U< -> <TRUE> }T
7798 T{ 1 2 U< -> <TRUE> }T
7799 T{ 0 MID-UINT U< -> <TRUE> }T
7800 T{ 0 MAX-UINT U< -> <TRUE> }T
7801 T{ MID-UINT MAX-UINT U< -> <TRUE> }T
7802 T{ 0 0 U< -> <FALSE> }T
7803 T{ 1 1 U< -> <FALSE> }T
7804 T{ 1 0 U< -> <FALSE> }T
7805 T{ 2 1 U< -> <FALSE> }T
7806 T{ MID-UINT 0 U< -> <FALSE> }T
7807 T{ MAX-UINT 0 U< -> <FALSE> }T
7808 T{ MAX-UINT MID-UINT U< -> <FALSE> }T
7809
7810 T{ 0 1 MIN -> 0 }T
7811 T{ 1 2 MIN -> 1 }T
7812 T{ -1 0 MIN -> -1 }T
7813 T{ -1 1 MIN -> -1 }T
7814 T{ MIN-INT 0 MIN -> MIN-INT }T
7815 T{ MIN-INT MAX-INT MIN -> MIN-INT }T
7816 T{ 0 MAX-INT MIN -> 0 }T
7817 T{ 0 0 MIN -> 0 }T
7818 T{ 1 1 MIN -> 1 }T
7819 T{ 1 0 MIN -> 0 }T
7820 T{ 2 1 MIN -> 1 }T
7821 T{ 0 -1 MIN -> -1 }T
7822 T{ 1 -1 MIN -> -1 }T
7823 T{ 0 MIN-INT MIN -> MIN-INT }T
7824 T{ MAX-INT MIN-INT MIN -> MIN-INT }T
7825 T{ MAX-INT 0 MIN -> 0 }T
7826
7827 T{ 0 1 MAX -> 1 }T
7828 T{ 1 2 MAX -> 2 }T
7829 T{ -1 0 MAX -> 0 }T
7830 T{ -1 1 MAX -> 1 }T
7831 T{ MIN-INT 0 MAX -> 0 }T
7832 T{ MIN-INT MAX-INT MAX -> MAX-INT }T
7833 T{ 0 MAX-INT MAX -> MAX-INT }T
7834 T{ 0 0 MAX -> 0 }T
7835 T{ 1 1 MAX -> 1 }T
7836 T{ 1 0 MAX -> 1 }T
7837 T{ 2 1 MAX -> 2 }T
7838 T{ 0 -1 MAX -> 0 }T
7839 T{ 1 -1 MAX -> 1 }T
7840 T{ 0 MIN-INT MAX -> 0 }T
7841 T{ MAX-INT MIN-INT MAX -> MAX-INT }T
7842 T{ MAX-INT 0 MAX -> MAX-INT }T
7843
7844 \ ------------------------------------------------------------------------
7845 TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
7846
7847 T{ 1 2 2DROP -> }T
7848 T{ 1 2 2DUP -> 1 2 1 2 }T
7849 T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T
7850 T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T
7851 T{ 0 ?DUP -> 0 }T
7852 T{ 1 ?DUP -> 1 1 }T
7853 T{ -1 ?DUP -> -1 -1 }T
7854 T{ DEPTH -> 0 }T
7855 T{ 0 DEPTH -> 0 1 }T
7856 T{ 0 1 DEPTH -> 0 1 2 }T
7857 T{ 0 DROP -> }T
7858 T{ 1 2 DROP -> 1 }T
7859 T{ 1 DUP -> 1 1 }T
7860 T{ 1 2 OVER -> 1 2 1 }T
7861 T{ 1 2 3 ROT -> 2 3 1 }T
7862 T{ 1 2 SWAP -> 2 1 }T
7863
7864 \ ------------------------------------------------------------------------
7865 TESTING >R R> R@
7866
7867 T{ : GR1 >R R> ; -> }T
7868 T{ : GR2 >R R@ R> DROP ; -> }T
7869 T{ 123 GR1 -> 123 }T
7870 T{ 123 GR2 -> 123 }T
7871 T{ 1S GR1 -> 1S }T   ( RETURN STACK HOLDS CELLS )
7872
7873 \ ------------------------------------------------------------------------
7874 TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
7875
7876 T{ 0 5 + -> 5 }T
7877 T{ 5 0 + -> 5 }T
7878 T{ 0 -5 + -> -5 }T
7879 T{ -5 0 + -> -5 }T
7880 T{ 1 2 + -> 3 }T
7881 T{ 1 -2 + -> -1 }T
7882 T{ -1 2 + -> 1 }T
7883 T{ -1 -2 + -> -3 }T
7884 T{ -1 1 + -> 0 }T
7885 T{ MID-UINT 1 + -> MID-UINT+1 }T
7886
7887 T{ 0 5 - -> -5 }T
7888 T{ 5 0 - -> 5 }T
7889 T{ 0 -5 - -> 5 }T
7890 T{ -5 0 - -> -5 }T
7891 T{ 1 2 - -> -1 }T
7892 T{ 1 -2 - -> 3 }T
7893 T{ -1 2 - -> -3 }T
7894 T{ -1 -2 - -> 1 }T
7895 T{ 0 1 - -> -1 }T
7896 T{ MID-UINT+1 1 - -> MID-UINT }T
7897
7898 T{ 0 1+ -> 1 }T
7899 T{ -1 1+ -> 0 }T
7900 T{ 1 1+ -> 2 }T
7901 T{ MID-UINT 1+ -> MID-UINT+1 }T
7902
7903 T{ 2 1- -> 1 }T
7904 T{ 1 1- -> 0 }T
7905 T{ 0 1- -> -1 }T
7906 T{ MID-UINT+1 1- -> MID-UINT }T
7907
7908 T{ 0 NEGATE -> 0 }T
7909 T{ 1 NEGATE -> -1 }T
7910 T{ -1 NEGATE -> 1 }T
7911 T{ 2 NEGATE -> -2 }T
7912 T{ -2 NEGATE -> 2 }T
7913
7914 T{ 0 ABS -> 0 }T
7915 T{ 1 ABS -> 1 }T
7916 T{ -1 ABS -> 1 }T
7917 T{ MIN-INT ABS -> MID-UINT+1 }T
7918
7919 \ ------------------------------------------------------------------------
7920 TESTING MULTIPLY: S>D * M* UM*
7921
7922 T{ 0 S>D -> 0 0 }T
7923 T{ 1 S>D -> 1 0 }T
7924 T{ 2 S>D -> 2 0 }T
7925 T{ -1 S>D -> -1 -1 }T
7926 T{ -2 S>D -> -2 -1 }T
7927 T{ MIN-INT S>D -> MIN-INT -1 }T
7928 T{ MAX-INT S>D -> MAX-INT 0 }T
7929
7930 T{ 0 0 M* -> 0 S>D }T
7931 T{ 0 1 M* -> 0 S>D }T
7932 T{ 1 0 M* -> 0 S>D }T
7933 T{ 1 2 M* -> 2 S>D }T
7934 T{ 2 1 M* -> 2 S>D }T
7935 T{ 3 3 M* -> 9 S>D }T
7936 T{ -3 3 M* -> -9 S>D }T
7937 T{ 3 -3 M* -> -9 S>D }T
7938 T{ -3 -3 M* -> 9 S>D }T
7939 T{ 0 MIN-INT M* -> 0 S>D }T
7940 T{ 1 MIN-INT M* -> MIN-INT S>D }T
7941 T{ 2 MIN-INT M* -> 0 1S }T
7942 T{ 0 MAX-INT M* -> 0 S>D }T
7943 T{ 1 MAX-INT M* -> MAX-INT S>D }T
7944 T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T
7945 T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T
7946 T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T
7947 T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T
7948
7949 T{ 0 0 * -> 0 }T                \ TEST IDENTITIES
7950 T{ 0 1 * -> 0 }T
7951 T{ 1 0 * -> 0 }T
7952 T{ 1 2 * -> 2 }T
7953 T{ 2 1 * -> 2 }T
7954 T{ 3 3 * -> 9 }T
7955 T{ -3 3 * -> -9 }T
7956 T{ 3 -3 * -> -9 }T
7957 T{ -3 -3 * -> 9 }T
7958
7959 T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T
7960 T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T
7961 T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T
7962
7963 T{ 0 0 UM* -> 0 0 }T
7964 T{ 0 1 UM* -> 0 0 }T
7965 T{ 1 0 UM* -> 0 0 }T
7966 T{ 1 2 UM* -> 2 0 }T
7967 T{ 2 1 UM* -> 2 0 }T
7968 T{ 3 3 UM* -> 9 0 }T
7969
7970 T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T
7971 T{ MID-UINT+1 2 UM* -> 0 1 }T
7972 T{ MID-UINT+1 4 UM* -> 0 2 }T
7973 T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T
7974 T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T
7975
7976 \ ------------------------------------------------------------------------
7977 TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
7978
7979 T{ 0 S>D 1 FM/MOD -> 0 0 }T
7980 T{ 1 S>D 1 FM/MOD -> 0 1 }T
7981 T{ 2 S>D 1 FM/MOD -> 0 2 }T
7982 T{ -1 S>D 1 FM/MOD -> 0 -1 }T
7983 T{ -2 S>D 1 FM/MOD -> 0 -2 }T
7984 T{ 0 S>D -1 FM/MOD -> 0 0 }T
7985 T{ 1 S>D -1 FM/MOD -> 0 -1 }T
7986 T{ 2 S>D -1 FM/MOD -> 0 -2 }T
7987 T{ -1 S>D -1 FM/MOD -> 0 1 }T
7988 T{ -2 S>D -1 FM/MOD -> 0 2 }T
7989 T{ 2 S>D 2 FM/MOD -> 0 1 }T
7990 T{ -1 S>D -1 FM/MOD -> 0 1 }T
7991 T{ -2 S>D -2 FM/MOD -> 0 1 }T
7992 T{  7 S>D  3 FM/MOD -> 1 2 }T
7993 T{  7 S>D -3 FM/MOD -> -2 -3 }T
7994 T{ -7 S>D  3 FM/MOD -> 2 -3 }T
7995 T{ -7 S>D -3 FM/MOD -> -1 2 }T
7996 T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T
7997 T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T
7998 T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T
7999 T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T
8000 T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T
8001 T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T
8002 T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T
8003 T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T
8004 T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T
8005 T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T
8006 T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T
8007 T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T
8008 T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T
8009 T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T
8010 T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T
8011 T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T
8012 T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T
8013
8014 T{ 0 S>D 1 SM/REM -> 0 0 }T
8015 T{ 1 S>D 1 SM/REM -> 0 1 }T
8016 T{ 2 S>D 1 SM/REM -> 0 2 }T
8017 T{ -1 S>D 1 SM/REM -> 0 -1 }T
8018 T{ -2 S>D 1 SM/REM -> 0 -2 }T
8019 T{ 0 S>D -1 SM/REM -> 0 0 }T
8020 T{ 1 S>D -1 SM/REM -> 0 -1 }T
8021 T{ 2 S>D -1 SM/REM -> 0 -2 }T
8022 T{ -1 S>D -1 SM/REM -> 0 1 }T
8023 T{ -2 S>D -1 SM/REM -> 0 2 }T
8024 T{ 2 S>D 2 SM/REM -> 0 1 }T
8025 T{ -1 S>D -1 SM/REM -> 0 1 }T
8026 T{ -2 S>D -2 SM/REM -> 0 1 }T
8027 T{  7 S>D  3 SM/REM -> 1 2 }T
8028 T{  7 S>D -3 SM/REM -> 1 -2 }T
8029 T{ -7 S>D  3 SM/REM -> -1 -2 }T
8030 T{ -7 S>D -3 SM/REM -> -1 2 }T
8031 T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T
8032 T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T
8033 T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T
8034 T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T
8035 T{ 1S 1 4 SM/REM -> 3 MAX-INT }T
8036 T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T
8037 T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T
8038 T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T
8039 T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T
8040 T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T
8041 T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T
8042 T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T
8043 T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T
8044
8045 T{ 0 0 1 UM/MOD -> 0 0 }T
8046 T{ 1 0 1 UM/MOD -> 0 1 }T
8047 T{ 1 0 2 UM/MOD -> 1 0 }T
8048 T{ 3 0 2 UM/MOD -> 1 1 }T
8049 T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T
8050 T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T
8051 T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T
8052
8053 : IFFLOORED
8054     [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
8055
8056 : IFSYM
8057     [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
8058
8059 \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
8060 \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
8061
8062 IFFLOORED : T/MOD  >R S>D R> FM/MOD ;
8063 IFFLOORED : T/     T/MOD SWAP DROP ;
8064 IFFLOORED : TMOD   T/MOD DROP ;
8065 IFFLOORED : T*/MOD >R M* R> FM/MOD ;
8066 IFFLOORED : T*/    T*/MOD SWAP DROP ;
8067 IFSYM     : T/MOD  >R S>D R> SM/REM ;
8068 IFSYM     : T/     T/MOD SWAP DROP ;
8069 IFSYM     : TMOD   T/MOD DROP ;
8070 IFSYM     : T*/MOD >R M* R> SM/REM ;
8071 IFSYM     : T*/    T*/MOD SWAP DROP ;
8072
8073 T{ 0 1 /MOD -> 0 1 T/MOD }T
8074 T{ 1 1 /MOD -> 1 1 T/MOD }T
8075 T{ 2 1 /MOD -> 2 1 T/MOD }T
8076 T{ -1 1 /MOD -> -1 1 T/MOD }T
8077 T{ -2 1 /MOD -> -2 1 T/MOD }T
8078 T{ 0 -1 /MOD -> 0 -1 T/MOD }T
8079 T{ 1 -1 /MOD -> 1 -1 T/MOD }T
8080 T{ 2 -1 /MOD -> 2 -1 T/MOD }T
8081 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
8082 T{ -2 -1 /MOD -> -2 -1 T/MOD }T
8083 T{ 2 2 /MOD -> 2 2 T/MOD }T
8084 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
8085 T{ -2 -2 /MOD -> -2 -2 T/MOD }T
8086 T{ 7 3 /MOD -> 7 3 T/MOD }T
8087 T{ 7 -3 /MOD -> 7 -3 T/MOD }T
8088 T{ -7 3 /MOD -> -7 3 T/MOD }T
8089 T{ -7 -3 /MOD -> -7 -3 T/MOD }T
8090 T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T
8091 T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T
8092 T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T
8093 T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T
8094
8095 T{ 0 1 / -> 0 1 T/ }T
8096 T{ 1 1 / -> 1 1 T/ }T
8097 T{ 2 1 / -> 2 1 T/ }T
8098 T{ -1 1 / -> -1 1 T/ }T
8099 T{ -2 1 / -> -2 1 T/ }T
8100 T{ 0 -1 / -> 0 -1 T/ }T
8101 T{ 1 -1 / -> 1 -1 T/ }T
8102 T{ 2 -1 / -> 2 -1 T/ }T
8103 T{ -1 -1 / -> -1 -1 T/ }T
8104 T{ -2 -1 / -> -2 -1 T/ }T
8105 T{ 2 2 / -> 2 2 T/ }T
8106 T{ -1 -1 / -> -1 -1 T/ }T
8107 T{ -2 -2 / -> -2 -2 T/ }T
8108 T{ 7 3 / -> 7 3 T/ }T
8109 T{ 7 -3 / -> 7 -3 T/ }T
8110 T{ -7 3 / -> -7 3 T/ }T
8111 T{ -7 -3 / -> -7 -3 T/ }T
8112 T{ MAX-INT 1 / -> MAX-INT 1 T/ }T
8113 T{ MIN-INT 1 / -> MIN-INT 1 T/ }T
8114 T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T
8115 T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T
8116
8117 T{ 0 1 MOD -> 0 1 TMOD }T
8118 T{ 1 1 MOD -> 1 1 TMOD }T
8119 T{ 2 1 MOD -> 2 1 TMOD }T
8120 T{ -1 1 MOD -> -1 1 TMOD }T
8121 T{ -2 1 MOD -> -2 1 TMOD }T
8122 T{ 0 -1 MOD -> 0 -1 TMOD }T
8123 T{ 1 -1 MOD -> 1 -1 TMOD }T
8124 T{ 2 -1 MOD -> 2 -1 TMOD }T
8125 T{ -1 -1 MOD -> -1 -1 TMOD }T
8126 T{ -2 -1 MOD -> -2 -1 TMOD }T
8127 T{ 2 2 MOD -> 2 2 TMOD }T
8128 T{ -1 -1 MOD -> -1 -1 TMOD }T
8129 T{ -2 -2 MOD -> -2 -2 TMOD }T
8130 T{ 7 3 MOD -> 7 3 TMOD }T
8131 T{ 7 -3 MOD -> 7 -3 TMOD }T
8132 T{ -7 3 MOD -> -7 3 TMOD }T
8133 T{ -7 -3 MOD -> -7 -3 TMOD }T
8134 T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T
8135 T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T
8136 T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T
8137 T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T
8138
8139 T{ 0 2 1 */ -> 0 2 1 T*/ }T
8140 T{ 1 2 1 */ -> 1 2 1 T*/ }T
8141 T{ 2 2 1 */ -> 2 2 1 T*/ }T
8142 T{ -1 2 1 */ -> -1 2 1 T*/ }T
8143 T{ -2 2 1 */ -> -2 2 1 T*/ }T
8144 T{ 0 2 -1 */ -> 0 2 -1 T*/ }T
8145 T{ 1 2 -1 */ -> 1 2 -1 T*/ }T
8146 T{ 2 2 -1 */ -> 2 2 -1 T*/ }T
8147 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
8148 T{ -2 2 -1 */ -> -2 2 -1 T*/ }T
8149 T{ 2 2 2 */ -> 2 2 2 T*/ }T
8150 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
8151 T{ -2 2 -2 */ -> -2 2 -2 T*/ }T
8152 T{ 7 2 3 */ -> 7 2 3 T*/ }T
8153 T{ 7 2 -3 */ -> 7 2 -3 T*/ }T
8154 T{ -7 2 3 */ -> -7 2 3 T*/ }T
8155 T{ -7 2 -3 */ -> -7 2 -3 T*/ }T
8156 T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T
8157 T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T
8158
8159 T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T
8160 T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T
8161 T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T
8162 T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T
8163 T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T
8164 T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T
8165 T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T
8166 T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T
8167 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
8168 T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T
8169 T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T
8170 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
8171 T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T
8172 T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T
8173 T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T
8174 T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T
8175 T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T
8176 T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T
8177 T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T
8178
8179 \ ------------------------------------------------------------------------
8180 TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
8181
8182 HERE 1 ALLOT
8183 HERE
8184 CONSTANT 2NDA
8185 CONSTANT 1STA
8186 T{ 1STA 2NDA U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
8187 T{ 1STA 1+ -> 2NDA }T           \ ... BY ONE ADDRESS UNIT
8188 ( MISSING TEST: NEGATIVE ALLOT )
8189
8190 HERE 1 ,
8191 HERE 2 ,
8192 CONSTANT 2ND
8193 CONSTANT 1ST
8194 T{ 1ST 2ND U< -> <TRUE> }T          \ HERE MUST GROW WITH ALLOT
8195 T{ 1ST CELL+ -> 2ND }T          \ ... BY ONE CELL
8196 T{ 1ST 1 CELLS + -> 2ND }T
8197 T{ 1ST @ 2ND @ -> 1 2 }T
8198 T{ 5 1ST ! -> }T
8199 T{ 1ST @ 2ND @ -> 5 2 }T
8200 T{ 6 2ND ! -> }T
8201 T{ 1ST @ 2ND @ -> 5 6 }T
8202 T{ 1ST 2@ -> 6 5 }T
8203 T{ 2 1 1ST 2! -> }T
8204 T{ 1ST 2@ -> 2 1 }T
8205 T{ 1S 1ST !  1ST @ -> 1S }T     \ CAN STORE CELL-WIDE VALUE
8206
8207 HERE 1 C,
8208 HERE 2 C,
8209 CONSTANT 2NDC
8210 CONSTANT 1STC
8211 T{ 1STC 2NDC U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
8212 T{ 1STC CHAR+ -> 2NDC }T            \ ... BY ONE CHAR
8213 T{ 1STC 1 CHARS + -> 2NDC }T
8214 T{ 1STC C@ 2NDC C@ -> 1 2 }T
8215 T{ 3 1STC C! -> }T
8216 T{ 1STC C@ 2NDC C@ -> 3 2 }T
8217 T{ 4 2NDC C! -> }T
8218 T{ 1STC C@ 2NDC C@ -> 3 4 }T
8219
8220 ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
8221 CONSTANT A-ADDR  CONSTANT UA-ADDR
8222 T{ UA-ADDR ALIGNED -> A-ADDR }T
8223 T{    1 A-ADDR C!  A-ADDR C@ ->    1 }T
8224 T{ 1234 A-ADDR  !  A-ADDR  @ -> 1234 }T
8225 T{ 123 456 A-ADDR 2!  A-ADDR 2@ -> 123 456 }T
8226 T{ 2 A-ADDR CHAR+ C!  A-ADDR CHAR+ C@ -> 2 }T
8227 T{ 3 A-ADDR CELL+ C!  A-ADDR CELL+ C@ -> 3 }T
8228 T{ 1234 A-ADDR CELL+ !  A-ADDR CELL+ @ -> 1234 }T
8229 T{ 123 456 A-ADDR CELL+ 2!  A-ADDR CELL+ 2@ -> 123 456 }T
8230
8231 : BITS ( X -- U )
8232     0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
8233 ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
8234 T{ 1 CHARS 1 < -> <FALSE> }T
8235 T{ 1 CHARS 1 CELLS > -> <FALSE> }T
8236 ( TBD: HOW TO FIND NUMBER OF BITS? )
8237
8238 ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
8239 T{ 1 CELLS 1 < -> <FALSE> }T
8240 T{ 1 CELLS 1 CHARS MOD -> 0 }T
8241 T{ 1S BITS 10 < -> <FALSE> }T
8242
8243 T{ 0 1ST ! -> }T
8244 T{ 1 1ST +! -> }T
8245 T{ 1ST @ -> 1 }T
8246 T{ -1 1ST +! 1ST @ -> 0 }T
8247
8248 \ ------------------------------------------------------------------------
8249 TESTING CHAR [CHAR] [ ] BL S"
8250
8251 T{ BL -> 20 }T
8252 T{ CHAR X -> 58 }T
8253 T{ CHAR HELLO -> 48 }T
8254 T{ : GC1 [CHAR] X ; -> }T
8255 T{ : GC2 [CHAR] HELLO ; -> }T
8256 T{ GC1 -> 58 }T
8257 T{ GC2 -> 48 }T
8258 T{ : GC3 [ GC1 ] LITERAL ; -> }T
8259 T{ GC3 -> 58 }T
8260 T{ : GC4 S" XY" ; -> }T
8261 T{ GC4 SWAP DROP -> 2 }T
8262 T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T
8263
8264 \ ------------------------------------------------------------------------
8265 TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
8266
8267 T{ : GT1 123 ; -> }T
8268 T{ ' GT1 EXECUTE -> 123 }T
8269 T{ : GT2 ['] GT1 ; IMMEDIATE -> }T
8270 T{ GT2 EXECUTE -> 123 }T
8271 HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
8272 HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
8273 T{ GT1STRING FIND -> ' GT1 -1 }T
8274 T{ GT2STRING FIND -> ' GT2 1 }T
8275 ( HOW TO SEARCH FOR NON-EXISTENT WORD? )
8276 T{ : GT3 GT2 LITERAL ; -> }T
8277 T{ GT3 -> ' GT1 }T
8278 T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T
8279
8280 T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T
8281 T{ : GT5 GT4 ; -> }T
8282 T{ GT5 -> 123 }T
8283 T{ : GT6 345 ; IMMEDIATE -> }T
8284 T{ : GT7 POSTPONE GT6 ; -> }T
8285 T{ GT7 -> 345 }T
8286
8287 T{ : GT8 STATE @ ; IMMEDIATE -> }T
8288 T{ GT8 -> 0 }T
8289 T{ : GT9 GT8 LITERAL ; -> }T
8290 T{ GT9 0= -> <FALSE> }T
8291
8292 \ ------------------------------------------------------------------------
8293 TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
8294
8295 T{ : GI1 IF 123 THEN ; -> }T
8296 T{ : GI2 IF 123 ELSE 234 THEN ; -> }T
8297 T{ 0 GI1 -> }T
8298 T{ 1 GI1 -> 123 }T
8299 T{ -1 GI1 -> 123 }T
8300 T{ 0 GI2 -> 234 }T
8301 T{ 1 GI2 -> 123 }T
8302 T{ -1 GI1 -> 123 }T
8303
8304 T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T
8305 T{ 0 GI3 -> 0 1 2 3 4 5 }T
8306 T{ 4 GI3 -> 4 5 }T
8307 T{ 5 GI3 -> 5 }T
8308 T{ 6 GI3 -> 6 }T
8309
8310 T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T
8311 T{ 3 GI4 -> 3 4 5 6 }T
8312 T{ 5 GI4 -> 5 6 }T
8313 T{ 6 GI4 -> 6 7 }T
8314
8315 T{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T
8316 T{ 1 GI5 -> 1 345 }T
8317 T{ 2 GI5 -> 2 345 }T
8318 T{ 3 GI5 -> 3 4 5 123 }T
8319 T{ 4 GI5 -> 4 5 123 }T
8320 T{ 5 GI5 -> 5 123 }T
8321
8322 T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T
8323 T{ 0 GI6 -> 0 }T
8324 T{ 1 GI6 -> 0 1 }T
8325 T{ 2 GI6 -> 0 1 2 }T
8326 T{ 3 GI6 -> 0 1 2 3 }T
8327 T{ 4 GI6 -> 0 1 2 3 4 }T
8328
8329 \ ------------------------------------------------------------------------
8330 TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
8331
8332 T{ : GD1 DO I LOOP ; -> }T
8333 T{ 4 1 GD1 -> 1 2 3 }T
8334 T{ 2 -1 GD1 -> -1 0 1 }T
8335 T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T
8336
8337 T{ : GD2 DO I -1 +LOOP ; -> }T
8338 T{ 1 4 GD2 -> 4 3 2 1 }T
8339 T{ -1 2 GD2 -> 2 1 0 -1 }T
8340 T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T
8341
8342 T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T
8343 T{ 4 1 GD3 -> 1 2 3 }T
8344 T{ 2 -1 GD3 -> -1 0 1 }T
8345 T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T
8346
8347 T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T
8348 T{ 1 4 GD4 -> 4 3 2 1 }T
8349 T{ -1 2 GD4 -> 2 1 0 -1 }T
8350 T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T
8351
8352 T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T
8353 T{ 1 GD5 -> 123 }T
8354 T{ 5 GD5 -> 123 }T
8355 T{ 6 GD5 -> 234 }T
8356
8357 T{ : GD6  ( PAT: T{0 0}T,T{0 0}TT{1 0}TT{1 1}T,T{0 0}TT{1 0}TT{1 1}TT{2 0}TT{2 1}TT{2 2}T )
8358     0 SWAP 0 DO
8359         I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
8360     LOOP ; -> }T
8361 T{ 1 GD6 -> 1 }T
8362 T{ 2 GD6 -> 3 }T
8363 T{ 3 GD6 -> 4 1 2 }T
8364
8365 \ ------------------------------------------------------------------------
8366 TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
8367
8368 T{ 123 CONSTANT X123 -> }T
8369 T{ X123 -> 123 }T
8370 T{ : EQU CONSTANT ; -> }T
8371 T{ X123 EQU Y123 -> }T
8372 T{ Y123 -> 123 }T
8373
8374 T{ VARIABLE V1 -> }T
8375 T{ 123 V1 ! -> }T
8376 T{ V1 @ -> 123 }T
8377
8378 T{ : NOP : POSTPONE ; ; -> }T
8379 T{ NOP NOP1 NOP NOP2 -> }T
8380 T{ NOP1 -> }T
8381 T{ NOP2 -> }T
8382
8383 T{ : DOES1 DOES> @ 1 + ; -> }T
8384 T{ : DOES2 DOES> @ 2 + ; -> }T
8385 T{ CREATE CR1 -> }T
8386 T{ CR1 -> HERE }T
8387 T{ ' CR1 >BODY -> HERE }T
8388 T{ 1 , -> }T
8389 T{ CR1 @ -> 1 }T
8390 T{ DOES1 -> }T
8391 T{ CR1 -> 2 }T
8392 T{ DOES2 -> }T
8393 T{ CR1 -> 3 }T
8394
8395 T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T
8396 T{ WEIRD: W1 -> }T
8397 T{ ' W1 >BODY -> HERE }T
8398 T{ W1 -> HERE 1 + }T
8399 T{ W1 -> HERE 2 + }T
8400
8401 \ ------------------------------------------------------------------------
8402 TESTING EVALUATE
8403
8404 : GE1 S" 123" ; IMMEDIATE
8405 : GE2 S" 123 1+" ; IMMEDIATE
8406 : GE3 S" : GE4 345 ;" ;
8407 : GE5 EVALUATE ; IMMEDIATE
8408
8409 T{ GE1 EVALUATE -> 123 }T           ( TEST EVALUATE IN INTERP. STATE )
8410 T{ GE2 EVALUATE -> 124 }T
8411 T{ GE3 EVALUATE -> }T
8412 T{ GE4 -> 345 }T
8413
8414 T{ : GE6 GE1 GE5 ; -> }T            ( TEST EVALUATE IN COMPILE STATE )
8415 T{ GE6 -> 123 }T
8416 T{ : GE7 GE2 GE5 ; -> }T
8417 T{ GE7 -> 124 }T
8418
8419 \ ------------------------------------------------------------------------
8420 TESTING SOURCE >IN WORD
8421
8422 : GS1 S" SOURCE" 2DUP EVALUATE
8423         >R SWAP >R = R> R> = ;
8424 T{ GS1 -> <TRUE> <TRUE> }T
8425
8426 VARIABLE SCANS
8427 : RESCAN?  -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
8428
8429 T{ 2 SCANS !
8430 345 RESCAN?
8431 -> 345 345 }T
8432
8433 : GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
8434 T{ GS2 -> 123 123 123 123 123 }T
8435
8436 : GS3 WORD COUNT SWAP C@ ;
8437 T{ BL GS3 HELLO -> 5 CHAR H }T
8438 T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T
8439 T{ BL GS3
8440 DROP -> 0 }T                \ BLANK LINE RETURN ZERO-LENGTH STRING
8441
8442 : GS4 SOURCE >IN ! DROP ;
8443 T{ GS4 123 456
8444 -> }T
8445
8446 \ ------------------------------------------------------------------------
8447 TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
8448
8449 : S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
8450     >R SWAP R@ = IF          \ MAKE SURE STRINGS HAVE SAME LENGTH
8451         R> ?DUP IF            \ IF NON-EMPTY STRINGS
8452         0 DO
8453         OVER C@ OVER C@ - IF
8454             2DROP <FALSE> UNLOOP EXIT THEN
8455         SWAP CHAR+ SWAP CHAR+
8456             LOOP
8457         THEN
8458         2DROP <TRUE>          \ IF WE GET HERE, STRINGS MATCH
8459     ELSE
8460         R> DROP 2DROP <FALSE>     \ LENGTHS MISMATCH
8461     THEN ;
8462
8463 : GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
8464 T{ GP1 -> <TRUE> }T
8465
8466 : GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
8467 T{ GP2 -> <TRUE> }T
8468
8469 : GP3  <# 1 0 # # #> S" 01" S= ;
8470 T{ GP3 -> <TRUE> }T
8471
8472 : GP4  <# 1 0 #S #> S" 1" S= ;
8473 T{ GP4 -> <TRUE> }T
8474
8475 24 CONSTANT MAX-BASE            \ BASE 2 .. 36
8476 : COUNT-BITS
8477     0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
8478 COUNT-BITS 2* CONSTANT #BITS-UD     \ NUMBER OF BITS IN UD
8479
8480 : GP5
8481     BASE @ <TRUE>
8482     MAX-BASE 1+ 2 DO         \ FOR EACH POSSIBLE BASE
8483         I BASE !              \ TBD: ASSUMES BASE WORKS
8484         I 0 <# #S #> S" 10" S= AND
8485     LOOP
8486     SWAP BASE ! ;
8487 T{ GP5 -> <TRUE> }T
8488
8489 : GP6
8490     BASE @ >R  2 BASE !
8491     MAX-UINT MAX-UINT <# #S #>       \ MAXIMUM UD TO BINARY
8492     R> BASE !                \ S: C-ADDR U
8493     DUP #BITS-UD = SWAP
8494     0 DO                 \ S: C-ADDR FLAG
8495         OVER C@ [CHAR] 1 = AND        \ ALL ONES
8496         >R CHAR+ R>
8497     LOOP SWAP DROP ;
8498 T{ GP6 -> <TRUE> }T
8499
8500 : GP7
8501     BASE @ >R    MAX-BASE BASE !
8502     <TRUE>
8503     A 0 DO
8504         I 0 <# #S #>
8505         1 = SWAP C@ I 30 + = AND AND
8506     LOOP
8507     MAX-BASE A DO
8508         I 0 <# #S #>
8509         1 = SWAP C@ 41 I A - + = AND AND
8510     LOOP
8511     R> BASE ! ;
8512
8513 T{ GP7 -> <TRUE> }T
8514
8515 \ >NUMBER TESTS
8516 CREATE GN-BUF 0 C,
8517 : GN-STRING GN-BUF 1 ;
8518 : GN-CONSUMED   GN-BUF CHAR+ 0 ;
8519 : GN'       [CHAR] ' WORD CHAR+ C@ GN-BUF C!  GN-STRING ;
8520
8521 T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T
8522 T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T
8523 T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T
8524 T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T   \ SHOULD FAIL TO CONVERT THESE
8525 T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T
8526 T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T
8527
8528 : >NUMBER-BASED
8529     BASE @ >R BASE ! >NUMBER R> BASE ! ;
8530
8531 T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T
8532 T{ 0 0 GN' 2'  2 >NUMBER-BASED -> 0 0 GN-STRING }T
8533 T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T
8534 T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T
8535 T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T
8536 T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T
8537
8538 : GN1   \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
8539     BASE @ >R BASE !
8540     <# #S #>
8541     0 0 2SWAP >NUMBER SWAP DROP      \ RETURN LENGTH ONLY
8542     R> BASE ! ;
8543 T{ 0 0 2 GN1 -> 0 0 0 }T
8544 T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
8545 T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
8546 T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T
8547 T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T
8548 T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T
8549
8550 : GN2   \ ( -- 16 10 )
8551     BASE @ >R  HEX BASE @  DECIMAL BASE @  R> BASE ! ;
8552 T{ GN2 -> 10 A }T
8553
8554 \ ------------------------------------------------------------------------
8555 TESTING FILL MOVE
8556
8557 CREATE FBUF 00 C, 00 C, 00 C,
8558 CREATE SBUF 12 C, 34 C, 56 C,
8559 : SEEBUF FBUF C@  FBUF CHAR+ C@  FBUF CHAR+ CHAR+ C@ ;
8560
8561 T{ FBUF 0 20 FILL -> }T
8562 T{ SEEBUF -> 00 00 00 }T
8563
8564 T{ FBUF 1 20 FILL -> }T
8565 T{ SEEBUF -> 20 00 00 }T
8566
8567 T{ FBUF 3 20 FILL -> }T
8568 T{ SEEBUF -> 20 20 20 }T
8569
8570 T{ FBUF FBUF 3 CHARS MOVE -> }T     \ BIZARRE SPECIAL CASE
8571 T{ SEEBUF -> 20 20 20 }T
8572
8573 T{ SBUF FBUF 0 CHARS MOVE -> }T
8574 T{ SEEBUF -> 20 20 20 }T
8575
8576 T{ SBUF FBUF 1 CHARS MOVE -> }T
8577 T{ SEEBUF -> 12 20 20 }T
8578
8579 T{ SBUF FBUF 3 CHARS MOVE -> }T
8580 T{ SEEBUF -> 12 34 56 }T
8581
8582 T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T
8583 T{ SEEBUF -> 12 12 34 }T
8584
8585 T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T
8586 T{ SEEBUF -> 12 34 34 }T
8587
8588 \ ------------------------------------------------------------------------
8589 TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
8590
8591 : OUTPUT-TEST
8592     ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
8593     41 BL DO I EMIT LOOP CR
8594     61 41 DO I EMIT LOOP CR
8595     7F 61 DO I EMIT LOOP CR
8596     ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
8597     9 1+ 0 DO I . LOOP CR
8598     ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
8599     [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
8600     ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
8601     [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
8602     ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
8603     5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
8604     ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
8605     S" LINE 1" TYPE CR S" LINE 2" TYPE CR
8606     ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
8607     ."   SIGNED: " MIN-INT . MAX-INT . CR
8608     ." UNSIGNED: " 0 U. MAX-UINT U. CR
8609 ;
8610
8611 T{ OUTPUT-TEST -> }T
8612 \ ------------------------------------------------------------------------
8613 TESTING INPUT: ACCEPT
8614
8615 CREATE ABUF 80 CHARS ALLOT
8616
8617 : ACCEPT-TEST
8618     CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
8619     ABUF 80 ACCEPT
8620     CR ." RECEIVED: " [CHAR] " EMIT
8621     ABUF SWAP TYPE [CHAR] " EMIT CR
8622 ;
8623
8624 T{ ACCEPT-TEST -> }T
8625 Vingt fois sur le métier remettez votre ouvrage, ...
8626 \ ------------------------------------------------------------------------
8627 TESTING DICTIONARY SEARCH RULES
8628
8629 T{ : GDX   123 ; : GDX   GDX 234 ; -> }T
8630
8631 T{ GDX -> 123 234 }T
8632
8633 CR .( End of Core word set tests) CR
8634
8635
8636
8637 RST_STATE   ; so ANS_COMPLEMENT_xx_MPY is conserved ;
8638 \ NOECHO      ; if an error occurs, comment this line before new download to find it.
8639
8640
8641 \ From: John Hayes S1I
8642 \ Subject: tester.fr
8643 \ Date: Mon, 27 Nov 95 13:10:09 PST
8644
8645 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
8646 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
8647 \ VERSION 1.1
8648
8649 \ 22/1/09 The words { and } have been changed to T{ and }T respectively to
8650 \ agree with the Forth 200X file ttester.fs. This avoids clashes with
8651 \ locals using { ... } and the FSL use of }
8652
8653
8654 \ 13/05/14 jmt. added colorised error messages.
8655
8656
8657
8658  0 CONSTANT FALSE
8659 -1 CONSTANT TRUE
8660
8661 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
8662 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
8663 VARIABLE VERBOSE
8664     FALSE VERBOSE !
8665 \   TRUE VERBOSE !
8666
8667 \ : EMPTY-STACK ( ... -- )  \ EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
8668 \     DEPTH ?DUP
8669 \             IF DUP 0< IF NEGATE 0
8670 \             DO 0 LOOP
8671 \             ELSE 0 DO DROP LOOP THEN
8672 \             THEN ;
8673 \
8674 \ : ERROR     \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
8675 \         \ THE LINE THAT HAD THE ERROR.
8676 \     TYPE SOURCE TYPE CR          \ DISPLAY LINE CORRESPONDING TO ERROR
8677 \     EMPTY-STACK              \ THROW AWAY EVERY THING ELSE
8678 \     QUIT  \ *** Uncomment this line to QUIT on an error
8679 \ ;
8680
8681 VARIABLE ACTUAL-DEPTH           \ STACK RECORD
8682 CREATE ACTUAL-RESULTS 20 CELLS ALLOT
8683
8684 : T{        \ ( -- ) SYNTACTIC SUGAR.
8685     ;
8686
8687 : ->        \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
8688     DEPTH DUP ACTUAL-DEPTH !     \ RECORD DEPTH
8689     ?DUP IF              \ IF THERE IS SOMETHING ON STACK
8690         0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
8691     THEN ;
8692
8693 : }T        \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
8694             \ (ACTUAL) CONTENTS.
8695     DEPTH ACTUAL-DEPTH @ = IF   \ IF DEPTHS MATCH
8696         DEPTH ?DUP IF           \ IF THERE IS SOMETHING ON THE STACK
8697         0 DO                    \ FOR EACH STACK ITEM
8698             ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
8699 \           = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN   \ jmt
8700             = 0= IF ABORT" INCORRECT RESULT: " THEN           \ jmt : colorised message
8701         LOOP
8702         THEN
8703     ELSE                 \ DEPTH MISMATCH
8704 \       S" WRONG NUMBER OF RESULTS: " ERROR \ jmt
8705         ABORT" WRONG NUMBER OF RESULTS: "   \ jmt : colorised message
8706     THEN ;
8707
8708 : TESTING   \ ( -- ) TALKING COMMENT.
8709     SOURCE VERBOSE @
8710     IF DUP >R TYPE CR R> >IN !
8711     ELSE >IN ! DROP [CHAR] * EMIT
8712     THEN ;
8713
8714 \ From: John Hayes S1I
8715 \ Subject: core.fr
8716 \ Date: Mon, 27 Nov 95 13:10
8717
8718 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
8719 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
8720 \ VERSION 1.2
8721 \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
8722 \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
8723 \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
8724 \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
8725 \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
8726 \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
8727
8728 CR
8729 TESTING CORE WORDS
8730 HEX
8731
8732 \ ------------------------------------------------------------------------
8733 TESTING BASIC ASSUMPTIONS
8734
8735 T{ -> }T                    \ START WITH CLEAN SLATE
8736 ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
8737 T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T
8738 T{  0 BITSSET? -> 0 }T      ( ZERO IS ALL BITS CLEAR )
8739 T{  1 BITSSET? -> 0 0 }T        ( OTHER NUMBER HAVE AT LEAST ONE BIT )
8740 T{ -1 BITSSET? -> 0 0 }T
8741
8742 \ ------------------------------------------------------------------------
8743 TESTING BOOLEANS: INVERT AND OR XOR
8744
8745 T{ 0 0 AND -> 0 }T
8746 T{ 0 1 AND -> 0 }T
8747 T{ 1 0 AND -> 0 }T
8748 T{ 1 1 AND -> 1 }T
8749
8750 T{ 0 INVERT 1 AND -> 1 }T
8751 T{ 1 INVERT 1 AND -> 0 }T
8752
8753 0    CONSTANT 0S
8754 0 INVERT CONSTANT 1S
8755
8756 T{ 0S INVERT -> 1S }T
8757 T{ 1S INVERT -> 0S }T
8758
8759 T{ 0S 0S AND -> 0S }T
8760 T{ 0S 1S AND -> 0S }T
8761 T{ 1S 0S AND -> 0S }T
8762 T{ 1S 1S AND -> 1S }T
8763
8764 T{ 0S 0S OR -> 0S }T
8765 T{ 0S 1S OR -> 1S }T
8766 T{ 1S 0S OR -> 1S }T
8767 T{ 1S 1S OR -> 1S }T
8768
8769 T{ 0S 0S XOR -> 0S }T
8770 T{ 0S 1S XOR -> 1S }T
8771 T{ 1S 0S XOR -> 1S }T
8772 T{ 1S 1S XOR -> 0S }T
8773
8774 \ ------------------------------------------------------------------------
8775 TESTING 2* 2/ LSHIFT RSHIFT
8776
8777 ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
8778 1S 1 RSHIFT INVERT CONSTANT MSB
8779 T{ MSB BITSSET? -> 0 0 }T
8780
8781 T{ 0S 2* -> 0S }T
8782 T{ 1 2* -> 2 }T
8783 T{ 4000 2* -> 8000 }T
8784 T{ 1S 2* 1 XOR -> 1S }T
8785 T{ MSB 2* -> 0S }T
8786
8787 T{ 0S 2/ -> 0S }T
8788 T{ 1 2/ -> 0 }T
8789 T{ 4000 2/ -> 2000 }T
8790 T{ 1S 2/ -> 1S }T               \ MSB PROPOGATED
8791 T{ 1S 1 XOR 2/ -> 1S }T
8792 T{ MSB 2/ MSB AND -> MSB }T
8793
8794 T{ 1 0 LSHIFT -> 1 }T
8795 T{ 1 1 LSHIFT -> 2 }T
8796 T{ 1 2 LSHIFT -> 4 }T
8797 T{ 1 F LSHIFT -> 8000 }T            \ BIGGEST GUARANTEED SHIFT
8798 T{ 1S 1 LSHIFT 1 XOR -> 1S }T
8799 T{ MSB 1 LSHIFT -> 0 }T
8800
8801 T{ 1 0 RSHIFT -> 1 }T
8802 T{ 1 1 RSHIFT -> 0 }T
8803 T{ 2 1 RSHIFT -> 1 }T
8804 T{ 4 2 RSHIFT -> 1 }T
8805 T{ 8000 F RSHIFT -> 1 }T            \ BIGGEST
8806 T{ MSB 1 RSHIFT MSB AND -> 0 }T     \ RSHIFT ZERO FILLS MSBS
8807 T{ MSB 1 RSHIFT 2* -> MSB }T
8808
8809 \ ------------------------------------------------------------------------
8810 TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
8811 0 INVERT            CONSTANT MAX-UINT
8812 0 INVERT 1 RSHIFT       CONSTANT MAX-INT
8813 0 INVERT 1 RSHIFT INVERT    CONSTANT MIN-INT
8814 0 INVERT 1 RSHIFT       CONSTANT MID-UINT
8815 0 INVERT 1 RSHIFT INVERT    CONSTANT MID-UINT+1
8816
8817 0S CONSTANT <FALSE>
8818 1S CONSTANT <TRUE>
8819
8820 T{ 0 0= -> <TRUE> }T
8821 T{ 1 0= -> <FALSE> }T
8822 T{ 2 0= -> <FALSE> }T
8823 T{ -1 0= -> <FALSE> }T
8824 T{ MAX-UINT 0= -> <FALSE> }T
8825 T{ MIN-INT 0= -> <FALSE> }T
8826 T{ MAX-INT 0= -> <FALSE> }T
8827
8828 T{ 0 0 = -> <TRUE> }T
8829 T{ 1 1 = -> <TRUE> }T
8830 T{ -1 -1 = -> <TRUE> }T
8831 T{ 1 0 = -> <FALSE> }T
8832 T{ -1 0 = -> <FALSE> }T
8833 T{ 0 1 = -> <FALSE> }T
8834 T{ 0 -1 = -> <FALSE> }T
8835
8836 T{ 0 0< -> <FALSE> }T
8837 T{ -1 0< -> <TRUE> }T
8838 T{ MIN-INT 0< -> <TRUE> }T
8839 T{ 1 0< -> <FALSE> }T
8840 T{ MAX-INT 0< -> <FALSE> }T
8841
8842 T{ 0 1 < -> <TRUE> }T
8843 T{ 1 2 < -> <TRUE> }T
8844 T{ -1 0 < -> <TRUE> }T
8845 T{ -1 1 < -> <TRUE> }T
8846 T{ MIN-INT 0 < -> <TRUE> }T
8847 T{ MIN-INT MAX-INT < -> <TRUE> }T
8848 T{ 0 MAX-INT < -> <TRUE> }T
8849 T{ 0 0 < -> <FALSE> }T
8850 T{ 1 1 < -> <FALSE> }T
8851 T{ 1 0 < -> <FALSE> }T
8852 T{ 2 1 < -> <FALSE> }T
8853 T{ 0 -1 < -> <FALSE> }T
8854 T{ 1 -1 < -> <FALSE> }T
8855 T{ 0 MIN-INT < -> <FALSE> }T
8856 T{ MAX-INT MIN-INT < -> <FALSE> }T
8857 T{ MAX-INT 0 < -> <FALSE> }T
8858
8859 T{ 0 1 > -> <FALSE> }T
8860 T{ 1 2 > -> <FALSE> }T
8861 T{ -1 0 > -> <FALSE> }T
8862 T{ -1 1 > -> <FALSE> }T
8863 T{ MIN-INT 0 > -> <FALSE> }T
8864 T{ MIN-INT MAX-INT > -> <FALSE> }T
8865 T{ 0 MAX-INT > -> <FALSE> }T
8866 T{ 0 0 > -> <FALSE> }T
8867 T{ 1 1 > -> <FALSE> }T
8868 T{ 1 0 > -> <TRUE> }T
8869 T{ 2 1 > -> <TRUE> }T
8870 T{ 0 -1 > -> <TRUE> }T
8871 T{ 1 -1 > -> <TRUE> }T
8872 T{ 0 MIN-INT > -> <TRUE> }T
8873 T{ MAX-INT MIN-INT > -> <TRUE> }T
8874 T{ MAX-INT 0 > -> <TRUE> }T
8875
8876 T{ 0 1 U< -> <TRUE> }T
8877 T{ 1 2 U< -> <TRUE> }T
8878 T{ 0 MID-UINT U< -> <TRUE> }T
8879 T{ 0 MAX-UINT U< -> <TRUE> }T
8880 T{ MID-UINT MAX-UINT U< -> <TRUE> }T
8881 T{ 0 0 U< -> <FALSE> }T
8882 T{ 1 1 U< -> <FALSE> }T
8883 T{ 1 0 U< -> <FALSE> }T
8884 T{ 2 1 U< -> <FALSE> }T
8885 T{ MID-UINT 0 U< -> <FALSE> }T
8886 T{ MAX-UINT 0 U< -> <FALSE> }T
8887 T{ MAX-UINT MID-UINT U< -> <FALSE> }T
8888
8889 T{ 0 1 MIN -> 0 }T
8890 T{ 1 2 MIN -> 1 }T
8891 T{ -1 0 MIN -> -1 }T
8892 T{ -1 1 MIN -> -1 }T
8893 T{ MIN-INT 0 MIN -> MIN-INT }T
8894 T{ MIN-INT MAX-INT MIN -> MIN-INT }T
8895 T{ 0 MAX-INT MIN -> 0 }T
8896 T{ 0 0 MIN -> 0 }T
8897 T{ 1 1 MIN -> 1 }T
8898 T{ 1 0 MIN -> 0 }T
8899 T{ 2 1 MIN -> 1 }T
8900 T{ 0 -1 MIN -> -1 }T
8901 T{ 1 -1 MIN -> -1 }T
8902 T{ 0 MIN-INT MIN -> MIN-INT }T
8903 T{ MAX-INT MIN-INT MIN -> MIN-INT }T
8904 T{ MAX-INT 0 MIN -> 0 }T
8905
8906 T{ 0 1 MAX -> 1 }T
8907 T{ 1 2 MAX -> 2 }T
8908 T{ -1 0 MAX -> 0 }T
8909 T{ -1 1 MAX -> 1 }T
8910 T{ MIN-INT 0 MAX -> 0 }T
8911 T{ MIN-INT MAX-INT MAX -> MAX-INT }T
8912 T{ 0 MAX-INT MAX -> MAX-INT }T
8913 T{ 0 0 MAX -> 0 }T
8914 T{ 1 1 MAX -> 1 }T
8915 T{ 1 0 MAX -> 1 }T
8916 T{ 2 1 MAX -> 2 }T
8917 T{ 0 -1 MAX -> 0 }T
8918 T{ 1 -1 MAX -> 1 }T
8919 T{ 0 MIN-INT MAX -> 0 }T
8920 T{ MAX-INT MIN-INT MAX -> MAX-INT }T
8921 T{ MAX-INT 0 MAX -> MAX-INT }T
8922
8923 \ ------------------------------------------------------------------------
8924 TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
8925
8926 T{ 1 2 2DROP -> }T
8927 T{ 1 2 2DUP -> 1 2 1 2 }T
8928 T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T
8929 T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T
8930 T{ 0 ?DUP -> 0 }T
8931 T{ 1 ?DUP -> 1 1 }T
8932 T{ -1 ?DUP -> -1 -1 }T
8933 T{ DEPTH -> 0 }T
8934 T{ 0 DEPTH -> 0 1 }T
8935 T{ 0 1 DEPTH -> 0 1 2 }T
8936 T{ 0 DROP -> }T
8937 T{ 1 2 DROP -> 1 }T
8938 T{ 1 DUP -> 1 1 }T
8939 T{ 1 2 OVER -> 1 2 1 }T
8940 T{ 1 2 3 ROT -> 2 3 1 }T
8941 T{ 1 2 SWAP -> 2 1 }T
8942
8943 \ ------------------------------------------------------------------------
8944 TESTING >R R> R@
8945
8946 T{ : GR1 >R R> ; -> }T
8947 T{ : GR2 >R R@ R> DROP ; -> }T
8948 T{ 123 GR1 -> 123 }T
8949 T{ 123 GR2 -> 123 }T
8950 T{ 1S GR1 -> 1S }T   ( RETURN STACK HOLDS CELLS )
8951
8952 \ ------------------------------------------------------------------------
8953 TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
8954
8955 T{ 0 5 + -> 5 }T
8956 T{ 5 0 + -> 5 }T
8957 T{ 0 -5 + -> -5 }T
8958 T{ -5 0 + -> -5 }T
8959 T{ 1 2 + -> 3 }T
8960 T{ 1 -2 + -> -1 }T
8961 T{ -1 2 + -> 1 }T
8962 T{ -1 -2 + -> -3 }T
8963 T{ -1 1 + -> 0 }T
8964 T{ MID-UINT 1 + -> MID-UINT+1 }T
8965
8966 T{ 0 5 - -> -5 }T
8967 T{ 5 0 - -> 5 }T
8968 T{ 0 -5 - -> 5 }T
8969 T{ -5 0 - -> -5 }T
8970 T{ 1 2 - -> -1 }T
8971 T{ 1 -2 - -> 3 }T
8972 T{ -1 2 - -> -3 }T
8973 T{ -1 -2 - -> 1 }T
8974 T{ 0 1 - -> -1 }T
8975 T{ MID-UINT+1 1 - -> MID-UINT }T
8976
8977 T{ 0 1+ -> 1 }T
8978 T{ -1 1+ -> 0 }T
8979 T{ 1 1+ -> 2 }T
8980 T{ MID-UINT 1+ -> MID-UINT+1 }T
8981
8982 T{ 2 1- -> 1 }T
8983 T{ 1 1- -> 0 }T
8984 T{ 0 1- -> -1 }T
8985 T{ MID-UINT+1 1- -> MID-UINT }T
8986
8987 T{ 0 NEGATE -> 0 }T
8988 T{ 1 NEGATE -> -1 }T
8989 T{ -1 NEGATE -> 1 }T
8990 T{ 2 NEGATE -> -2 }T
8991 T{ -2 NEGATE -> 2 }T
8992
8993 T{ 0 ABS -> 0 }T
8994 T{ 1 ABS -> 1 }T
8995 T{ -1 ABS -> 1 }T
8996 T{ MIN-INT ABS -> MID-UINT+1 }T
8997
8998 \ ------------------------------------------------------------------------
8999 TESTING MULTIPLY: S>D * M* UM*
9000
9001 T{ 0 S>D -> 0 0 }T
9002 T{ 1 S>D -> 1 0 }T
9003 T{ 2 S>D -> 2 0 }T
9004 T{ -1 S>D -> -1 -1 }T
9005 T{ -2 S>D -> -2 -1 }T
9006 T{ MIN-INT S>D -> MIN-INT -1 }T
9007 T{ MAX-INT S>D -> MAX-INT 0 }T
9008
9009 T{ 0 0 M* -> 0 S>D }T
9010 T{ 0 1 M* -> 0 S>D }T
9011 T{ 1 0 M* -> 0 S>D }T
9012 T{ 1 2 M* -> 2 S>D }T
9013 T{ 2 1 M* -> 2 S>D }T
9014 T{ 3 3 M* -> 9 S>D }T
9015 T{ -3 3 M* -> -9 S>D }T
9016 T{ 3 -3 M* -> -9 S>D }T
9017 T{ -3 -3 M* -> 9 S>D }T
9018 T{ 0 MIN-INT M* -> 0 S>D }T
9019 T{ 1 MIN-INT M* -> MIN-INT S>D }T
9020 T{ 2 MIN-INT M* -> 0 1S }T
9021 T{ 0 MAX-INT M* -> 0 S>D }T
9022 T{ 1 MAX-INT M* -> MAX-INT S>D }T
9023 T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T
9024 T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T
9025 T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T
9026 T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T
9027
9028 T{ 0 0 * -> 0 }T                \ TEST IDENTITIES
9029 T{ 0 1 * -> 0 }T
9030 T{ 1 0 * -> 0 }T
9031 T{ 1 2 * -> 2 }T
9032 T{ 2 1 * -> 2 }T
9033 T{ 3 3 * -> 9 }T
9034 T{ -3 3 * -> -9 }T
9035 T{ 3 -3 * -> -9 }T
9036 T{ -3 -3 * -> 9 }T
9037
9038 T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T
9039 T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T
9040 T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T
9041
9042 T{ 0 0 UM* -> 0 0 }T
9043 T{ 0 1 UM* -> 0 0 }T
9044 T{ 1 0 UM* -> 0 0 }T
9045 T{ 1 2 UM* -> 2 0 }T
9046 T{ 2 1 UM* -> 2 0 }T
9047 T{ 3 3 UM* -> 9 0 }T
9048
9049 T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T
9050 T{ MID-UINT+1 2 UM* -> 0 1 }T
9051 T{ MID-UINT+1 4 UM* -> 0 2 }T
9052 T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T
9053 T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T
9054
9055 \ ------------------------------------------------------------------------
9056 TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
9057
9058 T{ 0 S>D 1 FM/MOD -> 0 0 }T
9059 T{ 1 S>D 1 FM/MOD -> 0 1 }T
9060 T{ 2 S>D 1 FM/MOD -> 0 2 }T
9061 T{ -1 S>D 1 FM/MOD -> 0 -1 }T
9062 T{ -2 S>D 1 FM/MOD -> 0 -2 }T
9063 T{ 0 S>D -1 FM/MOD -> 0 0 }T
9064 T{ 1 S>D -1 FM/MOD -> 0 -1 }T
9065 T{ 2 S>D -1 FM/MOD -> 0 -2 }T
9066 T{ -1 S>D -1 FM/MOD -> 0 1 }T
9067 T{ -2 S>D -1 FM/MOD -> 0 2 }T
9068 T{ 2 S>D 2 FM/MOD -> 0 1 }T
9069 T{ -1 S>D -1 FM/MOD -> 0 1 }T
9070 T{ -2 S>D -2 FM/MOD -> 0 1 }T
9071 T{  7 S>D  3 FM/MOD -> 1 2 }T
9072 T{  7 S>D -3 FM/MOD -> -2 -3 }T
9073 T{ -7 S>D  3 FM/MOD -> 2 -3 }T
9074 T{ -7 S>D -3 FM/MOD -> -1 2 }T
9075 T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T
9076 T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T
9077 T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T
9078 T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T
9079 T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T
9080 T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T
9081 T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T
9082 T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T
9083 T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T
9084 T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T
9085 T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T
9086 T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T
9087 T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T
9088 T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T
9089 T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T
9090 T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T
9091 T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T
9092
9093 T{ 0 S>D 1 SM/REM -> 0 0 }T
9094 T{ 1 S>D 1 SM/REM -> 0 1 }T
9095 T{ 2 S>D 1 SM/REM -> 0 2 }T
9096 T{ -1 S>D 1 SM/REM -> 0 -1 }T
9097 T{ -2 S>D 1 SM/REM -> 0 -2 }T
9098 T{ 0 S>D -1 SM/REM -> 0 0 }T
9099 T{ 1 S>D -1 SM/REM -> 0 -1 }T
9100 T{ 2 S>D -1 SM/REM -> 0 -2 }T
9101 T{ -1 S>D -1 SM/REM -> 0 1 }T
9102 T{ -2 S>D -1 SM/REM -> 0 2 }T
9103 T{ 2 S>D 2 SM/REM -> 0 1 }T
9104 T{ -1 S>D -1 SM/REM -> 0 1 }T
9105 T{ -2 S>D -2 SM/REM -> 0 1 }T
9106 T{  7 S>D  3 SM/REM -> 1 2 }T
9107 T{  7 S>D -3 SM/REM -> 1 -2 }T
9108 T{ -7 S>D  3 SM/REM -> -1 -2 }T
9109 T{ -7 S>D -3 SM/REM -> -1 2 }T
9110 T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T
9111 T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T
9112 T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T
9113 T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T
9114 T{ 1S 1 4 SM/REM -> 3 MAX-INT }T
9115 T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T
9116 T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T
9117 T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T
9118 T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T
9119 T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T
9120 T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T
9121 T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T
9122 T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T
9123
9124 T{ 0 0 1 UM/MOD -> 0 0 }T
9125 T{ 1 0 1 UM/MOD -> 0 1 }T
9126 T{ 1 0 2 UM/MOD -> 1 0 }T
9127 T{ 3 0 2 UM/MOD -> 1 1 }T
9128 T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T
9129 T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T
9130 T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T
9131
9132 : IFFLOORED
9133     [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
9134
9135 : IFSYM
9136     [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
9137
9138 \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
9139 \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
9140
9141 IFFLOORED : T/MOD  >R S>D R> FM/MOD ;
9142 IFFLOORED : T/     T/MOD SWAP DROP ;
9143 IFFLOORED : TMOD   T/MOD DROP ;
9144 IFFLOORED : T*/MOD >R M* R> FM/MOD ;
9145 IFFLOORED : T*/    T*/MOD SWAP DROP ;
9146 IFSYM     : T/MOD  >R S>D R> SM/REM ;
9147 IFSYM     : T/     T/MOD SWAP DROP ;
9148 IFSYM     : TMOD   T/MOD DROP ;
9149 IFSYM     : T*/MOD >R M* R> SM/REM ;
9150 IFSYM     : T*/    T*/MOD SWAP DROP ;
9151
9152 T{ 0 1 /MOD -> 0 1 T/MOD }T
9153 T{ 1 1 /MOD -> 1 1 T/MOD }T
9154 T{ 2 1 /MOD -> 2 1 T/MOD }T
9155 T{ -1 1 /MOD -> -1 1 T/MOD }T
9156 T{ -2 1 /MOD -> -2 1 T/MOD }T
9157 T{ 0 -1 /MOD -> 0 -1 T/MOD }T
9158 T{ 1 -1 /MOD -> 1 -1 T/MOD }T
9159 T{ 2 -1 /MOD -> 2 -1 T/MOD }T
9160 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
9161 T{ -2 -1 /MOD -> -2 -1 T/MOD }T
9162 T{ 2 2 /MOD -> 2 2 T/MOD }T
9163 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
9164 T{ -2 -2 /MOD -> -2 -2 T/MOD }T
9165 T{ 7 3 /MOD -> 7 3 T/MOD }T
9166 T{ 7 -3 /MOD -> 7 -3 T/MOD }T
9167 T{ -7 3 /MOD -> -7 3 T/MOD }T
9168 T{ -7 -3 /MOD -> -7 -3 T/MOD }T
9169 T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T
9170 T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T
9171 T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T
9172 T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T
9173
9174 T{ 0 1 / -> 0 1 T/ }T
9175 T{ 1 1 / -> 1 1 T/ }T
9176 T{ 2 1 / -> 2 1 T/ }T
9177 T{ -1 1 / -> -1 1 T/ }T
9178 T{ -2 1 / -> -2 1 T/ }T
9179 T{ 0 -1 / -> 0 -1 T/ }T
9180 T{ 1 -1 / -> 1 -1 T/ }T
9181 T{ 2 -1 / -> 2 -1 T/ }T
9182 T{ -1 -1 / -> -1 -1 T/ }T
9183 T{ -2 -1 / -> -2 -1 T/ }T
9184 T{ 2 2 / -> 2 2 T/ }T
9185 T{ -1 -1 / -> -1 -1 T/ }T
9186 T{ -2 -2 / -> -2 -2 T/ }T
9187 T{ 7 3 / -> 7 3 T/ }T
9188 T{ 7 -3 / -> 7 -3 T/ }T
9189 T{ -7 3 / -> -7 3 T/ }T
9190 T{ -7 -3 / -> -7 -3 T/ }T
9191 T{ MAX-INT 1 / -> MAX-INT 1 T/ }T
9192 T{ MIN-INT 1 / -> MIN-INT 1 T/ }T
9193 T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T
9194 T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T
9195
9196 T{ 0 1 MOD -> 0 1 TMOD }T
9197 T{ 1 1 MOD -> 1 1 TMOD }T
9198 T{ 2 1 MOD -> 2 1 TMOD }T
9199 T{ -1 1 MOD -> -1 1 TMOD }T
9200 T{ -2 1 MOD -> -2 1 TMOD }T
9201 T{ 0 -1 MOD -> 0 -1 TMOD }T
9202 T{ 1 -1 MOD -> 1 -1 TMOD }T
9203 T{ 2 -1 MOD -> 2 -1 TMOD }T
9204 T{ -1 -1 MOD -> -1 -1 TMOD }T
9205 T{ -2 -1 MOD -> -2 -1 TMOD }T
9206 T{ 2 2 MOD -> 2 2 TMOD }T
9207 T{ -1 -1 MOD -> -1 -1 TMOD }T
9208 T{ -2 -2 MOD -> -2 -2 TMOD }T
9209 T{ 7 3 MOD -> 7 3 TMOD }T
9210 T{ 7 -3 MOD -> 7 -3 TMOD }T
9211 T{ -7 3 MOD -> -7 3 TMOD }T
9212 T{ -7 -3 MOD -> -7 -3 TMOD }T
9213 T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T
9214 T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T
9215 T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T
9216 T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T
9217
9218 T{ 0 2 1 */ -> 0 2 1 T*/ }T
9219 T{ 1 2 1 */ -> 1 2 1 T*/ }T
9220 T{ 2 2 1 */ -> 2 2 1 T*/ }T
9221 T{ -1 2 1 */ -> -1 2 1 T*/ }T
9222 T{ -2 2 1 */ -> -2 2 1 T*/ }T
9223 T{ 0 2 -1 */ -> 0 2 -1 T*/ }T
9224 T{ 1 2 -1 */ -> 1 2 -1 T*/ }T
9225 T{ 2 2 -1 */ -> 2 2 -1 T*/ }T
9226 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
9227 T{ -2 2 -1 */ -> -2 2 -1 T*/ }T
9228 T{ 2 2 2 */ -> 2 2 2 T*/ }T
9229 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
9230 T{ -2 2 -2 */ -> -2 2 -2 T*/ }T
9231 T{ 7 2 3 */ -> 7 2 3 T*/ }T
9232 T{ 7 2 -3 */ -> 7 2 -3 T*/ }T
9233 T{ -7 2 3 */ -> -7 2 3 T*/ }T
9234 T{ -7 2 -3 */ -> -7 2 -3 T*/ }T
9235 T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T
9236 T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T
9237
9238 T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T
9239 T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T
9240 T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T
9241 T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T
9242 T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T
9243 T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T
9244 T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T
9245 T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T
9246 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
9247 T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T
9248 T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T
9249 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
9250 T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T
9251 T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T
9252 T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T
9253 T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T
9254 T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T
9255 T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T
9256 T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T
9257
9258 \ ------------------------------------------------------------------------
9259 TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
9260
9261 HERE 1 ALLOT
9262 HERE
9263 CONSTANT 2NDA
9264 CONSTANT 1STA
9265 T{ 1STA 2NDA U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
9266 T{ 1STA 1+ -> 2NDA }T           \ ... BY ONE ADDRESS UNIT
9267 ( MISSING TEST: NEGATIVE ALLOT )
9268
9269 HERE 1 ,
9270 HERE 2 ,
9271 CONSTANT 2ND
9272 CONSTANT 1ST
9273 T{ 1ST 2ND U< -> <TRUE> }T          \ HERE MUST GROW WITH ALLOT
9274 T{ 1ST CELL+ -> 2ND }T          \ ... BY ONE CELL
9275 T{ 1ST 1 CELLS + -> 2ND }T
9276 T{ 1ST @ 2ND @ -> 1 2 }T
9277 T{ 5 1ST ! -> }T
9278 T{ 1ST @ 2ND @ -> 5 2 }T
9279 T{ 6 2ND ! -> }T
9280 T{ 1ST @ 2ND @ -> 5 6 }T
9281 T{ 1ST 2@ -> 6 5 }T
9282 T{ 2 1 1ST 2! -> }T
9283 T{ 1ST 2@ -> 2 1 }T
9284 T{ 1S 1ST !  1ST @ -> 1S }T     \ CAN STORE CELL-WIDE VALUE
9285
9286 HERE 1 C,
9287 HERE 2 C,
9288 CONSTANT 2NDC
9289 CONSTANT 1STC
9290 T{ 1STC 2NDC U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
9291 T{ 1STC CHAR+ -> 2NDC }T            \ ... BY ONE CHAR
9292 T{ 1STC 1 CHARS + -> 2NDC }T
9293 T{ 1STC C@ 2NDC C@ -> 1 2 }T
9294 T{ 3 1STC C! -> }T
9295 T{ 1STC C@ 2NDC C@ -> 3 2 }T
9296 T{ 4 2NDC C! -> }T
9297 T{ 1STC C@ 2NDC C@ -> 3 4 }T
9298
9299 ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
9300 CONSTANT A-ADDR  CONSTANT UA-ADDR
9301 T{ UA-ADDR ALIGNED -> A-ADDR }T
9302 T{    1 A-ADDR C!  A-ADDR C@ ->    1 }T
9303 T{ 1234 A-ADDR  !  A-ADDR  @ -> 1234 }T
9304 T{ 123 456 A-ADDR 2!  A-ADDR 2@ -> 123 456 }T
9305 T{ 2 A-ADDR CHAR+ C!  A-ADDR CHAR+ C@ -> 2 }T
9306 T{ 3 A-ADDR CELL+ C!  A-ADDR CELL+ C@ -> 3 }T
9307 T{ 1234 A-ADDR CELL+ !  A-ADDR CELL+ @ -> 1234 }T
9308 T{ 123 456 A-ADDR CELL+ 2!  A-ADDR CELL+ 2@ -> 123 456 }T
9309
9310 : BITS ( X -- U )
9311     0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
9312 ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
9313 T{ 1 CHARS 1 < -> <FALSE> }T
9314 T{ 1 CHARS 1 CELLS > -> <FALSE> }T
9315 ( TBD: HOW TO FIND NUMBER OF BITS? )
9316
9317 ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
9318 T{ 1 CELLS 1 < -> <FALSE> }T
9319 T{ 1 CELLS 1 CHARS MOD -> 0 }T
9320 T{ 1S BITS 10 < -> <FALSE> }T
9321
9322 T{ 0 1ST ! -> }T
9323 T{ 1 1ST +! -> }T
9324 T{ 1ST @ -> 1 }T
9325 T{ -1 1ST +! 1ST @ -> 0 }T
9326
9327 \ ------------------------------------------------------------------------
9328 TESTING CHAR [CHAR] [ ] BL S"
9329
9330 T{ BL -> 20 }T
9331 T{ CHAR X -> 58 }T
9332 T{ CHAR HELLO -> 48 }T
9333 T{ : GC1 [CHAR] X ; -> }T
9334 T{ : GC2 [CHAR] HELLO ; -> }T
9335 T{ GC1 -> 58 }T
9336 T{ GC2 -> 48 }T
9337 T{ : GC3 [ GC1 ] LITERAL ; -> }T
9338 T{ GC3 -> 58 }T
9339 T{ : GC4 S" XY" ; -> }T
9340 T{ GC4 SWAP DROP -> 2 }T
9341 T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T
9342
9343 \ ------------------------------------------------------------------------
9344 TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
9345
9346 T{ : GT1 123 ; -> }T
9347 T{ ' GT1 EXECUTE -> 123 }T
9348 T{ : GT2 ['] GT1 ; IMMEDIATE -> }T
9349 T{ GT2 EXECUTE -> 123 }T
9350 HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
9351 HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
9352 T{ GT1STRING FIND -> ' GT1 -1 }T
9353 T{ GT2STRING FIND -> ' GT2 1 }T
9354 ( HOW TO SEARCH FOR NON-EXISTENT WORD? )
9355 T{ : GT3 GT2 LITERAL ; -> }T
9356 T{ GT3 -> ' GT1 }T
9357 T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T
9358
9359 T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T
9360 T{ : GT5 GT4 ; -> }T
9361 T{ GT5 -> 123 }T
9362 T{ : GT6 345 ; IMMEDIATE -> }T
9363 T{ : GT7 POSTPONE GT6 ; -> }T
9364 T{ GT7 -> 345 }T
9365
9366 T{ : GT8 STATE @ ; IMMEDIATE -> }T
9367 T{ GT8 -> 0 }T
9368 T{ : GT9 GT8 LITERAL ; -> }T
9369 T{ GT9 0= -> <FALSE> }T
9370
9371 \ ------------------------------------------------------------------------
9372 TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
9373
9374 T{ : GI1 IF 123 THEN ; -> }T
9375 T{ : GI2 IF 123 ELSE 234 THEN ; -> }T
9376 T{ 0 GI1 -> }T
9377 T{ 1 GI1 -> 123 }T
9378 T{ -1 GI1 -> 123 }T
9379 T{ 0 GI2 -> 234 }T
9380 T{ 1 GI2 -> 123 }T
9381 T{ -1 GI1 -> 123 }T
9382
9383 T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T
9384 T{ 0 GI3 -> 0 1 2 3 4 5 }T
9385 T{ 4 GI3 -> 4 5 }T
9386 T{ 5 GI3 -> 5 }T
9387 T{ 6 GI3 -> 6 }T
9388
9389 T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T
9390 T{ 3 GI4 -> 3 4 5 6 }T
9391 T{ 5 GI4 -> 5 6 }T
9392 T{ 6 GI4 -> 6 7 }T
9393
9394 T{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T
9395 T{ 1 GI5 -> 1 345 }T
9396 T{ 2 GI5 -> 2 345 }T
9397 T{ 3 GI5 -> 3 4 5 123 }T
9398 T{ 4 GI5 -> 4 5 123 }T
9399 T{ 5 GI5 -> 5 123 }T
9400
9401 T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T
9402 T{ 0 GI6 -> 0 }T
9403 T{ 1 GI6 -> 0 1 }T
9404 T{ 2 GI6 -> 0 1 2 }T
9405 T{ 3 GI6 -> 0 1 2 3 }T
9406 T{ 4 GI6 -> 0 1 2 3 4 }T
9407
9408 \ ------------------------------------------------------------------------
9409 TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
9410
9411 T{ : GD1 DO I LOOP ; -> }T
9412 T{ 4 1 GD1 -> 1 2 3 }T
9413 T{ 2 -1 GD1 -> -1 0 1 }T
9414 T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T
9415
9416 T{ : GD2 DO I -1 +LOOP ; -> }T
9417 T{ 1 4 GD2 -> 4 3 2 1 }T
9418 T{ -1 2 GD2 -> 2 1 0 -1 }T
9419 T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T
9420
9421 T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T
9422 T{ 4 1 GD3 -> 1 2 3 }T
9423 T{ 2 -1 GD3 -> -1 0 1 }T
9424 T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T
9425
9426 T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T
9427 T{ 1 4 GD4 -> 4 3 2 1 }T
9428 T{ -1 2 GD4 -> 2 1 0 -1 }T
9429 T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T
9430
9431 T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T
9432 T{ 1 GD5 -> 123 }T
9433 T{ 5 GD5 -> 123 }T
9434 T{ 6 GD5 -> 234 }T
9435
9436 T{ : GD6  ( PAT: T{0 0}T,T{0 0}TT{1 0}TT{1 1}T,T{0 0}TT{1 0}TT{1 1}TT{2 0}TT{2 1}TT{2 2}T )
9437     0 SWAP 0 DO
9438         I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
9439     LOOP ; -> }T
9440 T{ 1 GD6 -> 1 }T
9441 T{ 2 GD6 -> 3 }T
9442 T{ 3 GD6 -> 4 1 2 }T
9443
9444 \ ------------------------------------------------------------------------
9445 TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
9446
9447 T{ 123 CONSTANT X123 -> }T
9448 T{ X123 -> 123 }T
9449 T{ : EQU CONSTANT ; -> }T
9450 T{ X123 EQU Y123 -> }T
9451 T{ Y123 -> 123 }T
9452
9453 T{ VARIABLE V1 -> }T
9454 T{ 123 V1 ! -> }T
9455 T{ V1 @ -> 123 }T
9456
9457 T{ : NOP : POSTPONE ; ; -> }T
9458 T{ NOP NOP1 NOP NOP2 -> }T
9459 T{ NOP1 -> }T
9460 T{ NOP2 -> }T
9461
9462 T{ : DOES1 DOES> @ 1 + ; -> }T
9463 T{ : DOES2 DOES> @ 2 + ; -> }T
9464 T{ CREATE CR1 -> }T
9465 T{ CR1 -> HERE }T
9466 T{ ' CR1 >BODY -> HERE }T
9467 T{ 1 , -> }T
9468 T{ CR1 @ -> 1 }T
9469 T{ DOES1 -> }T
9470 T{ CR1 -> 2 }T
9471 T{ DOES2 -> }T
9472 T{ CR1 -> 3 }T
9473
9474 T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T
9475 T{ WEIRD: W1 -> }T
9476 T{ ' W1 >BODY -> HERE }T
9477 T{ W1 -> HERE 1 + }T
9478 T{ W1 -> HERE 2 + }T
9479
9480 \ ------------------------------------------------------------------------
9481 TESTING EVALUATE
9482
9483 : GE1 S" 123" ; IMMEDIATE
9484 : GE2 S" 123 1+" ; IMMEDIATE
9485 : GE3 S" : GE4 345 ;" ;
9486 : GE5 EVALUATE ; IMMEDIATE
9487
9488 T{ GE1 EVALUATE -> 123 }T           ( TEST EVALUATE IN INTERP. STATE )
9489 T{ GE2 EVALUATE -> 124 }T
9490 T{ GE3 EVALUATE -> }T
9491 T{ GE4 -> 345 }T
9492
9493 T{ : GE6 GE1 GE5 ; -> }T            ( TEST EVALUATE IN COMPILE STATE )
9494 T{ GE6 -> 123 }T
9495 T{ : GE7 GE2 GE5 ; -> }T
9496 T{ GE7 -> 124 }T
9497
9498 \ ------------------------------------------------------------------------
9499 TESTING SOURCE >IN WORD
9500
9501 : GS1 S" SOURCE" 2DUP EVALUATE
9502         >R SWAP >R = R> R> = ;
9503 T{ GS1 -> <TRUE> <TRUE> }T
9504
9505 VARIABLE SCANS
9506 : RESCAN?  -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
9507
9508 T{ 2 SCANS !
9509 345 RESCAN?
9510 -> 345 345 }T
9511
9512 : GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
9513 T{ GS2 -> 123 123 123 123 123 }T
9514
9515 : GS3 WORD COUNT SWAP C@ ;
9516 T{ BL GS3 HELLO -> 5 CHAR H }T
9517 T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T
9518 T{ BL GS3
9519 DROP -> 0 }T                \ BLANK LINE RETURN ZERO-LENGTH STRING
9520
9521 : GS4 SOURCE >IN ! DROP ;
9522 T{ GS4 123 456
9523 -> }T
9524
9525 \ ------------------------------------------------------------------------
9526 TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
9527
9528 : S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
9529     >R SWAP R@ = IF          \ MAKE SURE STRINGS HAVE SAME LENGTH
9530         R> ?DUP IF            \ IF NON-EMPTY STRINGS
9531         0 DO
9532         OVER C@ OVER C@ - IF
9533             2DROP <FALSE> UNLOOP EXIT THEN
9534         SWAP CHAR+ SWAP CHAR+
9535             LOOP
9536         THEN
9537         2DROP <TRUE>          \ IF WE GET HERE, STRINGS MATCH
9538     ELSE
9539         R> DROP 2DROP <FALSE>     \ LENGTHS MISMATCH
9540     THEN ;
9541
9542 : GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
9543 T{ GP1 -> <TRUE> }T
9544
9545 : GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
9546 T{ GP2 -> <TRUE> }T
9547
9548 : GP3  <# 1 0 # # #> S" 01" S= ;
9549 T{ GP3 -> <TRUE> }T
9550
9551 : GP4  <# 1 0 #S #> S" 1" S= ;
9552 T{ GP4 -> <TRUE> }T
9553
9554 24 CONSTANT MAX-BASE            \ BASE 2 .. 36
9555 : COUNT-BITS
9556     0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
9557 COUNT-BITS 2* CONSTANT #BITS-UD     \ NUMBER OF BITS IN UD
9558
9559 : GP5
9560     BASE @ <TRUE>
9561     MAX-BASE 1+ 2 DO         \ FOR EACH POSSIBLE BASE
9562         I BASE !              \ TBD: ASSUMES BASE WORKS
9563         I 0 <# #S #> S" 10" S= AND
9564     LOOP
9565     SWAP BASE ! ;
9566 T{ GP5 -> <TRUE> }T
9567
9568 : GP6
9569     BASE @ >R  2 BASE !
9570     MAX-UINT MAX-UINT <# #S #>       \ MAXIMUM UD TO BINARY
9571     R> BASE !                \ S: C-ADDR U
9572     DUP #BITS-UD = SWAP
9573     0 DO                 \ S: C-ADDR FLAG
9574         OVER C@ [CHAR] 1 = AND        \ ALL ONES
9575         >R CHAR+ R>
9576     LOOP SWAP DROP ;
9577 T{ GP6 -> <TRUE> }T
9578
9579 : GP7
9580     BASE @ >R    MAX-BASE BASE !
9581     <TRUE>
9582     A 0 DO
9583         I 0 <# #S #>
9584         1 = SWAP C@ I 30 + = AND AND
9585     LOOP
9586     MAX-BASE A DO
9587         I 0 <# #S #>
9588         1 = SWAP C@ 41 I A - + = AND AND
9589     LOOP
9590     R> BASE ! ;
9591
9592 T{ GP7 -> <TRUE> }T
9593
9594 \ >NUMBER TESTS
9595 CREATE GN-BUF 0 C,
9596 : GN-STRING GN-BUF 1 ;
9597 : GN-CONSUMED   GN-BUF CHAR+ 0 ;
9598 : GN'       [CHAR] ' WORD CHAR+ C@ GN-BUF C!  GN-STRING ;
9599
9600 T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T
9601 T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T
9602 T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T
9603 T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T   \ SHOULD FAIL TO CONVERT THESE
9604 T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T
9605 T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T
9606
9607 : >NUMBER-BASED
9608     BASE @ >R BASE ! >NUMBER R> BASE ! ;
9609
9610 T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T
9611 T{ 0 0 GN' 2'  2 >NUMBER-BASED -> 0 0 GN-STRING }T
9612 T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T
9613 T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T
9614 T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T
9615 T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T
9616
9617 : GN1   \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
9618     BASE @ >R BASE !
9619     <# #S #>
9620     0 0 2SWAP >NUMBER SWAP DROP      \ RETURN LENGTH ONLY
9621     R> BASE ! ;
9622 T{ 0 0 2 GN1 -> 0 0 0 }T
9623 T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
9624 T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
9625 T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T
9626 T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T
9627 T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T
9628
9629 : GN2   \ ( -- 16 10 )
9630     BASE @ >R  HEX BASE @  DECIMAL BASE @  R> BASE ! ;
9631 T{ GN2 -> 10 A }T
9632
9633 \ ------------------------------------------------------------------------
9634 TESTING FILL MOVE
9635
9636 CREATE FBUF 00 C, 00 C, 00 C,
9637 CREATE SBUF 12 C, 34 C, 56 C,
9638 : SEEBUF FBUF C@  FBUF CHAR+ C@  FBUF CHAR+ CHAR+ C@ ;
9639
9640 T{ FBUF 0 20 FILL -> }T
9641 T{ SEEBUF -> 00 00 00 }T
9642
9643 T{ FBUF 1 20 FILL -> }T
9644 T{ SEEBUF -> 20 00 00 }T
9645
9646 T{ FBUF 3 20 FILL -> }T
9647 T{ SEEBUF -> 20 20 20 }T
9648
9649 T{ FBUF FBUF 3 CHARS MOVE -> }T     \ BIZARRE SPECIAL CASE
9650 T{ SEEBUF -> 20 20 20 }T
9651
9652 T{ SBUF FBUF 0 CHARS MOVE -> }T
9653 T{ SEEBUF -> 20 20 20 }T
9654
9655 T{ SBUF FBUF 1 CHARS MOVE -> }T
9656 T{ SEEBUF -> 12 20 20 }T
9657
9658 T{ SBUF FBUF 3 CHARS MOVE -> }T
9659 T{ SEEBUF -> 12 34 56 }T
9660
9661 T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T
9662 T{ SEEBUF -> 12 12 34 }T
9663
9664 T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T
9665 T{ SEEBUF -> 12 34 34 }T
9666
9667 \ ------------------------------------------------------------------------
9668 TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
9669
9670 : OUTPUT-TEST
9671     ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
9672     41 BL DO I EMIT LOOP CR
9673     61 41 DO I EMIT LOOP CR
9674     7F 61 DO I EMIT LOOP CR
9675     ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
9676     9 1+ 0 DO I . LOOP CR
9677     ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
9678     [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
9679     ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
9680     [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
9681     ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
9682     5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
9683     ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
9684     S" LINE 1" TYPE CR S" LINE 2" TYPE CR
9685     ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
9686     ."   SIGNED: " MIN-INT . MAX-INT . CR
9687     ." UNSIGNED: " 0 U. MAX-UINT U. CR
9688 ;
9689
9690 T{ OUTPUT-TEST -> }T
9691 \ ------------------------------------------------------------------------
9692 TESTING INPUT: ACCEPT
9693
9694 CREATE ABUF 80 CHARS ALLOT
9695
9696 : ACCEPT-TEST
9697     CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
9698     ABUF 80 ACCEPT
9699     CR ." RECEIVED: " [CHAR] " EMIT
9700     ABUF SWAP TYPE [CHAR] " EMIT CR
9701 ;
9702
9703 T{ ACCEPT-TEST -> }T
9704 Vingt fois sur le métier remettez votre ouvrage, ...
9705 \ ------------------------------------------------------------------------
9706 TESTING DICTIONARY SEARCH RULES
9707
9708 T{ : GDX   123 ; : GDX   GDX 234 ; -> }T
9709
9710 T{ GDX -> 123 234 }T
9711
9712 CR .( End of Core word set tests) CR
9713
9714
9715
9716 RST_STATE   ; so ANS_COMPLEMENT_xx_MPY is conserved ;
9717 \ NOECHO      ; if an error occurs, comment this line before new download to find it.
9718
9719
9720 \ From: John Hayes S1I
9721 \ Subject: tester.fr
9722 \ Date: Mon, 27 Nov 95 13:10:09 PST
9723
9724 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
9725 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
9726 \ VERSION 1.1
9727
9728 \ 22/1/09 The words { and } have been changed to T{ and }T respectively to
9729 \ agree with the Forth 200X file ttester.fs. This avoids clashes with
9730 \ locals using { ... } and the FSL use of }
9731
9732
9733 \ 13/05/14 jmt. added colorised error messages.
9734
9735
9736
9737  0 CONSTANT FALSE
9738 -1 CONSTANT TRUE
9739
9740 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
9741 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
9742 VARIABLE VERBOSE
9743     FALSE VERBOSE !
9744 \   TRUE VERBOSE !
9745
9746 \ : EMPTY-STACK ( ... -- )  \ EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
9747 \     DEPTH ?DUP
9748 \             IF DUP 0< IF NEGATE 0
9749 \             DO 0 LOOP
9750 \             ELSE 0 DO DROP LOOP THEN
9751 \             THEN ;
9752 \
9753 \ : ERROR     \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
9754 \         \ THE LINE THAT HAD THE ERROR.
9755 \     TYPE SOURCE TYPE CR          \ DISPLAY LINE CORRESPONDING TO ERROR
9756 \     EMPTY-STACK              \ THROW AWAY EVERY THING ELSE
9757 \     QUIT  \ *** Uncomment this line to QUIT on an error
9758 \ ;
9759
9760 VARIABLE ACTUAL-DEPTH           \ STACK RECORD
9761 CREATE ACTUAL-RESULTS 20 CELLS ALLOT
9762
9763 : T{        \ ( -- ) SYNTACTIC SUGAR.
9764     ;
9765
9766 : ->        \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
9767     DEPTH DUP ACTUAL-DEPTH !     \ RECORD DEPTH
9768     ?DUP IF              \ IF THERE IS SOMETHING ON STACK
9769         0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
9770     THEN ;
9771
9772 : }T        \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
9773             \ (ACTUAL) CONTENTS.
9774     DEPTH ACTUAL-DEPTH @ = IF   \ IF DEPTHS MATCH
9775         DEPTH ?DUP IF           \ IF THERE IS SOMETHING ON THE STACK
9776         0 DO                    \ FOR EACH STACK ITEM
9777             ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
9778 \           = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN   \ jmt
9779             = 0= IF ABORT" INCORRECT RESULT: " THEN           \ jmt : colorised message
9780         LOOP
9781         THEN
9782     ELSE                 \ DEPTH MISMATCH
9783 \       S" WRONG NUMBER OF RESULTS: " ERROR \ jmt
9784         ABORT" WRONG NUMBER OF RESULTS: "   \ jmt : colorised message
9785     THEN ;
9786
9787 : TESTING   \ ( -- ) TALKING COMMENT.
9788     SOURCE VERBOSE @
9789     IF DUP >R TYPE CR R> >IN !
9790     ELSE >IN ! DROP [CHAR] * EMIT
9791     THEN ;
9792
9793 \ From: John Hayes S1I
9794 \ Subject: core.fr
9795 \ Date: Mon, 27 Nov 95 13:10
9796
9797 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
9798 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
9799 \ VERSION 1.2
9800 \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
9801 \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
9802 \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
9803 \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
9804 \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
9805 \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
9806
9807 CR
9808 TESTING CORE WORDS
9809 HEX
9810
9811 \ ------------------------------------------------------------------------
9812 TESTING BASIC ASSUMPTIONS
9813
9814 T{ -> }T                    \ START WITH CLEAN SLATE
9815 ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
9816 T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T
9817 T{  0 BITSSET? -> 0 }T      ( ZERO IS ALL BITS CLEAR )
9818 T{  1 BITSSET? -> 0 0 }T        ( OTHER NUMBER HAVE AT LEAST ONE BIT )
9819 T{ -1 BITSSET? -> 0 0 }T
9820
9821 \ ------------------------------------------------------------------------
9822 TESTING BOOLEANS: INVERT AND OR XOR
9823
9824 T{ 0 0 AND -> 0 }T
9825 T{ 0 1 AND -> 0 }T
9826 T{ 1 0 AND -> 0 }T
9827 T{ 1 1 AND -> 1 }T
9828
9829 T{ 0 INVERT 1 AND -> 1 }T
9830 T{ 1 INVERT 1 AND -> 0 }T
9831
9832 0    CONSTANT 0S
9833 0 INVERT CONSTANT 1S
9834
9835 T{ 0S INVERT -> 1S }T
9836 T{ 1S INVERT -> 0S }T
9837
9838 T{ 0S 0S AND -> 0S }T
9839 T{ 0S 1S AND -> 0S }T
9840 T{ 1S 0S AND -> 0S }T
9841 T{ 1S 1S AND -> 1S }T
9842
9843 T{ 0S 0S OR -> 0S }T
9844 T{ 0S 1S OR -> 1S }T
9845 T{ 1S 0S OR -> 1S }T
9846 T{ 1S 1S OR -> 1S }T
9847
9848 T{ 0S 0S XOR -> 0S }T
9849 T{ 0S 1S XOR -> 1S }T
9850 T{ 1S 0S XOR -> 1S }T
9851 T{ 1S 1S XOR -> 0S }T
9852
9853 \ ------------------------------------------------------------------------
9854 TESTING 2* 2/ LSHIFT RSHIFT
9855
9856 ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
9857 1S 1 RSHIFT INVERT CONSTANT MSB
9858 T{ MSB BITSSET? -> 0 0 }T
9859
9860 T{ 0S 2* -> 0S }T
9861 T{ 1 2* -> 2 }T
9862 T{ 4000 2* -> 8000 }T
9863 T{ 1S 2* 1 XOR -> 1S }T
9864 T{ MSB 2* -> 0S }T
9865
9866 T{ 0S 2/ -> 0S }T
9867 T{ 1 2/ -> 0 }T
9868 T{ 4000 2/ -> 2000 }T
9869 T{ 1S 2/ -> 1S }T               \ MSB PROPOGATED
9870 T{ 1S 1 XOR 2/ -> 1S }T
9871 T{ MSB 2/ MSB AND -> MSB }T
9872
9873 T{ 1 0 LSHIFT -> 1 }T
9874 T{ 1 1 LSHIFT -> 2 }T
9875 T{ 1 2 LSHIFT -> 4 }T
9876 T{ 1 F LSHIFT -> 8000 }T            \ BIGGEST GUARANTEED SHIFT
9877 T{ 1S 1 LSHIFT 1 XOR -> 1S }T
9878 T{ MSB 1 LSHIFT -> 0 }T
9879
9880 T{ 1 0 RSHIFT -> 1 }T
9881 T{ 1 1 RSHIFT -> 0 }T
9882 T{ 2 1 RSHIFT -> 1 }T
9883 T{ 4 2 RSHIFT -> 1 }T
9884 T{ 8000 F RSHIFT -> 1 }T            \ BIGGEST
9885 T{ MSB 1 RSHIFT MSB AND -> 0 }T     \ RSHIFT ZERO FILLS MSBS
9886 T{ MSB 1 RSHIFT 2* -> MSB }T
9887
9888 \ ------------------------------------------------------------------------
9889 TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
9890 0 INVERT            CONSTANT MAX-UINT
9891 0 INVERT 1 RSHIFT       CONSTANT MAX-INT
9892 0 INVERT 1 RSHIFT INVERT    CONSTANT MIN-INT
9893 0 INVERT 1 RSHIFT       CONSTANT MID-UINT
9894 0 INVERT 1 RSHIFT INVERT    CONSTANT MID-UINT+1
9895
9896 0S CONSTANT <FALSE>
9897 1S CONSTANT <TRUE>
9898
9899 T{ 0 0= -> <TRUE> }T
9900 T{ 1 0= -> <FALSE> }T
9901 T{ 2 0= -> <FALSE> }T
9902 T{ -1 0= -> <FALSE> }T
9903 T{ MAX-UINT 0= -> <FALSE> }T
9904 T{ MIN-INT 0= -> <FALSE> }T
9905 T{ MAX-INT 0= -> <FALSE> }T
9906
9907 T{ 0 0 = -> <TRUE> }T
9908 T{ 1 1 = -> <TRUE> }T
9909 T{ -1 -1 = -> <TRUE> }T
9910 T{ 1 0 = -> <FALSE> }T
9911 T{ -1 0 = -> <FALSE> }T
9912 T{ 0 1 = -> <FALSE> }T
9913 T{ 0 -1 = -> <FALSE> }T
9914
9915 T{ 0 0< -> <FALSE> }T
9916 T{ -1 0< -> <TRUE> }T
9917 T{ MIN-INT 0< -> <TRUE> }T
9918 T{ 1 0< -> <FALSE> }T
9919 T{ MAX-INT 0< -> <FALSE> }T
9920
9921 T{ 0 1 < -> <TRUE> }T
9922 T{ 1 2 < -> <TRUE> }T
9923 T{ -1 0 < -> <TRUE> }T
9924 T{ -1 1 < -> <TRUE> }T
9925 T{ MIN-INT 0 < -> <TRUE> }T
9926 T{ MIN-INT MAX-INT < -> <TRUE> }T
9927 T{ 0 MAX-INT < -> <TRUE> }T
9928 T{ 0 0 < -> <FALSE> }T
9929 T{ 1 1 < -> <FALSE> }T
9930 T{ 1 0 < -> <FALSE> }T
9931 T{ 2 1 < -> <FALSE> }T
9932 T{ 0 -1 < -> <FALSE> }T
9933 T{ 1 -1 < -> <FALSE> }T
9934 T{ 0 MIN-INT < -> <FALSE> }T
9935 T{ MAX-INT MIN-INT < -> <FALSE> }T
9936 T{ MAX-INT 0 < -> <FALSE> }T
9937
9938 T{ 0 1 > -> <FALSE> }T
9939 T{ 1 2 > -> <FALSE> }T
9940 T{ -1 0 > -> <FALSE> }T
9941 T{ -1 1 > -> <FALSE> }T
9942 T{ MIN-INT 0 > -> <FALSE> }T
9943 T{ MIN-INT MAX-INT > -> <FALSE> }T
9944 T{ 0 MAX-INT > -> <FALSE> }T
9945 T{ 0 0 > -> <FALSE> }T
9946 T{ 1 1 > -> <FALSE> }T
9947 T{ 1 0 > -> <TRUE> }T
9948 T{ 2 1 > -> <TRUE> }T
9949 T{ 0 -1 > -> <TRUE> }T
9950 T{ 1 -1 > -> <TRUE> }T
9951 T{ 0 MIN-INT > -> <TRUE> }T
9952 T{ MAX-INT MIN-INT > -> <TRUE> }T
9953 T{ MAX-INT 0 > -> <TRUE> }T
9954
9955 T{ 0 1 U< -> <TRUE> }T
9956 T{ 1 2 U< -> <TRUE> }T
9957 T{ 0 MID-UINT U< -> <TRUE> }T
9958 T{ 0 MAX-UINT U< -> <TRUE> }T
9959 T{ MID-UINT MAX-UINT U< -> <TRUE> }T
9960 T{ 0 0 U< -> <FALSE> }T
9961 T{ 1 1 U< -> <FALSE> }T
9962 T{ 1 0 U< -> <FALSE> }T
9963 T{ 2 1 U< -> <FALSE> }T
9964 T{ MID-UINT 0 U< -> <FALSE> }T
9965 T{ MAX-UINT 0 U< -> <FALSE> }T
9966 T{ MAX-UINT MID-UINT U< -> <FALSE> }T
9967
9968 T{ 0 1 MIN -> 0 }T
9969 T{ 1 2 MIN -> 1 }T
9970 T{ -1 0 MIN -> -1 }T
9971 T{ -1 1 MIN -> -1 }T
9972 T{ MIN-INT 0 MIN -> MIN-INT }T
9973 T{ MIN-INT MAX-INT MIN -> MIN-INT }T
9974 T{ 0 MAX-INT MIN -> 0 }T
9975 T{ 0 0 MIN -> 0 }T
9976 T{ 1 1 MIN -> 1 }T
9977 T{ 1 0 MIN -> 0 }T
9978 T{ 2 1 MIN -> 1 }T
9979 T{ 0 -1 MIN -> -1 }T
9980 T{ 1 -1 MIN -> -1 }T
9981 T{ 0 MIN-INT MIN -> MIN-INT }T
9982 T{ MAX-INT MIN-INT MIN -> MIN-INT }T
9983 T{ MAX-INT 0 MIN -> 0 }T
9984
9985 T{ 0 1 MAX -> 1 }T
9986 T{ 1 2 MAX -> 2 }T
9987 T{ -1 0 MAX -> 0 }T
9988 T{ -1 1 MAX -> 1 }T
9989 T{ MIN-INT 0 MAX -> 0 }T
9990 T{ MIN-INT MAX-INT MAX -> MAX-INT }T
9991 T{ 0 MAX-INT MAX -> MAX-INT }T
9992 T{ 0 0 MAX -> 0 }T
9993 T{ 1 1 MAX -> 1 }T
9994 T{ 1 0 MAX -> 1 }T
9995 T{ 2 1 MAX -> 2 }T
9996 T{ 0 -1 MAX -> 0 }T
9997 T{ 1 -1 MAX -> 1 }T
9998 T{ 0 MIN-INT MAX -> 0 }T
9999 T{ MAX-INT MIN-INT MAX -> MAX-INT }T
10000 T{ MAX-INT 0 MAX -> MAX-INT }T
10001
10002 \ ------------------------------------------------------------------------
10003 TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
10004
10005 T{ 1 2 2DROP -> }T
10006 T{ 1 2 2DUP -> 1 2 1 2 }T
10007 T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T
10008 T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T
10009 T{ 0 ?DUP -> 0 }T
10010 T{ 1 ?DUP -> 1 1 }T
10011 T{ -1 ?DUP -> -1 -1 }T
10012 T{ DEPTH -> 0 }T
10013 T{ 0 DEPTH -> 0 1 }T
10014 T{ 0 1 DEPTH -> 0 1 2 }T
10015 T{ 0 DROP -> }T
10016 T{ 1 2 DROP -> 1 }T
10017 T{ 1 DUP -> 1 1 }T
10018 T{ 1 2 OVER -> 1 2 1 }T
10019 T{ 1 2 3 ROT -> 2 3 1 }T
10020 T{ 1 2 SWAP -> 2 1 }T
10021
10022 \ ------------------------------------------------------------------------
10023 TESTING >R R> R@
10024
10025 T{ : GR1 >R R> ; -> }T
10026 T{ : GR2 >R R@ R> DROP ; -> }T
10027 T{ 123 GR1 -> 123 }T
10028 T{ 123 GR2 -> 123 }T
10029 T{ 1S GR1 -> 1S }T   ( RETURN STACK HOLDS CELLS )
10030
10031 \ ------------------------------------------------------------------------
10032 TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
10033
10034 T{ 0 5 + -> 5 }T
10035 T{ 5 0 + -> 5 }T
10036 T{ 0 -5 + -> -5 }T
10037 T{ -5 0 + -> -5 }T
10038 T{ 1 2 + -> 3 }T
10039 T{ 1 -2 + -> -1 }T
10040 T{ -1 2 + -> 1 }T
10041 T{ -1 -2 + -> -3 }T
10042 T{ -1 1 + -> 0 }T
10043 T{ MID-UINT 1 + -> MID-UINT+1 }T
10044
10045 T{ 0 5 - -> -5 }T
10046 T{ 5 0 - -> 5 }T
10047 T{ 0 -5 - -> 5 }T
10048 T{ -5 0 - -> -5 }T
10049 T{ 1 2 - -> -1 }T
10050 T{ 1 -2 - -> 3 }T
10051 T{ -1 2 - -> -3 }T
10052 T{ -1 -2 - -> 1 }T
10053 T{ 0 1 - -> -1 }T
10054 T{ MID-UINT+1 1 - -> MID-UINT }T
10055
10056 T{ 0 1+ -> 1 }T
10057 T{ -1 1+ -> 0 }T
10058 T{ 1 1+ -> 2 }T
10059 T{ MID-UINT 1+ -> MID-UINT+1 }T
10060
10061 T{ 2 1- -> 1 }T
10062 T{ 1 1- -> 0 }T
10063 T{ 0 1- -> -1 }T
10064 T{ MID-UINT+1 1- -> MID-UINT }T
10065
10066 T{ 0 NEGATE -> 0 }T
10067 T{ 1 NEGATE -> -1 }T
10068 T{ -1 NEGATE -> 1 }T
10069 T{ 2 NEGATE -> -2 }T
10070 T{ -2 NEGATE -> 2 }T
10071
10072 T{ 0 ABS -> 0 }T
10073 T{ 1 ABS -> 1 }T
10074 T{ -1 ABS -> 1 }T
10075 T{ MIN-INT ABS -> MID-UINT+1 }T
10076
10077 \ ------------------------------------------------------------------------
10078 TESTING MULTIPLY: S>D * M* UM*
10079
10080 T{ 0 S>D -> 0 0 }T
10081 T{ 1 S>D -> 1 0 }T
10082 T{ 2 S>D -> 2 0 }T
10083 T{ -1 S>D -> -1 -1 }T
10084 T{ -2 S>D -> -2 -1 }T
10085 T{ MIN-INT S>D -> MIN-INT -1 }T
10086 T{ MAX-INT S>D -> MAX-INT 0 }T
10087
10088 T{ 0 0 M* -> 0 S>D }T
10089 T{ 0 1 M* -> 0 S>D }T
10090 T{ 1 0 M* -> 0 S>D }T
10091 T{ 1 2 M* -> 2 S>D }T
10092 T{ 2 1 M* -> 2 S>D }T
10093 T{ 3 3 M* -> 9 S>D }T
10094 T{ -3 3 M* -> -9 S>D }T
10095 T{ 3 -3 M* -> -9 S>D }T
10096 T{ -3 -3 M* -> 9 S>D }T
10097 T{ 0 MIN-INT M* -> 0 S>D }T
10098 T{ 1 MIN-INT M* -> MIN-INT S>D }T
10099 T{ 2 MIN-INT M* -> 0 1S }T
10100 T{ 0 MAX-INT M* -> 0 S>D }T
10101 T{ 1 MAX-INT M* -> MAX-INT S>D }T
10102 T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T
10103 T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T
10104 T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T
10105 T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T
10106
10107 T{ 0 0 * -> 0 }T                \ TEST IDENTITIES
10108 T{ 0 1 * -> 0 }T
10109 T{ 1 0 * -> 0 }T
10110 T{ 1 2 * -> 2 }T
10111 T{ 2 1 * -> 2 }T
10112 T{ 3 3 * -> 9 }T
10113 T{ -3 3 * -> -9 }T
10114 T{ 3 -3 * -> -9 }T
10115 T{ -3 -3 * -> 9 }T
10116
10117 T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T
10118 T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T
10119 T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T
10120
10121 T{ 0 0 UM* -> 0 0 }T
10122 T{ 0 1 UM* -> 0 0 }T
10123 T{ 1 0 UM* -> 0 0 }T
10124 T{ 1 2 UM* -> 2 0 }T
10125 T{ 2 1 UM* -> 2 0 }T
10126 T{ 3 3 UM* -> 9 0 }T
10127
10128 T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T
10129 T{ MID-UINT+1 2 UM* -> 0 1 }T
10130 T{ MID-UINT+1 4 UM* -> 0 2 }T
10131 T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T
10132 T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T
10133
10134 \ ------------------------------------------------------------------------
10135 TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
10136
10137 T{ 0 S>D 1 FM/MOD -> 0 0 }T
10138 T{ 1 S>D 1 FM/MOD -> 0 1 }T
10139 T{ 2 S>D 1 FM/MOD -> 0 2 }T
10140 T{ -1 S>D 1 FM/MOD -> 0 -1 }T
10141 T{ -2 S>D 1 FM/MOD -> 0 -2 }T
10142 T{ 0 S>D -1 FM/MOD -> 0 0 }T
10143 T{ 1 S>D -1 FM/MOD -> 0 -1 }T
10144 T{ 2 S>D -1 FM/MOD -> 0 -2 }T
10145 T{ -1 S>D -1 FM/MOD -> 0 1 }T
10146 T{ -2 S>D -1 FM/MOD -> 0 2 }T
10147 T{ 2 S>D 2 FM/MOD -> 0 1 }T
10148 T{ -1 S>D -1 FM/MOD -> 0 1 }T
10149 T{ -2 S>D -2 FM/MOD -> 0 1 }T
10150 T{  7 S>D  3 FM/MOD -> 1 2 }T
10151 T{  7 S>D -3 FM/MOD -> -2 -3 }T
10152 T{ -7 S>D  3 FM/MOD -> 2 -3 }T
10153 T{ -7 S>D -3 FM/MOD -> -1 2 }T
10154 T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T
10155 T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T
10156 T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T
10157 T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T
10158 T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T
10159 T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T
10160 T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T
10161 T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T
10162 T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T
10163 T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T
10164 T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T
10165 T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T
10166 T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T
10167 T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T
10168 T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T
10169 T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T
10170 T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T
10171
10172 T{ 0 S>D 1 SM/REM -> 0 0 }T
10173 T{ 1 S>D 1 SM/REM -> 0 1 }T
10174 T{ 2 S>D 1 SM/REM -> 0 2 }T
10175 T{ -1 S>D 1 SM/REM -> 0 -1 }T
10176 T{ -2 S>D 1 SM/REM -> 0 -2 }T
10177 T{ 0 S>D -1 SM/REM -> 0 0 }T
10178 T{ 1 S>D -1 SM/REM -> 0 -1 }T
10179 T{ 2 S>D -1 SM/REM -> 0 -2 }T
10180 T{ -1 S>D -1 SM/REM -> 0 1 }T
10181 T{ -2 S>D -1 SM/REM -> 0 2 }T
10182 T{ 2 S>D 2 SM/REM -> 0 1 }T
10183 T{ -1 S>D -1 SM/REM -> 0 1 }T
10184 T{ -2 S>D -2 SM/REM -> 0 1 }T
10185 T{  7 S>D  3 SM/REM -> 1 2 }T
10186 T{  7 S>D -3 SM/REM -> 1 -2 }T
10187 T{ -7 S>D  3 SM/REM -> -1 -2 }T
10188 T{ -7 S>D -3 SM/REM -> -1 2 }T
10189 T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T
10190 T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T
10191 T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T
10192 T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T
10193 T{ 1S 1 4 SM/REM -> 3 MAX-INT }T
10194 T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T
10195 T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T
10196 T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T
10197 T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T
10198 T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T
10199 T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T
10200 T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T
10201 T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T
10202
10203 T{ 0 0 1 UM/MOD -> 0 0 }T
10204 T{ 1 0 1 UM/MOD -> 0 1 }T
10205 T{ 1 0 2 UM/MOD -> 1 0 }T
10206 T{ 3 0 2 UM/MOD -> 1 1 }T
10207 T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T
10208 T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T
10209 T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T
10210
10211 : IFFLOORED
10212     [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
10213
10214 : IFSYM
10215     [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
10216
10217 \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
10218 \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
10219
10220 IFFLOORED : T/MOD  >R S>D R> FM/MOD ;
10221 IFFLOORED : T/     T/MOD SWAP DROP ;
10222 IFFLOORED : TMOD   T/MOD DROP ;
10223 IFFLOORED : T*/MOD >R M* R> FM/MOD ;
10224 IFFLOORED : T*/    T*/MOD SWAP DROP ;
10225 IFSYM     : T/MOD  >R S>D R> SM/REM ;
10226 IFSYM     : T/     T/MOD SWAP DROP ;
10227 IFSYM     : TMOD   T/MOD DROP ;
10228 IFSYM     : T*/MOD >R M* R> SM/REM ;
10229 IFSYM     : T*/    T*/MOD SWAP DROP ;
10230
10231 T{ 0 1 /MOD -> 0 1 T/MOD }T
10232 T{ 1 1 /MOD -> 1 1 T/MOD }T
10233 T{ 2 1 /MOD -> 2 1 T/MOD }T
10234 T{ -1 1 /MOD -> -1 1 T/MOD }T
10235 T{ -2 1 /MOD -> -2 1 T/MOD }T
10236 T{ 0 -1 /MOD -> 0 -1 T/MOD }T
10237 T{ 1 -1 /MOD -> 1 -1 T/MOD }T
10238 T{ 2 -1 /MOD -> 2 -1 T/MOD }T
10239 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
10240 T{ -2 -1 /MOD -> -2 -1 T/MOD }T
10241 T{ 2 2 /MOD -> 2 2 T/MOD }T
10242 T{ -1 -1 /MOD -> -1 -1 T/MOD }T
10243 T{ -2 -2 /MOD -> -2 -2 T/MOD }T
10244 T{ 7 3 /MOD -> 7 3 T/MOD }T
10245 T{ 7 -3 /MOD -> 7 -3 T/MOD }T
10246 T{ -7 3 /MOD -> -7 3 T/MOD }T
10247 T{ -7 -3 /MOD -> -7 -3 T/MOD }T
10248 T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T
10249 T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T
10250 T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T
10251 T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T
10252
10253 T{ 0 1 / -> 0 1 T/ }T
10254 T{ 1 1 / -> 1 1 T/ }T
10255 T{ 2 1 / -> 2 1 T/ }T
10256 T{ -1 1 / -> -1 1 T/ }T
10257 T{ -2 1 / -> -2 1 T/ }T
10258 T{ 0 -1 / -> 0 -1 T/ }T
10259 T{ 1 -1 / -> 1 -1 T/ }T
10260 T{ 2 -1 / -> 2 -1 T/ }T
10261 T{ -1 -1 / -> -1 -1 T/ }T
10262 T{ -2 -1 / -> -2 -1 T/ }T
10263 T{ 2 2 / -> 2 2 T/ }T
10264 T{ -1 -1 / -> -1 -1 T/ }T
10265 T{ -2 -2 / -> -2 -2 T/ }T
10266 T{ 7 3 / -> 7 3 T/ }T
10267 T{ 7 -3 / -> 7 -3 T/ }T
10268 T{ -7 3 / -> -7 3 T/ }T
10269 T{ -7 -3 / -> -7 -3 T/ }T
10270 T{ MAX-INT 1 / -> MAX-INT 1 T/ }T
10271 T{ MIN-INT 1 / -> MIN-INT 1 T/ }T
10272 T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T
10273 T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T
10274
10275 T{ 0 1 MOD -> 0 1 TMOD }T
10276 T{ 1 1 MOD -> 1 1 TMOD }T
10277 T{ 2 1 MOD -> 2 1 TMOD }T
10278 T{ -1 1 MOD -> -1 1 TMOD }T
10279 T{ -2 1 MOD -> -2 1 TMOD }T
10280 T{ 0 -1 MOD -> 0 -1 TMOD }T
10281 T{ 1 -1 MOD -> 1 -1 TMOD }T
10282 T{ 2 -1 MOD -> 2 -1 TMOD }T
10283 T{ -1 -1 MOD -> -1 -1 TMOD }T
10284 T{ -2 -1 MOD -> -2 -1 TMOD }T
10285 T{ 2 2 MOD -> 2 2 TMOD }T
10286 T{ -1 -1 MOD -> -1 -1 TMOD }T
10287 T{ -2 -2 MOD -> -2 -2 TMOD }T
10288 T{ 7 3 MOD -> 7 3 TMOD }T
10289 T{ 7 -3 MOD -> 7 -3 TMOD }T
10290 T{ -7 3 MOD -> -7 3 TMOD }T
10291 T{ -7 -3 MOD -> -7 -3 TMOD }T
10292 T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T
10293 T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T
10294 T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T
10295 T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T
10296
10297 T{ 0 2 1 */ -> 0 2 1 T*/ }T
10298 T{ 1 2 1 */ -> 1 2 1 T*/ }T
10299 T{ 2 2 1 */ -> 2 2 1 T*/ }T
10300 T{ -1 2 1 */ -> -1 2 1 T*/ }T
10301 T{ -2 2 1 */ -> -2 2 1 T*/ }T
10302 T{ 0 2 -1 */ -> 0 2 -1 T*/ }T
10303 T{ 1 2 -1 */ -> 1 2 -1 T*/ }T
10304 T{ 2 2 -1 */ -> 2 2 -1 T*/ }T
10305 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
10306 T{ -2 2 -1 */ -> -2 2 -1 T*/ }T
10307 T{ 2 2 2 */ -> 2 2 2 T*/ }T
10308 T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
10309 T{ -2 2 -2 */ -> -2 2 -2 T*/ }T
10310 T{ 7 2 3 */ -> 7 2 3 T*/ }T
10311 T{ 7 2 -3 */ -> 7 2 -3 T*/ }T
10312 T{ -7 2 3 */ -> -7 2 3 T*/ }T
10313 T{ -7 2 -3 */ -> -7 2 -3 T*/ }T
10314 T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T
10315 T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T
10316
10317 T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T
10318 T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T
10319 T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T
10320 T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T
10321 T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T
10322 T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T
10323 T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T
10324 T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T
10325 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
10326 T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T
10327 T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T
10328 T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
10329 T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T
10330 T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T
10331 T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T
10332 T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T
10333 T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T
10334 T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T
10335 T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T
10336
10337 \ ------------------------------------------------------------------------
10338 TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
10339
10340 HERE 1 ALLOT
10341 HERE
10342 CONSTANT 2NDA
10343 CONSTANT 1STA
10344 T{ 1STA 2NDA U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
10345 T{ 1STA 1+ -> 2NDA }T           \ ... BY ONE ADDRESS UNIT
10346 ( MISSING TEST: NEGATIVE ALLOT )
10347
10348 HERE 1 ,
10349 HERE 2 ,
10350 CONSTANT 2ND
10351 CONSTANT 1ST
10352 T{ 1ST 2ND U< -> <TRUE> }T          \ HERE MUST GROW WITH ALLOT
10353 T{ 1ST CELL+ -> 2ND }T          \ ... BY ONE CELL
10354 T{ 1ST 1 CELLS + -> 2ND }T
10355 T{ 1ST @ 2ND @ -> 1 2 }T
10356 T{ 5 1ST ! -> }T
10357 T{ 1ST @ 2ND @ -> 5 2 }T
10358 T{ 6 2ND ! -> }T
10359 T{ 1ST @ 2ND @ -> 5 6 }T
10360 T{ 1ST 2@ -> 6 5 }T
10361 T{ 2 1 1ST 2! -> }T
10362 T{ 1ST 2@ -> 2 1 }T
10363 T{ 1S 1ST !  1ST @ -> 1S }T     \ CAN STORE CELL-WIDE VALUE
10364
10365 HERE 1 C,
10366 HERE 2 C,
10367 CONSTANT 2NDC
10368 CONSTANT 1STC
10369 T{ 1STC 2NDC U< -> <TRUE> }T        \ HERE MUST GROW WITH ALLOT
10370 T{ 1STC CHAR+ -> 2NDC }T            \ ... BY ONE CHAR
10371 T{ 1STC 1 CHARS + -> 2NDC }T
10372 T{ 1STC C@ 2NDC C@ -> 1 2 }T
10373 T{ 3 1STC C! -> }T
10374 T{ 1STC C@ 2NDC C@ -> 3 2 }T
10375 T{ 4 2NDC C! -> }T
10376 T{ 1STC C@ 2NDC C@ -> 3 4 }T
10377
10378 ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
10379 CONSTANT A-ADDR  CONSTANT UA-ADDR
10380 T{ UA-ADDR ALIGNED -> A-ADDR }T
10381 T{    1 A-ADDR C!  A-ADDR C@ ->    1 }T
10382 T{ 1234 A-ADDR  !  A-ADDR  @ -> 1234 }T
10383 T{ 123 456 A-ADDR 2!  A-ADDR 2@ -> 123 456 }T
10384 T{ 2 A-ADDR CHAR+ C!  A-ADDR CHAR+ C@ -> 2 }T
10385 T{ 3 A-ADDR CELL+ C!  A-ADDR CELL+ C@ -> 3 }T
10386 T{ 1234 A-ADDR CELL+ !  A-ADDR CELL+ @ -> 1234 }T
10387 T{ 123 456 A-ADDR CELL+ 2!  A-ADDR CELL+ 2@ -> 123 456 }T
10388
10389 : BITS ( X -- U )
10390     0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
10391 ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
10392 T{ 1 CHARS 1 < -> <FALSE> }T
10393 T{ 1 CHARS 1 CELLS > -> <FALSE> }T
10394 ( TBD: HOW TO FIND NUMBER OF BITS? )
10395
10396 ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
10397 T{ 1 CELLS 1 < -> <FALSE> }T
10398 T{ 1 CELLS 1 CHARS MOD -> 0 }T
10399 T{ 1S BITS 10 < -> <FALSE> }T
10400
10401 T{ 0 1ST ! -> }T
10402 T{ 1 1ST +! -> }T
10403 T{ 1ST @ -> 1 }T
10404 T{ -1 1ST +! 1ST @ -> 0 }T
10405
10406 \ ------------------------------------------------------------------------
10407 TESTING CHAR [CHAR] [ ] BL S"
10408
10409 T{ BL -> 20 }T
10410 T{ CHAR X -> 58 }T
10411 T{ CHAR HELLO -> 48 }T
10412 T{ : GC1 [CHAR] X ; -> }T
10413 T{ : GC2 [CHAR] HELLO ; -> }T
10414 T{ GC1 -> 58 }T
10415 T{ GC2 -> 48 }T
10416 T{ : GC3 [ GC1 ] LITERAL ; -> }T
10417 T{ GC3 -> 58 }T
10418 T{ : GC4 S" XY" ; -> }T
10419 T{ GC4 SWAP DROP -> 2 }T
10420 T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T
10421
10422 \ ------------------------------------------------------------------------
10423 TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
10424
10425 T{ : GT1 123 ; -> }T
10426 T{ ' GT1 EXECUTE -> 123 }T
10427 T{ : GT2 ['] GT1 ; IMMEDIATE -> }T
10428 T{ GT2 EXECUTE -> 123 }T
10429 HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
10430 HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
10431 T{ GT1STRING FIND -> ' GT1 -1 }T
10432 T{ GT2STRING FIND -> ' GT2 1 }T
10433 ( HOW TO SEARCH FOR NON-EXISTENT WORD? )
10434 T{ : GT3 GT2 LITERAL ; -> }T
10435 T{ GT3 -> ' GT1 }T
10436 T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T
10437
10438 T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T
10439 T{ : GT5 GT4 ; -> }T
10440 T{ GT5 -> 123 }T
10441 T{ : GT6 345 ; IMMEDIATE -> }T
10442 T{ : GT7 POSTPONE GT6 ; -> }T
10443 T{ GT7 -> 345 }T
10444
10445 T{ : GT8 STATE @ ; IMMEDIATE -> }T
10446 T{ GT8 -> 0 }T
10447 T{ : GT9 GT8 LITERAL ; -> }T
10448 T{ GT9 0= -> <FALSE> }T
10449
10450 \ ------------------------------------------------------------------------
10451 TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
10452
10453 T{ : GI1 IF 123 THEN ; -> }T
10454 T{ : GI2 IF 123 ELSE 234 THEN ; -> }T
10455 T{ 0 GI1 -> }T
10456 T{ 1 GI1 -> 123 }T
10457 T{ -1 GI1 -> 123 }T
10458 T{ 0 GI2 -> 234 }T
10459 T{ 1 GI2 -> 123 }T
10460 T{ -1 GI1 -> 123 }T
10461
10462 T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T
10463 T{ 0 GI3 -> 0 1 2 3 4 5 }T
10464 T{ 4 GI3 -> 4 5 }T
10465 T{ 5 GI3 -> 5 }T
10466 T{ 6 GI3 -> 6 }T
10467
10468 T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T
10469 T{ 3 GI4 -> 3 4 5 6 }T
10470 T{ 5 GI4 -> 5 6 }T
10471 T{ 6 GI4 -> 6 7 }T
10472
10473 T{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T
10474 T{ 1 GI5 -> 1 345 }T
10475 T{ 2 GI5 -> 2 345 }T
10476 T{ 3 GI5 -> 3 4 5 123 }T
10477 T{ 4 GI5 -> 4 5 123 }T
10478 T{ 5 GI5 -> 5 123 }T
10479
10480 T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T
10481 T{ 0 GI6 -> 0 }T
10482 T{ 1 GI6 -> 0 1 }T
10483 T{ 2 GI6 -> 0 1 2 }T
10484 T{ 3 GI6 -> 0 1 2 3 }T
10485 T{ 4 GI6 -> 0 1 2 3 4 }T
10486
10487 \ ------------------------------------------------------------------------
10488 TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
10489
10490 T{ : GD1 DO I LOOP ; -> }T
10491 T{ 4 1 GD1 -> 1 2 3 }T
10492 T{ 2 -1 GD1 -> -1 0 1 }T
10493 T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T
10494
10495 T{ : GD2 DO I -1 +LOOP ; -> }T
10496 T{ 1 4 GD2 -> 4 3 2 1 }T
10497 T{ -1 2 GD2 -> 2 1 0 -1 }T
10498 T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T
10499
10500 T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T
10501 T{ 4 1 GD3 -> 1 2 3 }T
10502 T{ 2 -1 GD3 -> -1 0 1 }T
10503 T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T
10504
10505 T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T
10506 T{ 1 4 GD4 -> 4 3 2 1 }T
10507 T{ -1 2 GD4 -> 2 1 0 -1 }T
10508 T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T
10509
10510 T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T
10511 T{ 1 GD5 -> 123 }T
10512 T{ 5 GD5 -> 123 }T
10513 T{ 6 GD5 -> 234 }T
10514
10515 T{ : GD6  ( PAT: T{0 0}T,T{0 0}TT{1 0}TT{1 1}T,T{0 0}TT{1 0}TT{1 1}TT{2 0}TT{2 1}TT{2 2}T )
10516     0 SWAP 0 DO
10517         I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
10518     LOOP ; -> }T
10519 T{ 1 GD6 -> 1 }T
10520 T{ 2 GD6 -> 3 }T
10521 T{ 3 GD6 -> 4 1 2 }T
10522
10523 \ ------------------------------------------------------------------------
10524 TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
10525
10526 T{ 123 CONSTANT X123 -> }T
10527 T{ X123 -> 123 }T
10528 T{ : EQU CONSTANT ; -> }T
10529 T{ X123 EQU Y123 -> }T
10530 T{ Y123 -> 123 }T
10531
10532 T{ VARIABLE V1 -> }T
10533 T{ 123 V1 ! -> }T
10534 T{ V1 @ -> 123 }T
10535
10536 T{ : NOP : POSTPONE ; ; -> }T
10537 T{ NOP NOP1 NOP NOP2 -> }T
10538 T{ NOP1 -> }T
10539 T{ NOP2 -> }T
10540
10541 T{ : DOES1 DOES> @ 1 + ; -> }T
10542 T{ : DOES2 DOES> @ 2 + ; -> }T
10543 T{ CREATE CR1 -> }T
10544 T{ CR1 -> HERE }T
10545 T{ ' CR1 >BODY -> HERE }T
10546 T{ 1 , -> }T
10547 T{ CR1 @ -> 1 }T
10548 T{ DOES1 -> }T
10549 T{ CR1 -> 2 }T
10550 T{ DOES2 -> }T
10551 T{ CR1 -> 3 }T
10552
10553 T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T
10554 T{ WEIRD: W1 -> }T
10555 T{ ' W1 >BODY -> HERE }T
10556 T{ W1 -> HERE 1 + }T
10557 T{ W1 -> HERE 2 + }T
10558
10559 \ ------------------------------------------------------------------------
10560 TESTING EVALUATE
10561
10562 : GE1 S" 123" ; IMMEDIATE
10563 : GE2 S" 123 1+" ; IMMEDIATE
10564 : GE3 S" : GE4 345 ;" ;
10565 : GE5 EVALUATE ; IMMEDIATE
10566
10567 T{ GE1 EVALUATE -> 123 }T           ( TEST EVALUATE IN INTERP. STATE )
10568 T{ GE2 EVALUATE -> 124 }T
10569 T{ GE3 EVALUATE -> }T
10570 T{ GE4 -> 345 }T
10571
10572 T{ : GE6 GE1 GE5 ; -> }T            ( TEST EVALUATE IN COMPILE STATE )
10573 T{ GE6 -> 123 }T
10574 T{ : GE7 GE2 GE5 ; -> }T
10575 T{ GE7 -> 124 }T
10576
10577 \ ------------------------------------------------------------------------
10578 TESTING SOURCE >IN WORD
10579
10580 : GS1 S" SOURCE" 2DUP EVALUATE
10581         >R SWAP >R = R> R> = ;
10582 T{ GS1 -> <TRUE> <TRUE> }T
10583
10584 VARIABLE SCANS
10585 : RESCAN?  -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
10586
10587 T{ 2 SCANS !
10588 345 RESCAN?
10589 -> 345 345 }T
10590
10591 : GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
10592 T{ GS2 -> 123 123 123 123 123 }T
10593
10594 : GS3 WORD COUNT SWAP C@ ;
10595 T{ BL GS3 HELLO -> 5 CHAR H }T
10596 T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T
10597 T{ BL GS3
10598 DROP -> 0 }T                \ BLANK LINE RETURN ZERO-LENGTH STRING
10599
10600 : GS4 SOURCE >IN ! DROP ;
10601 T{ GS4 123 456
10602 -> }T
10603
10604 \ ------------------------------------------------------------------------
10605 TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
10606
10607 : S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
10608     >R SWAP R@ = IF          \ MAKE SURE STRINGS HAVE SAME LENGTH
10609         R> ?DUP IF            \ IF NON-EMPTY STRINGS
10610         0 DO
10611         OVER C@ OVER C@ - IF
10612             2DROP <FALSE> UNLOOP EXIT THEN
10613         SWAP CHAR+ SWAP CHAR+
10614             LOOP
10615         THEN
10616         2DROP <TRUE>          \ IF WE GET HERE, STRINGS MATCH
10617     ELSE
10618         R> DROP 2DROP <FALSE>     \ LENGTHS MISMATCH
10619     THEN ;
10620
10621 : GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
10622 T{ GP1 -> <TRUE> }T
10623
10624 : GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
10625 T{ GP2 -> <TRUE> }T
10626
10627 : GP3  <# 1 0 # # #> S" 01" S= ;
10628 T{ GP3 -> <TRUE> }T
10629
10630 : GP4  <# 1 0 #S #> S" 1" S= ;
10631 T{ GP4 -> <TRUE> }T
10632
10633 24 CONSTANT MAX-BASE            \ BASE 2 .. 36
10634 : COUNT-BITS
10635     0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
10636 COUNT-BITS 2* CONSTANT #BITS-UD     \ NUMBER OF BITS IN UD
10637
10638 : GP5
10639     BASE @ <TRUE>
10640     MAX-BASE 1+ 2 DO         \ FOR EACH POSSIBLE BASE
10641         I BASE !              \ TBD: ASSUMES BASE WORKS
10642         I 0 <# #S #> S" 10" S= AND
10643     LOOP
10644     SWAP BASE ! ;
10645 T{ GP5 -> <TRUE> }T
10646
10647 : GP6
10648     BASE @ >R  2 BASE !
10649     MAX-UINT MAX-UINT <# #S #>       \ MAXIMUM UD TO BINARY
10650     R> BASE !                \ S: C-ADDR U
10651     DUP #BITS-UD = SWAP
10652     0 DO                 \ S: C-ADDR FLAG
10653         OVER C@ [CHAR] 1 = AND        \ ALL ONES
10654         >R CHAR+ R>
10655     LOOP SWAP DROP ;
10656 T{ GP6 -> <TRUE> }T
10657
10658 : GP7
10659     BASE @ >R    MAX-BASE BASE !
10660     <TRUE>
10661     A 0 DO
10662         I 0 <# #S #>
10663         1 = SWAP C@ I 30 + = AND AND
10664     LOOP
10665     MAX-BASE A DO
10666         I 0 <# #S #>
10667         1 = SWAP C@ 41 I A - + = AND AND
10668     LOOP
10669     R> BASE ! ;
10670
10671 T{ GP7 -> <TRUE> }T
10672
10673 \ >NUMBER TESTS
10674 CREATE GN-BUF 0 C,
10675 : GN-STRING GN-BUF 1 ;
10676 : GN-CONSUMED   GN-BUF CHAR+ 0 ;
10677 : GN'       [CHAR] ' WORD CHAR+ C@ GN-BUF C!  GN-STRING ;
10678
10679 T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T
10680 T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T
10681 T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T
10682 T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T   \ SHOULD FAIL TO CONVERT THESE
10683 T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T
10684 T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T
10685
10686 : >NUMBER-BASED
10687     BASE @ >R BASE ! >NUMBER R> BASE ! ;
10688
10689 T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T
10690 T{ 0 0 GN' 2'  2 >NUMBER-BASED -> 0 0 GN-STRING }T
10691 T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T
10692 T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T
10693 T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T
10694 T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T
10695
10696 : GN1   \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
10697     BASE @ >R BASE !
10698     <# #S #>
10699     0 0 2SWAP >NUMBER SWAP DROP      \ RETURN LENGTH ONLY
10700     R> BASE ! ;
10701 T{ 0 0 2 GN1 -> 0 0 0 }T
10702 T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
10703 T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
10704 T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T
10705 T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T
10706 T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T
10707
10708 : GN2   \ ( -- 16 10 )
10709     BASE @ >R  HEX BASE @  DECIMAL BASE @  R> BASE ! ;
10710 T{ GN2 -> 10 A }T
10711
10712 \ ------------------------------------------------------------------------
10713 TESTING FILL MOVE
10714
10715 CREATE FBUF 00 C, 00 C, 00 C,
10716 CREATE SBUF 12 C, 34 C, 56 C,
10717 : SEEBUF FBUF C@  FBUF CHAR+ C@  FBUF CHAR+ CHAR+ C@ ;
10718
10719 T{ FBUF 0 20 FILL -> }T
10720 T{ SEEBUF -> 00 00 00 }T
10721
10722 T{ FBUF 1 20 FILL -> }T
10723 T{ SEEBUF -> 20 00 00 }T
10724
10725 T{ FBUF 3 20 FILL -> }T
10726 T{ SEEBUF -> 20 20 20 }T
10727
10728 T{ FBUF FBUF 3 CHARS MOVE -> }T     \ BIZARRE SPECIAL CASE
10729 T{ SEEBUF -> 20 20 20 }T
10730
10731 T{ SBUF FBUF 0 CHARS MOVE -> }T
10732 T{ SEEBUF -> 20 20 20 }T
10733
10734 T{ SBUF FBUF 1 CHARS MOVE -> }T
10735 T{ SEEBUF -> 12 20 20 }T
10736
10737 T{ SBUF FBUF 3 CHARS MOVE -> }T
10738 T{ SEEBUF -> 12 34 56 }T
10739
10740 T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T
10741 T{ SEEBUF -> 12 12 34 }T
10742
10743 T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T
10744 T{ SEEBUF -> 12 34 34 }T
10745
10746 \ ------------------------------------------------------------------------
10747 TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
10748
10749 : OUTPUT-TEST
10750     ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
10751     41 BL DO I EMIT LOOP CR
10752     61 41 DO I EMIT LOOP CR
10753     7F 61 DO I EMIT LOOP CR
10754     ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
10755     9 1+ 0 DO I . LOOP CR
10756     ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
10757     [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
10758     ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
10759     [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
10760     ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
10761     5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
10762     ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
10763     S" LINE 1" TYPE CR S" LINE 2" TYPE CR
10764     ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
10765     ."   SIGNED: " MIN-INT . MAX-INT . CR
10766     ." UNSIGNED: " 0 U. MAX-UINT U. CR
10767 ;
10768
10769 T{ OUTPUT-TEST -> }T
10770 \ ------------------------------------------------------------------------
10771 TESTING INPUT: ACCEPT
10772
10773 CREATE ABUF 80 CHARS ALLOT
10774
10775 : ACCEPT-TEST
10776     CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
10777     ABUF 80 ACCEPT
10778     CR ." RECEIVED: " [CHAR] " EMIT
10779     ABUF SWAP TYPE [CHAR] " EMIT CR
10780 ;
10781
10782 T{ ACCEPT-TEST -> }T
10783 Vingt fois sur le métier remettez votre ouvrage, ... Boileau, L'Art poétique
10784 \ ------------------------------------------------------------------------
10785 TESTING DICTIONARY SEARCH RULES
10786
10787 T{ : GDX   123 ; : GDX   GDX 234 ; -> }T
10788
10789 T{ GDX -> 123 234 }T
10790
10791 CR .( End of Core word set tests) CR
10792
10793
10794 $0A BASE !
10795 ECHO
10796             ; end of core test
10797 PWR_HERE    ; preserved against power OFF