Size of cell in address units.
4 CONSTANT cell
Muliply input by 4.
: 4*
two LSHIFT
;
Take address units and convert back to cells.
: cell/ ( n -- cells
4/
;
Input by 8.
: 8* ( x1 -- x2)
three LSHIFT
;
Input divided by 8.
: 8/ ( x1 -- x2)
three RSHIFT
;
Input by 8.
: 16* ( x1 --x2)
four LSHIFT
;
Input divided by 16.
: 16/ ( x2 -- x2)
four RSHIFT
;
Two is added to the input.
: 2+ ( u1|n1 -- u2|n2)
two +
;
Two is subtracted from the input.
: 2- ( u1|n1 -- u2|n2)
two -
;
Three is added to the input.
: 3+ ( u1|n1 -- u2|n2)
three +
;
Four is added to the input.
: 4+ ( u1|n1 -- u2|n2)
four +
;
Four is subtracted from the input.
: 4- ( u1|n1 -- u2|n2)
four -
;
Input is multipied by 3.
: 3* ( u1|n1 -- u2|n2)
three *
;
Eight is added to the input.
: 8+ ( u1|n1 -- u2|n2)
eight +
;
Eight is subtracted from the input.
: 8- ( u1|n1 -- u2|n2)
eight -
;
Duplicate the top stack item and fetch the data.
: dup@ ( addr -- addr 32b )
DUP @
; inline
Top three stack items a duplicated..
: 3DUP ( a b c -- a b c a b c)
jump jump jump
;
Move the counted string pointed to by addr1 to addr2, the length of the data area
at addr2 is given by max.
max includes the character count. It is the receiving data area length
: $move ( addr1 addr2 buffer_size --)
ROT \ addr2 max addr1(--
COUNT \ addr2 max addr1+1 characters(--
CHARS \ addr2 max addr1+1 bytes(--
#$count_length + \ addr2 max addr1+1 n1
ROT \ addr2 addr1+1 n1 max(--
MIN \ addr2 adr1+1 n2--
SWAP #$count_length - \ addr2 n2 addr1(--
-rot \ addr1 addr2 n2(--
MOVE
;
Signed compare two double numbers. If d1 > d2 , return TRUE.
: d> ( d1 d2 -- f )
2SWAP D<
;
Just like 0=, documents the fact that you expected a flag. See also 0= , INVERT and NEGATE.
: not ( flag -- flag1)
0=
; inline
Change unsigned number to double
: u>d ( u --dl dh )
0
; inline
Change double to unsigned, no error checking
: d>u ( u --dl dh )
DROP
; inline
Two unsigned numers are divided and the remaimder and quotent are returned.
: u/mod ( u1 u2 -- rem quot )
>R u>d R> UM/MOD
;
A double number is divided and a remainder and double number are returned. This is used in # . The divider is the contents of BASE the remainder is a character. The number returned is what remains after the division.
: mu/mod ( lo hi u -- rem lo hi )
>R zero R@ \ lo hi zero u
UM/MOD \ lo rem quot (--
R> \ lo rem quot u<-
SWAP \ lo rem u quot (--
>R \ lo rem u (--
UM/MOD \ rem quot (--
R> \ rem l h (--
;
Raise 2 to the specified power
2 2** -> 4
: 2** ( n - x1)
one SWAP LSHIFT
;
A value is fetched form address, if non zero it is used as a execution token.
: @execute ( addr --)
@ ?DUP IF EXECUTE THEN
;
Work out the asl value required to set the highest bit set in the value supplied.
eg: 4 >asl -> 2 2 2** -> 4 5 >asl -> 2
: >asl ( value -- asl_value)
zero SWAP \ count value (--
BEGIN
1 RSHIFT
DUP not IF
DROP
EXIT
THEN
SWAP 1+ SWAP
AGAIN
;
IEEE1275
Synonym for lshift
: << ( x1 u --x2)
LSHIFT ; inline
IEEE1275
Synonym for rshift
: >> ( x1 u --x2)
RSHIFT ; inline
IEEE1275
Arithmetic shift x1 right by u bit-places
CODE >>a S )+ D0 MOV S ) D1 MOV D0 D1 ASR D1 S ) MOV NEXTd>> ( lowd1 highd2 u -- lowd2 highd2 )
Double number logical shift right, u is limited to 32
20 CONSTANT #cell_bits CODE d>> ( lowd1 highd2 u -- lowd2 highd2 ) S )+ D0 MOV 1 # D1 MOV D0 D1 LSL ( bits of interest.) 1 # D1 SUB S )+ D6 MOV D6 D2 MOV ( low bits in high cell that have to be placed in low cell) D1 D2 AND #cell_bits # D3 MOV D0 D3 SUB D3 D2 LSL ( bits now as they have to be placed in low) S )+ D7 MOV D0 D7 LSR ( shifted in bits are zero) D2 D7 OR D0 D6 LSR D7 S -) MOV D6 S -) MOV NEXTd<< ( lowd1 highd2 u -- lowd2 highd2 )
Double number logical shift right, u is limited to 32
CODE d<< ( lowd1 highd2 u -- lowd2 highd2 ) S )+ D0 MOV 1 # D1 MOV D0 D1 LSL ( bits of interest.) 1 # D1 SUB #cell_bits # D3 MOV D0 D3 SUB ( bits to be used from low cell) D3 D1 LSL S )+ D6 MOV S )+ D7 MOV D7 D2 MOV ( low bits in high cell that have to be placed in low cell) D1 D2 AND D3 D2 LSR ( bits now as they have to be placed in high) D0 D6 LSL ( shifted in bits are zero) D2 D6 OR D0 D7 LSL D7 S -) MOV D6 S -) MOV NEXTd>>a ( lowd1 highd2 u -- lowd2 highd2 )
Double number arithmetric shift right, u is limited to 32
CODE d>>a ( lowd1 highd2 u -- lowd2 highd2 ) S )+ D0 MOV 1 # D1 MOV D0 D1 LSL ( bits of interest.) 1 # D1 SUB S )+ D6 MOV D6 D2 MOV ( low bits in high cell that have to be placed in low cell) D1 D2 AND #cell_bits # D3 MOV D0 D3 SUB D3 D2 LSL ( bits now as they have to be placed in low) S )+ D7 MOV D0 D7 LSR ( shifted in bits are zero) D2 D7 OR D0 D6 ASR D7 S -) MOV D6 S -) MOV NEXTMore double operators
dor ( d1 d2 -- d3 )
OR the two double numbers
CODE dor ( d1 d2 -- d3 ) S )+ D0 MOV \ high S )+ D1 MOV \ low S )+ D2 MOV \ high S )+ D3 MOV \ low D0 D2 OR D1 D3 OR D3 S -) MOV D2 S -) MOV NEXTdand ( d1 d2 -- d3 )
AND the two double numbers
CODE dand ( d1 d2 -- d3 ) S )+ D0 MOV \ high S )+ D1 MOV \ low S )+ D2 MOV \ high S )+ D3 MOV \ low D0 D2 AND D1 D3 AND D3 S -) MOV D2 S -) MOV NEXTdxor ( d1 d2 -- d3 )
XOR the two double numbers
CODE dxor ( d1 d2 -- d3 ) S )+ D0 MOV \ high S )+ D1 MOV \ low S )+ D2 MOV \ high S )+ D3 MOV \ low D0 D2 EOR D1 D3 EOR D3 S -) MOV D2 S -) MOV NEXTVector to entry in table, n is the entry number, addr is the base address of the table.
zero DUP CONSTANT _#vector_table_count 2+ DUP CONSTANT _#vector_table_data DROP : vector ( n addr --) TUCK _#vector_table_count + W@ 1- MIN CELLS _#vector_table_data + + @execute ;Remove leading blanks
: -leading { ( variable _%addr ) variable _%number -- ( a2 n2 ) } _%number @ zero DO DUP char@ BL <> IF _%number @ I - UNLOOP EXIT THEN 1 CHARS + LOOP \ get to here nothing but blank zero ; CREATE NULL 0 t, : $= ( addr addr -- flag) 2DUP $count@ SWAP $count@ <> IF 2DROP FALSE EXIT THEN DUP $count@ >R #$count_length + SWAP #$count_length + R> zero DO OVER char@ OVER char@ <> IF 2DROP UNLOOP FALSE EXIT THEN 1 CHARS + SWAP 1 CHARS + LOOP 2DROP TRUE ; \ convert a stack described string to a counted string \ The inverse of COUNT : $make ( source number destination --) 2DUP $count! #$count_length + SWAP MOVE ; ( $ WORDS) DECIMAL : -$trailing ( addr --) COUNT -TRAILING SWAP #$count_length - $count! ; _#less -1 ??= : $< ( $1 $2 --flag) SWAP COUNT ROT COUNT COMPARE 0< ; \ Non standard \ _#greater 1 ??= : $> ( $1 $2 --flag) SWAP COUNT ROT COUNT COMPARE 0> ; : $+ { ( $1 $2 ) variable %addr variable %buffer_length -- }{ variable %base variable %total_count } %addr @ %base ! \ room for count #$count_length NEGATE %buffer_length +! #$count_length %addr +! SWAP COUNT %buffer_length @ MIN DUP %total_count ! %addr @ SWAP MOVE \ $2(-- %total_count @ NEGATE %buffer_length +! %total_count @ %addr +! COUNT %buffer_length @ MIN DUP %total_count +! %addr @ SWAP MOVE %total_count @ %base @ $count! ; : $move ( addr1 addr2 buffer_size --) ROT \ addr2 max addr1(-- COUNT \ addr2 max addr1+1 characters(-- CHARS \ addr2 max addr1+1 bytes(-- #$count_length + \ addr2 max addr1+1 n1 ROT \ addr2 addr1+1 n1 max(-- MIN \ addr2 adr1+1 n2-- SWAP #$count_length - \ addr2 n2 addr1(-- -rot \ addr1 addr2 n2(-- MOVE ; \ The 5300 can handle unaligned operations : unaligned! ( value addr --) ! ; inline : unaligned@ ( addr --) @ ; inline : unalignedW@ ( addr --) W@ ; inline