CORE EXT
( -- false )
Return a false flag.
0 CONSTANT FALSE
CORE EXT
( -- true )
Return a true flag, a single-cell value with all bits set.
-1 CONSTANT TRUE
( n1 n2 n3 -- n4 )
Multiply n1 by n2 producing the intermediate double-cell result d. Divide d by n3 giving the single-cell quotient n4. An ambiguous condition exists if n3 is zero or if the quotient n4 lies outside the range of a signed number. If d and n3 differ in sign, the implementation-defined result returned will be the same as that returned by either the phrase >R M* R> FM/MOD SWAP DROP or the phrase >R M* R> SM/REM SWAP DROP .
: */ ( n1 n2 n3 --n4)
>R M* R> SM/REM NIP
;
star-slash-mod CORE
( n1 n2 n3 -- n4 n5 )
Multiply n1 by n2 producing the intermediate double-cell result d. Divide d by n3 producing the single-cell remainder n4 and the single-cell quotient n5. An ambiguous condition exists if n3 is zero, or if the quotient n5 lies outside the range of a single-cell signed integer. If d and n3 differ in sign, the implementation-defined result returned will be the same as that returned by either the phrase >R M* R> FM/MOD or the phrase >R M* R> SM/REM .
: */MOD ( n1 n2 n3 -- n4 n5 )
>R M* R> SM/REM ;
CORE
( n1|u1 -- n2|u2 )
Add one (1) to n1|u1 giving the sum n2|u2.
: 1+ ( x1 - x2)
one +
;
CORE
( n1|u1 -- n2|u2 )
Subtract one (1) from n1|u1 giving the difference n2|u2.
: 1- ( x1 -- x2)
one -
;
CORE
( a-addr1 -- a-addr2 )
Add the size in address units of a cell to a-addr1, giving a-addr2. As with ALIGN and ALIGNED, the words CELL and CELL+ were added to aid in transportability across systems with different cell sizes. They are intended to be used in manipulating indexes and addresses in integral numbers of cell-widths.
Example: 2VARIABLE DATA 0 100 DATA 2! DATA @ . 100 DATA CELL+ @ . 0
: CELL+ ( a-addr1 -- a-addr2 )
four +
;
: cell- ( a-addr -- a-addr2 )
four -
;
two-store CORE
( x1 x2 a-addr -- )
Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the next consecutive cell. It is equivalent to the sequence SWAP OVER ! CELL+ !
: 2! ( x1 x2 a-addr -- )
SWAP OVER ! CELL+ !
;
CORE
( x1 -- x2 )
x2 is the result of shifting x1 one bit toward the most-significant bit, filling the vacated least-significant bit with zero.
: 2* ( x1 -- x2 )
one LSHIFT
;
two-fetch CORE
( a-addr -- x1 x2 )
Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and x1 at the next consecutive cell. It is equivalent to the sequence DUP CELL+ @ SWAP @
: 2@ ( a-addr -- x1 x2 )
DUP CELL+ @ SWAP @
;
CORE
( addr -- a-addr )
a-addr is the first aligned address greater than or equal to addr.
: ALIGNED ( addr -- a-addr
1+ -2 AND ;
: 4aligned ( addr -- a-addr)
3 + -4 AND ;
\ line aligned, needed for fast DMA
: 16aligned ( addr -- a-addr)
0F + -10 AND ;
CORE
( -- char )
char is the character value for a space. Because space is used throughout Forth as the standard delimiter, this word is the only way a program has to find and use the system value of space. The value of a space character can not be obtained with CHAR, for instance.
20 CONSTANT BL
CORE
( n1 -- n2 )
n2 is the size in address units of n1 cells.
Example:
\ Allots space in the array NUMBERS for 100 cells of data. CREATE NUMBERS 100 CELLS ALLOT
: CELLS ( n1 -- n2)
two LSHIFT
;
CORE
( c-addr1 -- c-addr2 )
Add the size in address units of a character to c-addr1, giving c-addr2.
: CHAR+ ( c-addr1 -- c-addr2 )
1+
; inline
CORE
( n1 -- n2 )
n2 is the size in address units of n1 characters. COLDFORTH As we plan to move to 16bit characters,this we try and use.
: CHARS ( n1 -- n2 ) ; inline \ it actually adds nothing to the compiled code
CORE
( c-addr1 -- c-addr2 u )
Return the character string specification for the counted string stored at c-addr1. c-addr2 is the address of the first character after c-addr1. u is the contents of the character at c-addr1, which is the length in characters of the string at c-addr2.
zero
DUP CONSTANT _#$_count 1+
DUP CONSTANT _#$_data
DROP
\ lenth of count field
_#$_data _#$_count - CONSTANT #$count_length
\ words to deal with string counts
: $count@ C@ ;
: $count! C! ;
: COUNT ( c-addr1 -- c-addr2 u )
DUP _#$_data + SWAP $count@
;
( n1 n2 -- n3 )
Divide n1 by n2, giving the single-cell remainder 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 DROP or the phrase >R S>D R> SM/REM DROP.
.S .( MOD)
: MOD ( n1 n2 -- n3 )
>R S>D R> SM/REM DROP
;
DOUBLE
( d1 d2 -- flag )
flag is true if and only if d1 is less than d2.
.S .( D<)
: D< ( d1 d2 -- f )
( l1 h1 l2 h2 -- f)
\ Signed compare two double numbers. If d1 < d2, return TRUE.
2 PICK \ l1 h1 l2 h2 h1 (--
OVER = \ l1 h1 l2 h2 h1 h2 (--
IF
DU<
ELSE
NIP \ l1 h1 h2 (--
ROT DROP \ h1 h2 (--
<
THEN
;
.S .( D< )
DOUBLE
( d -- flag )
flag is true if and only if d is less than zero.
: D0< ( d1 -- f1 )
zero zero D<
;
DOUBLE
( xd -- flag )
flag is true if and only if xd is equal to zero.
: D0= ( xd -- flag )
OR 0=
;
d-equals DOUBLE
( xd1 xd2 -- flag )
flag is true if and only if xd1 is bit-for-bit the same as xd2.
: D= ( d1 d2 --flag)
D- OR 0=
;
d-to-s DOUBLE
( d -- n )
n is the equivalent of d. An ambiguous condition exists if d lies outside the range of a signed single-cell number.
: D>S
DROP
; inline
DOUBLE
( d1 d2 -- d3 )
d3 is the greater of d1 and d2.
: DMAX ( d1 d2 -- d3 )
4dup D< IF
2SWAP
THEN
2DROP
;
DOUBLE
( d1 d2 -- d3 )
d3 is the lesser of d1 and d2.
: DMIN ( d1 d2 -- d3 )
4dup 2SWAP D< IF
2SWAP
THEN
2DROP
;
Tri negate.
: tnegate ( t1lo t1mid t1hi -- t2lo t2mid t2hi )
INVERT >R
INVERT >R
INVERT zero -1 -1 D+ S>D R> zero D+
R> +
;
Unsigned double by an unsigned integer to give a tri result.
: ut* ( ulo uhi u -- utlo utmid uthi )
SWAP >R dup>r
UM* zero R> R> UM* D+
;
Double by a integer to give a tri result.
.S .( mt*)
: mt* ( lo hi n -- tlo tmid thi )
DUP 0< IF
ABS OVER 0< IF
>R DABS R> ut*
ELSE
ut* tnegate
THEN
ELSE
OVER 0<
IF
>R DABS R> ut* tnegate
ELSE
ut*
THEN
THEN
;
Divide a tri number by an integer.
.S .( ut/)
: ut/ ( utlo utmid uthi n -- d1 )
dup>r UM/MOD -rot R> UM/MOD
NIP SWAP
;
( d1 n1 +n2 -- d2 )
Multiply d1 by n1 producing the triple-cell intermediate result t. Divide t by +n2 giving the double-cell quotient d2. An ambiguous condition exists if +n2 is zero or negative, or the quotient lies outside of the range of a double-precision signed integer.
.S .( M*/)
: M*/ ( d1 n1 +n2 -- d2 )
>R mt* DUP 0< IF
tnegate R> ut/ DNEGATE
ELSE
R> ut/
THEN
;
( c-addr u1 -- c-addr u2 )
If u1 is greater than zero, u2 is equal to u1 less the number of spaces at the end of the character string specified by c-addr u1. If u1 is zero or the entire string consists of spaces, u2 is zero.
: -TRAILING ( c-addr u1 -- c-addr u2 )
DUP IF
>R DUP DUP R> \ c-addr c_addr c-addr u1 (--
CHARS + [ 1 CHARS ]T LITERAL - \ c-addr c-addr end (--
DO
I char@ BL <> IF
I OVER - [ 1 CHARS ]T LITERAL +
UNLOOP
EXIT
THEN
[ 1 CHARS NEGATE ]T LITERAL +LOOP
\ all blank
zero
EXIT
THEN
;
STRING
( c-addr1 u1 n -- c-addr2 u2 )
Adjust the character string at c-addr1 by n characters. The resulting character string, specified by c-addr2 u2, begins at c-addr1 plus n characters and is u1 minus n characters long.
/STRING is used to remove or add characters relative to the left end of the character string. Positive values of n will exclude characters from the string while negative values of n will include characters to the left of the string. /STRING is a natural factor of WORD and commonly available.
: /STRING ( c-addr len n -- c-addr2 len2 )
OVER MIN \ c-addr len min (--
TUCK \ c-addr min len min (--
- \ c-addr min len2 (--
-rot \ len2 c-addr min (--
+ \ len2 c-addr2 (--
SWAP \ c-addr2 len2 (--
;
STRING
( c-addr u -- )
If u is greater than zero, store the character value for space in u consecutive character positions beginning at c-addr.
.S .( BLANK)
: BLANK ( c-addr u --)
BL FILL ;
STRING
( c-addr1 u1 c-addr2 u2 -- n )
Compare the string specified by c-addr1 u1 to the string specified by c-addr2 u2. The strings are compared, beginning at the given addresses, character by character, up to the length of the shorter string or until a difference is found. If the two strings are identical, n is zero. If the two strings are identical up to the length of the shorter string, n is minus-one (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not identical up to the length of the shorter string, n is minus-one (-1) if the first non-matching character in the string specified by c-addr1 u1 has a lesser numeric value than the corresponding character in the string specified by c-addr2 u2 and one (1) otherwise.
.S .( _#less)
\ Describe the result, sorry I hate magic numbers.
-1 CONSTANT _#less
0 CONSTANT _#same
1 CONSTANT _#greater
\
: COMPARE ( addr1 u1 addr2 u2 --tri)
ROT \ addr1 addr2 u2 u1 (--
\ If the strings are equal up to the shortest the result
\ depends on the length. The strings are treated as if the
\ missing characters are less than zero.
2DUP > IF \ addr1 addr2 u2 u1 (--
_#less
ELSE
2DUP < IF
_#greater
ELSE
_#same
THEN
THEN
\ addr1 addr2 u2 u1 value (--
>R
MIN zero ?DO
DUP char@ \ addr1 addr2 char2 (--
jump char@ \ addr1 addr2 char2 char1 (--
2DUP \ addr1 addr2 char2 char1 char2 char1(--
> IF
4drop
_#greater
UNLOOP
r>drop
EXIT
THEN
< IF
2DROP
_#less
UNLOOP
r>drop
EXIT
THEN
CHAR+ SWAP CHAR+ SWAP \ addr1+1 addr2+1 (--
[ 1 CHARS ]T LITERAL +LOOP
2DROP
\ equal up to the shortest, result depends on length
R>
;
STRING
( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag )
Search the string specified by c-addr1 u1 for the string specified by c-addr2 u2. If flag is true, a match was found at c-addr3 with u3 characters remaining. If flag is false there was no match and c-addr3 is c-addr1 and u3 is u1.
: _byte_data= ( c-addr c-addr2 u2 -- flag)
zero DO
OVER C@ OVER C@ <> IF
2DROP UNLOOP FALSE EXIT
THEN
1+ SWAP 1+
LOOP
2DROP
TRUE
;
: SEARCH { ( c-addr1 u1 ) variable c-addr2 variable u2 -- ( c-addr3 u3 flag ) }{
}
u2 @ 0= IF
TRUE
EXIT
THEN
\ once around for each character position
2DUP \ c-addr1 u1 c-addr1 u1(--
BEGIN
\ if search string is greater in length than number of characters left
\ then failure.
u2 @ OVER > IF
2DROP
FALSE
EXIT
THEN
OVER
c-addr2 @ u2 @ \ c-addr1 u1 c-addr1 u1 c-addr1 c-addr2 u2(--
_byte_data= IF
2SWAP 2DROP
TRUE
EXIT
THEN
SWAP 1+
SWAP 1-
AGAIN
;