mirror of https://github.com/mgcaret/of816.git
40 lines
1.2 KiB
Forth
40 lines
1.2 KiB
Forth
0 INVERT CONSTANT MAX-UINT
|
|
0 INVERT 1 RSHIFT CONSTANT MAX-INT
|
|
0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT
|
|
0 INVERT 1 RSHIFT CONSTANT MID-UINT
|
|
0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1
|
|
|
|
: IFFLOORED
|
|
[ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
|
|
|
|
: IFSYM
|
|
[ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
|
|
|
|
\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
|
|
\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
|
|
|
|
IFFLOORED : T/MOD >R S>D R> FM/MOD ;
|
|
IFFLOORED : T/ T/MOD SWAP DROP ;
|
|
IFFLOORED : TMOD T/MOD DROP ;
|
|
IFFLOORED : T*/MOD >R M* R> FM/MOD ;
|
|
IFFLOORED : T*/ T*/MOD SWAP DROP ;
|
|
IFSYM : T/MOD >R S>D R> SM/REM ;
|
|
IFSYM : T/ T/MOD SWAP DROP ;
|
|
IFSYM : TMOD T/MOD DROP ;
|
|
IFSYM : T*/MOD >R M* R> SM/REM ;
|
|
IFSYM : T*/ T*/MOD SWAP DROP ;
|
|
|
|
0 CONSTANT 0S
|
|
0 INVERT CONSTANT 1S
|
|
|
|
T{ -> }T \ START WITH CLEAN SLATE
|
|
( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
|
|
T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T
|
|
T{ 0 BITSSET? -> 0 }T ( ZERO IS ALL BITS CLEAR )
|
|
T{ 1 BITSSET? -> 0 0 }T ( OTHER NUMBER HAVE AT LEAST ONE BIT )
|
|
T{ -1 BITSSET? -> 0 0 }T
|
|
|
|
( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
|
|
1S 1 RSHIFT INVERT CONSTANT MSB
|
|
T{ MSB BITSSET? -> 0 0 }T
|