Subroutines needed by standard words if processor doesn't support a divide. I think this is the best you can do.
Funny how things change, on a processor like the coldfire it is better to loop than unwind the code as memory access is slow.
\ Algoritham supplied by FORTH inc.
\ leave the head on basic 64/32 divide is very useful.
\ pity the processor didn't provide it.
\ LABEL (um/mod)
\ D3 R -) MOV
\ 0 # A0 MOV \ 32 bits thru the loop
\ BEGIN \
\ D1 D1 ADDX \ d1 left one bit,
\ D0 D0 ADDX \ and propagate msb of d1 when shifting d0
\ CS IF \ d0 shifted out a one,
\ D2 D0 SUB \ reduce d0 by d2 (divisor)
\ D3 D3 SUB \ generate phony X bit for next d1 shift
\ ELSE \ if no zero out of dshift
\ D2 D0 SUB \ try to reduce d0 by divisor
\ CS IF \ if fails,
\ D2 D0 ADD \ add divisor back
\ THEN \
\ THEN \
\ \ Doing it this way result in a test that doesn't effect
\ \ the x bit. I didn't see this FORTH inc did
\ 1 0) A0 LEA \ repeat, 32 times
\ $20 # A0 CMP \
\ EQ UNTIL \
\ D1 D1 ADDX \ final shift for return value
\ -1 # D1 EOR \ and compliment, since we used inverted logic
\ R )+ D3 MOV
\ RTS
\
\ Faster version Thanks to:
\ Wayne Deeter wrd@logical-co.com
\ D2 divisor
\ D0 hi
\ D1 low
\ output
\ D1 quot
\ D0 rem
\
LABEL (um/mod)
D3 R -) MOV
D4 R -) MOV
D5 R -) MOV
D2 D3 MOV
1 # D3 LSR
D2 D3 SUB \ divisor/2
A0 A0 SUB
D3 A0 SUB
$1F # D5 MOV
D2 D4 MOV
D5 D4 LSL
BEGIN
D4 D1 ADD
D3 D0 ADDX
D3 CC SCC
D1 D1 ADDX \ low
D0 D0 ADDX \ upp
D3 EXTB
D2 D3 AND
A0 D3 SUB
1 # D5 SUB
LT UNTIL
D3 TST
PL IF
D2 D0 ADD
THEN
R )+ D5 MOV
R )+ D4 MOV
R )+ D3 MOV
NEXT
\ sub so return address
(um/mod) CONSTANT (um/mod)
??HEX
( x a-addr -- )
Store x at a-addr.
CODE ! ( 32b addr --)
S )+ A0 MOV
S )+ A0 ) MOV
NEXT inline
( n1|u1 n2|u2 -- n3|u3 )
Multiply n1|u1 by n2|u2 giving the product n3|u3.
CODE * ( n n - p)
S )+ D1 MOV
S ) D1 L. MULS
D1 S ) MOV
NEXT inline
( n1|u1 n2|u2 -- n3|u3 )
Add n2|u2 to n1|u1, giving the sum n3|u3.
CODE + ( n n -n)
S )+ D0 MOV
D0 S ) ADD
NEXT inline
( n|u a-addr -- )
Add n|u to the single-cell number at a-addr.
CODE +! ( n|u addr--)
S )+ A0 MOV
S )+ D0 MOV
D0 A0 ) ADD
NEXT inline
( u1|n1 n2|u2 -- n3|u3)
Subtract n2|u2 from n1|u1, giving the difference n3|u3.
CODE - ( u1|n1 n2|u2 -- n3|u3)
S )+ D0 MOV
D0 S ) SUB
NEXT inline
CORE
( n1 n2 -- n3 n4 )
Divide n1 by n2, giving the single-cell remainder n3 and the single-cell quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2 differ in sign, the implementation-defined result returned will be the same as that returned by either the phrase >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM .
CODE /MOD ( numi domi -- rem quot)
S )+ D0 MOV
S ) D1 MOV
D0 D2 D1 REMS
D0 D1 L. DIVS
D2 S ) MOV
D1 S -) MOV
NEXT
m-plus DOUBLE
( d1|ud1 n -- d2|ud2 )
Add n to d1|ud1, giving the sum d2|ud2.
CODE M+ ( d1|ud1 n -- d2|ud2 )
S )+ D2 MOV \ n
S )+ D1 MOV \ dhigh
S )+ D0 MOV \ dlow
0 # D3 MOV
D2 D0 ADD
D3 D1 ADDX
D0 S -) MOV
D1 S -) MOV
NEXT
CORE
( n1 n2 -- n3 )
Divide n1 by n2, giving the single-cell quotient n3. An ambiguous condition exists if n2 is zero. If n1 and n2 differ in sign, the implementation-defined result returned will be the same as that returned by either the phrase >R S>D R> FM/MOD SWAP DROP or the phrase >R S>D R> SM/REM SWAP DROP .
CODE / ( n1 n2 -- n3)
S )+ D0 MOV
S )+ D1 MOV
D0 D1 L. DIVS
D1 S -) MOV
NEXT
f-m-slash-mod CORE
( d1 n1 -- n2 n3 )
Divide d1 by n1, giving the floored quotient n3 and the remainder n2. Input and output stack arguments are signed. An ambiguous condition exists if n1 is zero or if the quotient lies outside the range of a single-cell signed integer.
Numi Domi Dividend Divisor Remainder Quotient -------- ------- --------- -------- 10 7 3 1 -10 7 4 -2 10 -7 -4 -2 -10 -7 -3 1
CODE FM/MOD ( numil numih domi -- rem quot )
S )+ D2 MOV \ domi
MI IF
D2 NEG \ domi is now positive
S )+ D0 MOV \ high numi
S )+ D1 MOV \ low numi
D0 TST
MI IF
D1 NEG \ numi is now positive
D0 NEGX
(um/mod) BSR
( domi - remainder -)
D0 NEG
ELSE
(um/mod) BSR
( domi - remainder -)
( And if rem non zero round down for floored division)
D0 TST NE IF
D2 D0 SUB
1 # D1 ADD
THEN
D1 NEG
THEN
ELSE
S )+ D0 MOV \ high numi
S )+ D1 MOV \ low numi
D0 TST
MI IF
D1 NEG
D0 NEGX
(um/mod) BSR
( If rem non zero round down for floored division)
( we add to D1 about to negate it)
D0 TST NE IF
D2 D0 SUB
D0 NEG
1 # D1 ADD
THEN
( quotent is negative if numi and domi are oppersate signs)
D1 NEG
ELSE
(um/mod) BSR
THEN
THEN
D0 S -) MOV ( remainder)
D1 S -) MOV ( quotent)
NEXT
( d1 n1 -- n2 n3 )
Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2. Input and output stack arguments are signed. An ambiguous condition exists if n1 is zero or if the quotient lies outside the range of a single-cell signed integer.
Numi Domi Dividend Divisor Remainder Quotient -------- ------- --------- -------- 10 7 3 1 -10 7 -3 -1 10 -7 3 -1 -10 -7 -3 1
CODE SM/REM ( numil numih domi -- rem quot )
S )+ D2 MOV \ domi
MI IF
D2 NEG \ domi is now positive
S )+ D0 MOV \ high numi
S )+ D1 MOV \ low numi
D0 TST
MI IF
D1 NEG \ numi is now positive
D0 NEGX
(um/mod) BSR
( remainder takes the sign of numi)
D0 NEG
ELSE
(um/mod) BSR
( quotent is negative if numi and domi are)
( opersate signs)
D1 NEG
THEN
ELSE
S )+ D0 MOV \ high numi
S )+ D1 MOV \ low numi
D0 TST
MI IF
D1 NEG
D0 NEGX
(um/mod) BSR
( remainder takes the sign of numi)
D0 NEG
( quotent is negative if numi and domi are opppersate signs)
D1 NEG
ELSE
(um/mod) BSR
THEN
THEN
D0 S -) MOV ( remainder)
D1 S -) MOV ( quotent)
NEXT
CORE
( n -- flag )
flag is true if and only if n is less than zero.
CODE 0< ( n -flag)
FALSE # D1 MOV
S ) TST MI IF
TRUE # D1 MOV
THEN
D1 S ) MOV
NEXT
CORE EXT
( x -- flag )
flag is true if and only if x is not equal to zero.
CODE 0<> ( n --flag)
FALSE # D1 MOV
S ) TST NE IF
TRUE # D1 MOV
THEN
D1 S ) MOV
NEXT
\ TRUE -1 ??=
\ CODE 0<> ( x -- flag)
\ S )+ D0 MOV
\ 0 # D1 MOV
\ -1 # D0 ADD
\ D1 D1 SUBX
\ D1 S -) MOV
\ NEXT
CORE
( x -- flag )
flag is true if and only if x is equal to zero.
CODE 0= ( n --flag )
FALSE # D1 MOV
S ) TST EQ IF
TRUE # D1 MOV
THEN
D1 S ) MOV
NEXT
CORE
( x1 -- x2 )
x2 is the result of shifting x1 one bit toward the least-significant bit, leaving the most-significant bit unchanged.
CODE 2/ ( x1 -- x2 )
S )+ D0 MOV
1 # D0 ASR
D0 S -) MOV
NEXT
CORE
( x1 x2 -- )
Drop cell pair x1 x2 from the stack.
CODE 2DROP ( a b --)
8 # S ADD
NEXT inline
CORE
( x1 x2 -- x1 x2 x1 x2 )
Duplicate cell pair x1 x2.
CODE 2DUP ( a b -- a b a b )
S ) \\ D0 D1 \\ MMOV
D1 S -) MOV
D0 S -) MOV
NEXT inline \ It is 8 bytes, but allow for speed
CODE
( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 )
Copy cell pair x1 x2 to the top of the stack.
CODE 2OVER ( a b c d -- a b c d a b)
0C S) S -) MOV
0C S) S -) MOV
NEXT inline
CORE
( x1 x2 x3 x4 -- x3 x4 x1 x2 )
Exchange the top two cell pairs.
CODE 2SWAP ( a b c d - c d a b )
S )+ D0 MOV
S )+ D1 MOV
S )+ D2 MOV
S )+ D3 MOV
D1 S -) MOV
D0 S -) MOV
D3 S -) MOV
D2 S -) MOV
NEXT
less-than CORE
( n1 n2 -- flag )
flag is true if and only if n1 is less than n2.
CODE < ( n n - flag)
FALSE # D2 MOV
S )+ D0 MOV
S ) D1 MOV
\ destination relative to source
D0 D1 CMP LT IF
TRUE # D2 MOV
THEN
D2 S ) MOV
NEXT
CORE
( x1 x2 -- flag )
flag is true if and only if x1 is bit-for-bit the same as x2.
CODE = ( n n --flag)
FALSE # D2 MOV
S )+ D0 MOV
S ) D0 SUB
EQ IF
TRUE # D2 MOV
THEN
D2 S ) MOV
NEXT inline \ critical word in search_thread
CORE
( n1 n2 -- flag )
flag is true if and only if n1 is greater than n2.
CODE > ( n n - flag)
FALSE # D2 MOV
S )+ D0 MOV
S ) D1 MOV
\ destination relative to source
D0 D1 CMP GT IF
TRUE # D2 MOV
THEN
D2 S ) MOV
NEXT
CORE
( x -- 0 | x x )
Duplicate x if it is non-zero.
CODE ?DUP ( n - 0| n n)
S ) TST NE IF
S ) S -) MOV
THEN
NEXT inline
CORE
( a-addr -- x )
x is the value stored at a-addr.
CODE @ ( addr -- 32b)
S )+ A0 MOV
A0 ) S -) MOV
NEXT inline
CORE
( n -- u )
u is the absolute value of n.
CODE ABS ( n --u)
S ) D0 MOV MI IF
D0 NEG
D0 S ) MOV
THEN
NEXT inline
CORE
( x1 x2 -- x3 )
x3 is the bit-by-bit logical and of x1 with x2.
CODE AND ( 32b 32b - 32b)
S )+ D0 MOV
D0 S ) AND
NEXT inline
( char c-addr -- )
CORE
Store char at c-addr. When character size is smaller than cell size, only the number of low-order bits corresponding to character size are transferred.
CODE C! ( n a)
S )+ A0 MOV
S )+ D0 MOV
D0 A0 ) B. MOV
NEXT inline
CORE
( c-addr -- char )
Fetch the character stored at c-addr. When the cell size is greater than character size, the unused high-order bits are all zeroes.
#5407 [IF]
CODE C@ ( addr --n)
S )+ A0 MOV
A0 ) D0 B. MVZ
D0 S -) MOV
NEXT inline
[ELSE]
CODE C@ ( addr --n)
S )+ A0 MOV
0 # D0 MOV
A0 ) D0 B. MOV
D0 S -) MOV \ 8 bytes but allow for speed
NEXT inline
[THEN]
CORE
( x -- )
Remove x from the stack.
CODE DROP ( 32b-)
4 # S ADD
NEXT inline
( x -- x x )
Duplicate x.
CODE DUP ( 32b - 32b 32b)
S ) S -) MOV
NEXT inline
( i*x xt -- j*x )
Remove xt from the stack and perform the semantics identified by it. Other stack effects are due to the word EXECUTEd.
CODE EXECUTE ( addr --)
S )+ W MOV
WVECTOR
( c-addr u char -- )
If u is greater than zero, store char in each of u consecutive characters of memory beginning at c-addr.
CODE FILL ( a n c --)
S )+ D2 MOV \ low 8 bits
S )+ D0 MOV EQ IF \ zero fill
4 # S ADD
ELSE \ data to move
S ) A0 MOV \ addr
D0 D1 MOV
S )+ D1 OR
03 # D1 AND NE IF ( have to use bytes)
BEGIN
D2 A0 )+ B. MOV
1 # D0 SUB
EQ UNTIL
ELSE ( long words thanks)
D2 D3 MOV
8 # D2 ASL
D3 D2 B. MOV
8 # D2 ASL
D3 D2 B. MOV
8 # D2 ASL
D3 D2 B. MOV
BEGIN
D2 A0 )+ MOV
4 # D0 SUB
EQ UNTIL
THEN
THEN
NEXT
Interpretation: Interpretation semantics for this word are undefined.
Execution: ( -- n|u ) ( R: loop-sys -- loop-sys )
n|u is a copy of the current (innermost) loop index. An ambiguous condition exists if the loop control parameters are unavailable.
CODE I ( - 32b)
4 R) S -) MOV
NEXT
( x1 -- x2 )
Invert all bits of x1, giving its logical inverse x2.
CODE INVERT ( x1 -- x2 )
S )+ D0 MOV
-1 # D0 EOR
D0 S -) MOV
NEXT inline
Interpretation: Interpretation semantics for this word are undefined.
Execution: ( -- n|u ) ( R: loop-sys1 loop-sys2 -- loop-sys1 loop-sys2 )
n|u is a copy of the next-outer loop index. An ambiguous condition exists if the loop control parameters of the next-outer loop, loop-sys1, are unavailable.
CODE J ( - 32b)
0C R) S -) MOV
NEXT
( x1 u -- x2 )
Perform a logical left shift of u bit-places on x1, giving x2. Put zeroes into the least significant bits vacated by the shift. An ambiguous condition exists if u is greater than or equal to the number of bits in a cell.
CODE LSHIFT ( x1 shift --)
S )+ D0 MOV
S )+ D1 MOV
D0 D1 LSL
D1 S -) MOV
NEXT inline \ 8 bytes allow for speed
( n1 n2 -- d )
d is the signed product of n1 times n2. This word is a useful early step in calculation, going to extra precision conveniently. It has been in use since the Forth systems of the early 1970's.
We use 16 * 16 -> 32 as it gives a simple to follow solution.
#USE_MAC [IF]
\ stack usage
zero
DUP EQU #{s}_sdm.n1
DUP EQU #{s}_sdm.rh CELL+
DUP EQU #{s}_sdm.n2
DUP EQU #{s}_sdm.rl CELL+
EQU #{s}_sdm.stack_length
\ Mac Constants
0x06 EQU #sign_bit
CODE M* ( N2 N1 --- Rl Rh )
MACSR D0 MOV
#sign_bit # D0 BSET
D0 MACSR MOV
D4 CLR
[ #{s}_sdm.n1 S ] D0 MOV
MI IF
D0 NEG
TRUE # D4 EOR
THEN
[ #{s}_sdm.n2 S ] D1 MOV
MI IF
D1 NEG
TRUE # D4 EOR
THEN
zero # ACC MOV
D0 D1 W. MAC \ B*D = LH|LL
ACC D2 MOV
D2 [ #{s}_sdm.rl S ] MOV
D2 W. CLR
D2 SWP \ D2 = 00|LH
D2 ACC MOV
D0 U. D1 W. MAC \ A*D + D2 = HL|LH + 00|LH
ACC D2 MOV \ D2 = AD + BDh
zero # ACC MOV
D0 D1 U. W. MAC \ B*C = HL|LH
ACC D3 MOV \ D3 = BC
D3 D2 ADD \ D2 = BC + AD + BDh ==> HL|LH
D2 [ #{s}_sdm.rl S ] W. MOV \ LH complete and place with LL
D3 CLR
D3 D3 ADDX
D3 D2 W. MOV \ Place extend bit in LH
D2 SWP \ D2 = HH extend only |HL
D2 ACC MOV
D0 U. D1 U. W. MAC \ A*C + D2 = HH|HL
ACC D2 MOV \ D2 = HH|LL
D2 [ #{s}_sdm.rh S ] MOV
D4 TST
NE IF
D2 NEG
[ #{s}_sdm.rl S ] D3 MOV
D3 NEG
D3 [ #{s}_sdm.rl S ] MOV
NE IF
0xFFFFFFFF # D2 ADD
THEN
D2 [ #{s}_sdm.rh S ] MOV
THEN
NEXT
[ELSE]
CODE M* ( a b -- low high)
1 # D6 MOV
S ) D0 MOV MI IF
D6 NEG
D0 NEG
D0 S ) MOV
THEN
4 S) D0 MOV MI IF
D6 NEG
D0 NEG
D0 4 S) MOV
THEN
0 # D7 MOV
0 S) D0 W. MOV ( A)
2 S) D1 W. MOV ( B)
4 S) D2 W. MOV ( C)
6 S) D3 W. MOV ( D)
D3 D4 MOV ( D)
D1 D4 MULU ( BD)
D4 6 S) W. MOV ( BD low bits)
D4 W. CLR ( saved on stack nothing more to do with calc)
D4 SWP ( BD high bits)
D2 D5 MOV ( C )
D1 D5 MULU ( BC)
D4 D5 ADD
D7 D7 ADDX ( collect the carry)
D0 D3 MULU ( AD )
D3 D5 ADD
0 # D3 MOV
D3 D7 ADDX ( collect the carry)
D5 4 S) W. MOV ( x bits )
D7 D5 W. MOV
D5 SWP ( xx bits)
D0 D2 MULU ( AC)
D2 D5 ADD
D5 S ) MOV ( xx and xxx bits)
D6 TST MI IF
4 S) D0 MOV
S ) D1 MOV
D0 NEG
D1 NEGX
D0 4 S) MOV
D1 S ) MOV
THEN
NEXT
[THEN]
( n1 n2 -- n3 )
n3 is the greater of n1 and n2.
CODE MAX ( n1 n2 - n3 )
S )+ D0 MOV
S ) D0 CMP GT IF
D0 S ) MOV
THEN
NEXT inline \ 8 bytes allow for speed
( n1 n2 -- n3 )
n3 is the lesser of n1 and n2.
CODE MIN ( n1 n2 - n3 )
S )+ D0 MOV
S ) D0 CMP LT IF
D0 S ) MOV
THEN
NEXT inline \ 8 bytes allow for speed
( addr1 addr2 u -- )
If u is greater than zero, copy the contents of u consecutive address units at addr1 to the u consecutive address units at addr2. After MOVE completes, the u consecutive address units at addr2 contain exactly what the u consecutive address units at addr1 contained before the move.
CODE MOVE ( from to num --)
S )+ D0 MOV NE IF \ ( data to move)
S )+ A1 MOV
S )+ A0 MOV
\ should the null case add time to the general case.
\ A0 A1 CMP EQ IF
\ NEXT assembler
\ THEN
\ can take out the address check here for 5307 as long word moves do not
\ have to be on longword boundries, however the rti1000 bus is not so
\ kind. But then the user should not be using rti1000
\ byte alligned addresses
D0 D1 MOV
3 # D1 AND EQ IF ( everything on a long word boundry)
\ destination relative to source
A0 A1 CMP HI IF \ move up in memory
D0 A0 ADD
D0 A1 ADD
BEGIN
A0 -) A1 -) MOV
4 # D0 SUB
EQ UNTIL
NEXT assembler
THEN \ move down in memory
BEGIN
A0 )+ A1 )+ MOV
4 # D0 SUB
EQ UNTIL
NEXT assembler
THEN
D0 D1 MOV
1 # D1 AND EQ IF ( everything on a word boundry)
\ destination relative to source
A0 A1 CMP HI IF \ move up in memory
D0 A0 ADD
D0 A1 ADD
BEGIN
A0 -) A1 -) W. MOV
2 # D0 SUB
EQ UNTIL
NEXT assembler
THEN \ move down in memory
BEGIN
A0 )+ A1 )+ W. MOV
2 # D0 SUB
EQ UNTIL
NEXT assembler
THEN
\ do it as a byte operations
A0 A1 CMP HI IF \ move up in memory
D0 A0 ADD
D0 A1 ADD
BEGIN
A0 -) A1 -) B. MOV
1 # D0 SUB
EQ UNTIL
NEXT assembler
THEN \ move down in memory
BEGIN
A0 )+ A1 )+ B. MOV
1 # D0 SUB
EQ UNTIL
NEXT assembler
THEN \ nothing to move
8 # S ADD
NEXT
( n1 -- n2 )
Negate n1, giving its arithmetic inverse n2.
CODE NEGATE ( n - n)
S ) D0 MOV
D0 NEG
D0 S ) MOV
NEXT inline
( x1 x2 -- x3 )
x3 is the bit-by-bit inclusive-or of x1 with x2.
CODE OR ( 32b 32b - 32b)
S )+ D0 MOV
D0 S ) OR
NEXT inline
( x1 x2 -- x1 x2 x1 )
Place a copy of x1 on top of the stack.
CODE OVER ( 32b1 32b2 - 32b1 32b2 32b1)
4 S) S -) MOV
NEXT inline
( x1 x2 x3 -- x2 x3 x1 )
Rotate the top three stack entries.
CODE ROT ( 32b1 32b2 32b3 -- 32b2 32b3 32b1)
S )+ D0 MOV
S )+ D1 MOV
S )+ D2 MOV
D1 S -) MOV
D0 S -) MOV
D2 S -) MOV
NEXT
( x1 u -- x2 )
Perform a logical right shift of u bit-places on x1, giving x2. Put zeroes into the most significant bits vacated by the shift. An ambiguous condition exists if u is greater than or equal to the number of bits in a cell.
CODE RSHIFT ( x1 shift --)
S )+ D0 MOV
S )+ D1 MOV
D0 D1 LSR
D1 S -) MOV
NEXT inline \ 8 bytes allow for speed.
( n -- d )
Convert the number n to the double-cell number d with the same numerical value.
CODE S>D ( n -- dl dh )
S ) D0 MOV MI IF
\ negative sign extend.
-1 # S -) MOV
ELSE
0 # S -) MOV
THEN
NEXT
( x1 x2 -- x2 x1 )
Exchange the top two stack items.
CODE SWAP ( 32b1 32b2 - 32b2 32b1)
S )+ D0 MOV
S )+ D1 MOV
D0 S -) MOV
D1 S -) MOV
NEXT inline \ 8 bytes allow for speed
( u1 u2 -- flag )
flag is true if and only if u1 is less than u2.
-1 TRUE ??=
CODE U< ( u1 u2 --flag )
0 # D2 MOV
S )+ D0 MOV \ u2
S )+ D1 MOV \ u1
D0 D1 SUB \ u1 u2 -
D2 D2 SUBX \ carry if u2 is greater=
\ or u1 is less
D2 S -) MOV
NEXT
u-greater-than CORE EXT
( u1 u2 -- flag )
flag is true if and only if u1 is greater than u2.
-1 TRUE ??=
CODE U> ( u1 u2 --flag )
0 # D2 MOV
S )+ D0 MOV \ u2
S )+ D1 MOV \ u1
D1 D0 SUB \ u1 u2 -
D2 D2 SUBX \ carry if u1 is greater
\ or u2 is less
D2 S -) MOV
NEXT
CORE
( u1 u2 -- ud )
Multiply u1 by u2, giving the unsigned double-cell product ud. All values and arithmetic are unsigned. We use 16 * 16 -> 32 as it gives a simple to follow solution.
CODE UM* ( a b -- low high)
0 # D7 MOV
0 S) D0 W. MOV ( A)
2 S) D1 W. MOV ( B)
4 S) D2 W. MOV ( C)
6 S) D3 W. MOV ( D)
D3 D4 MOV ( D)
D1 D4 MULU ( BD)
D4 6 S) W. MOV ( BD low bits)
D4 W. CLR ( saved on stack nothing more to do with calc)
D4 SWP ( BD high bits)
D2 D5 MOV ( C )
D1 D5 MULU ( BC)
D4 D5 ADD
D7 D7 ADDX ( collect the carry)
D0 D3 MULU ( AD )
D3 D5 ADD
0 # D3 MOV
D3 D7 ADDX ( collect the carry)
D5 4 S) W. MOV ( x bits )
D7 D5 W. MOV
D5 SWP ( xx bits)
D0 D2 MULU ( AC)
D2 D5 ADD
D5 S ) MOV ( xx and xxx bits)
NEXT
( ud u1 -- u2 u3 )
Divide ud by u1, giving the quotient u3 and the remainder u2. All values and arithmetic are unsigned. An ambiguous condition exists if u1 is zero or if the quotient lies outside the range of a single-cell unsigned integer.
CODE UM/MOD ( low high domi -- rem quot )
S )+ D2 MOV \ domi
S )+ D0 MOV \ high
S )+ D1 MOV \ low
(um/mod) BSR
D0 S -) MOV ( remainder)
D1 S -) MOV ( quotent)
NEXT
CORE
Interpretation: Interpretation semantics for this word are undefined.
Execution: ( -- ) ( R: loop-sys -- )
Discard the loop-control parameters for the current nesting level. An UNLOOP is required for each nesting level before the definition may be EXITed. An ambiguous condition exists if the loop-control parameters are unavailable.
Typical use: : X ... limit first DO ... test IF ... UNLOOP EXIT THEN ... LOOP ... ;
UNLOOP allows the use of EXIT within the context of DO ... LOOP and related do-loop constructs. UNLOOP as a function has been called UNDO. UNLOOP is more indicative of the action: nothing gets undone -- we simply stop doing it.
CODE UNLOOP ( --)
R )+ W MOV
8 # R ADD
W R -) MOV
NEXT
( x1 x2 -- x3 )
x3 is the bit-by-bit exclusive-or of x1 with x2.
CODE XOR ( 32b 32b - 32b)
S )+ D0 MOV
D0 S ) EOR
NEXT inline
CORE EXT
( n -- flag )
flag is true if and only if n is greater than zero.
CODE 0> ( n -- flag)
FALSE # D1 MOV
S ) TST GT IF
TRUE # D1 MOV
THEN
D1 S ) MOV
NEXT
CORE EXT
Interpretation: Interpretation semantics for this word are undefined.
Execution: ( -- x1 x2 ) ( R: x1 x2 -- x1 x2 )
Copy cell pair x1 x2 from the return stack. Semantically equivalent to R> R> 2DUP >R >R SWAP .
CODE 2R@ ( -- x1 x2 )
R )+ W MOV
4 R) S -) MOV
R ) S -) MOV
W R -) MOV
NEXT
CORE EXT
( x1 x2 -- flag )
flag is true if and only if x1 is not bit-for-bit the same as x2.
CODE <> ( n n - flag )
FALSE # D2 MOV
S )+ D0 MOV
S ) D1 MOV
D0 D1 CMP NE IF
TRUE # D2 MOV
THEN
D2 S ) MOV
NEXT
( addr u -- )
If u is greater than zero, clear all bits in each of u consecutive address units of memory beginning at addr. COLDFORTH: Coded for minimum branch delays on long word fill This could be written using FILL, but it is an important word so it has been left as code.
CODE ERASE ( a n --)
S )+ D0 MOV NE IF
S )+ A0 MOV \ addr
D0 D1 MOV
03 # D1 AND EQ IF ( can use long)
\ D1 already contains zero after the alignment test
BEGIN
D1 A0 )+ MOV
4 # D0 SUB
EQ UNTIL
NEXT
assembler
THEN
01 # D1 AND EQ IF
BEGIN
D1 A0 )+ W. MOV
2 # D0 SUB
EQ UNTIL
NEXT
assembler
THEN
0 # D1 MOV
BEGIN
D1 A0 )+ B. MOV
1 # D0 SUB
EQ UNTIL
NEXT
assembler
ELSE
4 # S ADD
THEN
NEXT
( x1 x2 -- x2 )
Drop the first item below the top of stack.
CODE NIP ( 32b1 32b2 -- 32b2)
S )+ S ) MOV
NEXT inline
( xu ... x1 x0 u -- xu ... x1 x0 xu )
Remove u. Copy the xu to the top of the stack. An ambiguous condition exists if there are less than u+2 items on the stack before PICK is executed. 0 PICK is equivalent to DUP and 1 PICK is equivalent to OVER.
CODE PICK ( n -- 32b )
S )+ D0 MOV
[ S D0 4 ] S -) MOV
NEXT inline
( xu xu-1 ... x0 u -- xu-1 ... x0 xu )
Remove u. Rotate u+1 items on the top of the stack. An ambiguous condition exists if there are less than u+2 items on the stack before ROLL is executed.
2 ROLL is equivalent to ROT, 1 ROLL is equivalent to SWAP and 0 ROLL is a null operation.
CODE ROLL
[ S ]+ D0 MOV
[ S D0 4 ] A0 LEA
[ S D0 4 ] [ S -] MOV
BEGIN
[ A0 -] [ 4 A0 ] MOV
1 # D0 SUB
CS UNTIL
\ remember never have anything on the stack
\ on the wrong side of the stack pointer.
4 # S ADD
NEXT
c-s-pick TOOLS EXT
Interpretation: Interpretation semantics for this word are undefined.
Execution: ( C: destu ... orig0|dest0 -- destu ... orig0|dest0 destu )( S: u -- )
Remove u. Copy destu to the top of the control-flow stack. An ambiguous condition exists if there are less than u+1 items, each of which shall be an orig or dest, on the control-flow stack before CS-PICK is executed.
If the control-flow stack is implemented using the data stack, u shall be the topmost item on the data stack.
The intent is to reiterate a dest on the control-flow stack so that it can be resolved more than once. For example:
\ Conditionally transfer control to beginning of loop \ This is similar in spirit to C's "continue" statement. : ?REPEAT ( dest -- dest ) \ Compilation ( flag -- ) \ Execution 0 CS-PICK POSTPONE UNTIL ; IMMEDIATE : XX ( -- ) \ Example use of ?REPEAT BEGIN ... flag ?REPEAT ( Go back to BEGIN if flag is false ) ... flag ?REPEAT ( Go back to BEGIN if flag is false ) ... flag UNTIL ( Go back to BEGIN if flag is false ) ... ;
As the compile stack is the data stack, and as each item is two stack items, CS-PICK is equivilant to 2pick in this system.
CODE CS-PICK ( n -- 32b )
S )+ D0 MOV
1 # D0 ASL
[ 4 S D0 4 ] S -) MOV
[ 4 S D0 4 ] S -) MOV
NEXT
c-s-roll TOOLS EXT
Interpretation: Interpretation semantics for this word are undefined.
Execution: ( C: origu|destu origu-1|destu-1 ... orig0|dest0 -- origu-1|destu-1 ... orig0|dest0 origu|destu )( S: u -- )
Remove u. Rotate u+1 elements on top of the control-flow stack so that origu|destu is on top of the control-flow stack. An ambiguous condition exists if there are less than u+1 items, each of which shall be an orig or dest, on the control-flow stack before CS-ROLL is executed.
If the control-flow stack is implemented using the data stack, u shall be the topmost item on the data stack.
CODE CS-ROLL
[ S ]+ D0 MOV
1 # D0 ASL
[ S D0 4 ] A0 LEA
[ 4 S D0 4 ] [ S -] MOV
[ 4 S D0 4 ] [ S -] MOV
1 # D0 ADD
BEGIN
[ A0 -] [ 8 A0 ] MOV
1 # D0 SUB
CS UNTIL
\ remember never have anything on the stack
\ on the wrong side of the stack pointer.
8 # S ADD
NEXT
( x1 x2 -- x2 x1 x2 )
Copy the first (top) stack item below the second stack item.
CODE TUCK ( 32b1 32b2 -- 32b2 32b1 32b2)
S )+ D0 MOV
S )+ D1 MOV
D0 S -) MOV
D1 S -) MOV
D0 S -) MOV
NEXT
( n1|u1 n2|u2 n3|u3 -- flag )
Perform a comparison of a test value n1|u1 with a lower limit n2|u2 and an upper limit n3|u3, returning true if either (n2|u2 < n3|u3 and (n2|u2 <= n1|u1 and n1|u1 < n3|u3)) or (n2|u2 > n3|u3 and (n2|u2 <= n1|u1 or n1|u1 < n3|u3)) is true, returning false otherwise. An ambiguous condition exists if n1|u1, n2|u2, and n3|u3 are not all the same type.
TRUE if lo <= n < hi
CODE WITHIN ( value lo hi - t)
S )+ D0 MOV \ hi
S )+ D1 MOV \ lo
S )+ D2 MOV \ n|u
FALSE # S -) MOV
D1 D0 SUB \ hi lo -
D1 D2 SUB \ value lo -
D0 D2 SUB \ ( hi lo - ) ( value lo - ) -
CS IF
TRUE # S ) MOV
THEN
NEXT
DOUBLE
( d1|ud1 d2|ud2 -- d3|ud3 )
Add d2|ud2 to d1|ud1, giving the sum d3|ud3.
CODE D+ ( lo1 hi1 lo2 hi2 -- lo3 hi3 )
\ hi2 -> D0
\ lo2 -> D1
\ hi1 -> D2
\ lo1 -> D3
\ want
\ D2 hi3
\ D3 lo3
S ) \\ D3 D0 \\ MMOV
8 # S ADD
D1 D3 ADD
D0 D2 ADDX
\\ D3 D2 \\ S ) MMOV
NEXT
DOUBLE
( d1|ud1 d2|ud2 -- d3|ud3 )
Subtract d2|ud2 from d1|ud1, giving the difference d3|ud3.
CODE D- ( lo1 hi1 lo2 hi2 -- lo3 hi3 )
\ hi2 -> D0
\ lo2 -> D1
\ hi1 -> D2
\ lo1 -> D3
\ want
\ D2 hi3
\ D3 lo3
S ) \\ D3 D0 \\ MMOV
8 # S ADD
D1 D3 SUB
D0 D2 SUBX
\\ D3 D2 \\ S ) MMOV
NEXT
DOUBLE
( xd1 -- xd2 )
xd2 is the result of shifting xd1 one bit toward the most-significant bit, filling the vacated least-significant bit with zero.
CODE D2* ( lo1 hi1 -- lo2 hi2 )
S )+ D0 MOV \ hi
S )+ D1 MOV \ lo
0 # D2 MOV
1 # D0 ASL
1 # D1 ASL
D2 D0 ADDX
D1 S -) MOV
D0 S -) MOV
NEXT
DOUBLE
( xd1 -- xd2 )
xd2 is the result of shifting xd1 one bit toward the least-significant bit, leaving the most-significant bit unchanged.
There is no ROXL instruction and I can see no better way
CODE D2/ ( lo1 hi1 -- lo2 hi2 )
S )+ D0 MOV \ hi
S )+ D1 MOV \ lo
0 # D2 MOV
1 # D1 LSR
1 # D0 LSR
D2 D2 ADDX
1F # D3 MOV
D3 D2 ASL
D2 D1 OR
D1 S -) MOV
D0 S -) MOV
NEXT
DOUBLE
( d -- ud )
ud is the absolute value of d.
CODE DABS ( lo1 hi1 -- lo2 hi2)
S ) D0 MOV MI IF
4 S) D1 MOV
D1 NEG \ low
D0 NEGX \ high
D1 4 S) MOV
D0 S ) MOV
THEN
NEXT
DOUBLE
( d1 -- d2 )
d2 is the negation of d1.
CODE DNEGATE ( lo1 hi1 -- lo2 hi2 )
S )+ D0 MOV
S )+ D1 MOV
D1 NEG \ low
D0 NEGX \ high
D1 S -) MOV
D0 S -) MOV
NEXT
DOUBLE EXT
( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 )
Rotate the top three cell pairs on the stack bringing cell pair x1 x2 to the top of the stack.
CODE 2ROT ( x5 x4 x3 x2 x1 x0 -- x3 x2 x1 x0 x5 x4 )
S ) \\ D5 D0 \\ MMOV
8 # S ADD
\\ D3 D0 \\ S ) MMOV
D5 S -) MOV
D4 S -) MOV
NEXT
DOUBLE EXT
( ud1 ud2 -- flag )
flag is true if and only if ud1 is less than ud2.
-1 TRUE ??=
CODE DU< ( lo1 hi1 lo2 h1 2 --flag)
\ hi2 -> D0
\ lo2 -> D1
\ hi1 -> D2
\ lo1 -> D3
0 # D4 MOV \ for flag generation
S ) \\ D3 D0 \ MMOV
10 S) S LEA
D1 D3 SUB
D0 D2 SUBX
D4 D4 SUBX \ generate flag
D4 S -) MOV
NEXT
STRING
( c-addr1 c-addr2 u -- )
If u is greater than zero, copy u consecutive characters from the data space starting at c-addr1 to that starting at c-addr2, proceeding character-by-character from lower addresses to higher addresses.
If c-addr2 lies within the source region (i.e., when c-addr2 is not less than c-addr1 and c-addr2 is less than the quantity c-addr1 u CHARS +), memory propagation occurs.
Typical use: Assume a character string at address 100: ABCD. Then after
CODE CMOVE
S )+ D1 MOV
S )+ A0 MOV
S )+ A1 MOV
1 # D1 SUB CC IF
BEGIN
A1 )+ A0 )+ B. MOV
1 # D1 SUB
CS UNTIL
THEN
NEXT
STRING
( c-addr1 c-addr2 u -- )
If u is greater than zero, copy u consecutive characters from the data space starting at c-addr1 to that starting at c-addr2, proceeding character-by-character from higher addresses to lower addresses.
If c-addr1 lies within the destination region (i.e., when c-addr1 is greater than or equal to c-addr2 and c-addr2 is less than the quantity c-addr1 u CHARS +), memory propagation occurs.
Typical use: Assume a character string at address 100: ABCD. Then after
CODE CMOVE>
S )+ D1 MOV
S )+ A0 MOV
S )+ A1 MOV
D1 A1 ADD
D1 A0 ADD
1 # D1 SUB CC IF
BEGIN
A1 -) A0 -) B. MOV
1 # D1 SUB
CS UNTIL
THEN
NEXT