Copyright Bill Muench All rights reserved.
Permission is granted for non-commercial use, provided this notice is included.
Contact Bill Muench concerning commercial use.
CR .( eForth library )
CR ( Copyright Bill Muench All rights reserved. )
( Bill Muench \ OntoLogic )
( \ Santa Cruz CA 95065 )
( 971005 move to CORE 0= BOUNDS NIP [CHAR] )
( 950512 change 2LITERAL add ?LEAVE )
( 950411 change DU. FIND remove DDEFER DVALUE DV! )
( fix VALUE TO COMPILE )
( move to CORE ['] )
( 941015 fix FIND per jfox )
( add SEARCH-WORDLIST WORD )
( 930307 start library collection )
MARKER E4.LIB
BASE @ !CSP
DECIMAL
( =========================================================== )
' .S 'OK ! ( prompt option )
( =========================================================== )
: UNUSED ( -- u ) DP 2@ - ; \ ???
: _C" ( -- a ) _" ; COMPILE-ONLY
: C" ( "ccc" -- ) ['] _C" COMPILE, ,C" ; IMMEDIATE
( =========================================================== )
: ?#S ( base -- n )
BASE @ >R BASE ! ( save and set radix )
-1 0 <# #S #> SWAP DROP ( save only count )
R> BASE ! ; ( restore radix )
: BINARY ( -- ) 2 BASE ! ;
: [COMPILE] ( 'name' -- ) ' COMPILE, ; IMMEDIATE
( numeric overrides ========================================== )
: X# ( -- ) ( 'ccc' -- n | d )
DOES> C@ ( new radix )
BASE @ >R BASE ! ( save and set radix )
PARSE-WORD ( get a u of string )
['] EVALUATE CATCH ( convert to number, set trap )
R> BASE ! THROW ; ( restore radix before error control )
CREATE B# ( 'ccc' -- n | d ) 2 C, X# IMMEDIATE
CREATE O# ( 'ccc' -- n | d ) 8 C, X# IMMEDIATE
CREATE D# ( 'ccc' -- n | d ) 10 C, X# IMMEDIATE
CREATE H# ( 'ccc' -- n | d ) 16 C, X# IMMEDIATE
CREATE T# ( 'ccc' -- n | d ) 36 C, X# IMMEDIATE
: .X ( -- ) DOES> C@ BASE @ >R BASE ! U. R> BASE ! ;
CREATE .B ( n -- ) 2 C, .X
CREATE .O ( n -- ) 8 C, .X
CREATE .D ( n -- ) 10 C, .X
CREATE .H ( n -- ) 16 C, .X
CREATE .T ( n -- ) 36 C, .X
( =========================================================== )
: @EXECUTE ( a -- ) @ ?DUP IF EXECUTE THEN ;
: DEFER ( 'name' -- ) CREATE 0 , DOES> @EXECUTE ;
: VALUE ( n 'name' -- ) CREATE , DOES> @ ;
: !TO ( n xt -- ) >BODY ! ;
: TO ( n 'name' -- )
' STATE @ ( compiling ? )
IF [COMPILE] LITERAL ['] !TO COMPILE, EXIT
THEN !TO ; IMMEDIATE
( =========================================================== )
: BLANK ( a u -- ) BL FILL ;
: ERASE ( a u -- ) 0 FILL ;
0 CONSTANT FALSE
0 DUP = CONSTANT TRUE
: 0> ( n -- ) NEGATE 0< ;
: 0<> ( n -- f ) IF -1 EXIT THEN 0 ; \ 0= INVERT ;
: <> ( n n -- f ) = 0= ;
: > ( n n -- f ) SWAP < ;
: U> ( u u -- f ) SWAP U< ;
: 1+ ( n -- n ) 1 + ;
: 1- ( n -- n ) 1 - ;
: 2+ ( n -- n ) 2 + ;
: 2- ( n -- n ) 2 - ;
: 2* ( n -- n ) 2 * ;
: 2/ ( n -- n ) 2 / ;
: TUCK ( n1 n2 -- n2 n1 n2 ) SWAP OVER ;
: -ROT ( n1 n2 n3 -- n3 n1 n2 ) SWAP >R SWAP R> ;
: UMIN ( u u -- u ) 2DUP U< IF BEGIN DROP ;
: UMAX ( u u -- u ) 2DUP U< UNTIL THEN SWAP DROP ;
( double number extensions ================================== )
: 2LITERAL ( d -- ) SWAP [COMPILE] LITERAL [COMPILE] LITERAL ; IMMEDIATE
: 2CONSTANT ( d 'name' -- ) CREATE , , DOES> 2@ ;
: 2VARIABLE ( 'name' -- ) CREATE 2 CELLS ALLOT ;
: 2>R ( n1 n2 -- ) ( R: -- n1 n2 )
SWAP R> SWAP >R SWAP >R >R ; COMPILE-ONLY
: 2R> ( -- n1 n2 ) ( R: n1 n2 -- )
R> R> SWAP R> SWAP >R SWAP ; COMPILE-ONLY
: 2R@ ( -- n1 n2 ) ( R: n1 n2 -- n1 n2 )
R> R> R@ SWAP >R SWAP R@ SWAP >R ; COMPILE-ONLY
: 2SWAP ( d1 d2 -- d2 d1 ) ROT >R ROT R> ;
: 2OVER ( d1 d2 -- d1 d2 d1 ) >R >R 2DUP R> R> 2SWAP ;
: 2ROT ( d1 d2 d3 -- d2 d3 d1 ) 2>R 2SWAP 2R> 2SWAP ;
: D0< ( d -- f ) SWAP DROP 0< ;
: D0> ( d -- f ) DNEGATE D0< ;
: D- ( d d -- d ) DNEGATE D+ ;
: D0= ( d -- f ) OR 0= ;
: D= ( d d -- f ) D- D0= ;
: D< ( d d -- f ) ROT 2DUP XOR IF SWAP 2SWAP 2DROP < ;
: DU< ( ud ud -- f )
ROT 2DUP XOR IF SWAP 2SWAP THEN THEN 2DROP U< ;
: DMIN ( d d -- d ) 2OVER 2OVER D< IF BEGIN 2DROP ;
: DMAX ( d d -- d ) 2OVER 2OVER D< UNTIL THEN 2SWAP 2DROP ;
: M+ ( d n -- d ) S>D D+ ;
: M- ( d n -- d ) S>D D- ;
: M* ( n n -- d )
2DUP XOR 0< >R ABS SWAP ABS UM* R> IF DNEGATE THEN ;
: M/ ( d n -- q ) FM/MOD SWAP DROP ;
: */MOD ( n n n -- r q ) >R M* R> FM/MOD ;
: */ ( n n n -- q ) */MOD SWAP DROP ;
: MU/MOD ( ud u -- ur udq ) >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ;
: D2* ( d -- d ) 2DUP D+ ;
: DU2/ ( ud -- ud ) 2 MU/MOD ROT DROP ;
: D2/ ( d -- d ) DUP >R 1 AND DU2/ R> 2/ OR ;
: DU.R ( ud n -- ) >R <# #S #> R> S.R ;
: DU. ( ud -- ) 0 DU.R SPACE ;
( ============================================================ )
: 3* ( n -- n ) DUP DUP + + ;
: 4* ( n -- n ) DUP + DUP + ;
( ??? ======================================================= )
: TU* ( ud u -- ut ) DUP >R SWAP >R UM* 0 R> R> UM* D+ ;
: TU/MOD ( ut u -- ur udq ) DUP >R UM/MOD R> SWAP >R UM/MOD R> ;
: M*/MOD ( ud u u -- ur udq ) >R TU* R> TU/MOD ;
: M*/ ( ud u u -- ud ) M*/MOD ROT DROP ;
( implementation defined ==================================== )
: MSB> ( hl -- zh ) 8 RSHIFT ; \ ???
: >MSB ( hl -- lz ) 8 LSHIFT ; \ ???
: LSB ( hl -- zl ) >MSB MSB> ;
: JOIN ( zl zh -- hl ) >MSB SWAP LSB OR ;
: SPLIT ( hl -- zl zh ) DUP LSB SWAP MSB> ;
: FLIP ( hl -- lh ) SPLIT SWAP JOIN ;
( =========================================================== )
: WWORDS ( 'ccc' -- ) ( try WWORDS A B C D E F )
BEGIN WORDS SOURCE SWAP DROP >IN @ = UNTIL ;
( =========================================================== )
: ROLL ( n ... +n -- ... n ) ( never never ROLL )
?DUP IF SWAP >R 1 - RECURSE R> SWAP THEN ;
: -ROLL ( ... n +n -- n ... ) ( never never never -ROLL )
?DUP IF ROT >R 1 - RECURSE R> THEN ;
( =========================================================== )
: NOT ( n -- n ) INVERT ;
: CONVERT ( ud a -- ud a ) CHAR+ -1 >NUMBER DROP ;
H# 80 CONSTANT =IMMEDIATE
: FIND ( a -- a 0 | xt 1 | xt -1 )
DUP >R COUNT SFIND ( found ? )
IF =IMMEDIATE AND ( attribute ? )
IF 1 ( immediate )
ELSE -1 ( non-immediate )
THEN R> DROP EXIT
THEN 2DROP R> 0 ; ( not found )
: SEARCH-WORDLIST ( a u wid -- 0 | xt 1 | xt -1 )
WID? ( found ? )
IF =IMMEDIATE AND ( attribute ? )
IF 1 EXIT ( immediate )
THEN -1 EXIT ( non-immediate )
THEN 2DROP 0 ; ( not found )
( =========================================================== )
\ The words EXPECT and SPAN are obsolescent.
\ The following definition may be used provided a program does not
\ depend on input being terminated when the final count is
\ reached.
VARIABLE SPAN
: EXPECT ( a u -- ) ACCEPT SPAN ! ;
( =========================================================== )
\ The word WORD is not used in eForth because it requires a
\ character string to be moved from the input buffer, converted
\ to a counted string, and placed in some other buffer. This is
\ unnecessary for both interpreting and compiling.
\ The ANS Standard has change all references to strings to an
\ address and count, except for WORD and FIND. Both words have
\ been in use for a long time, and should be considered
\ 'standard'. But I do not think either should be required in the
\ CORE and I think both should be considered obsolescent. WORD
\ already has obsolescent 'features'.
\ eForth uses only the address and count convention.
\ The following definition is provided as a concession, it has an
\ environmental dependency, it does NOT skip 'non-blank' leading
\ delimiters.
\ If you would like to write a corrected version of WORD, please
\ send it to me. It needs to skip leading delimiters and then
\ parse for that same character as a terminating delimiter.
: WORD ( c -- a )
DUP BL = ( blank delimited ? )
IF DROP PARSE-WORD ( skip leading blanks )
ELSE PARSE ( does NOT skip non-blank leading delimiters )
THEN HERE PACK ; ( move and convert string )
( =========================================================== )
\ [?]DO pushes the address of a1 to the
\ Return Stack for [?]LEAVE and [+]LOOP
\
\ v-------------------<<
\ [?]DO a1 ... [?]LEAVE ... [+]LOOP ...
\ >>--------+>----------------^
\
\ v-------------------------------------<<
\ [?]DO a1 ... IF a2 ... UNLOOP EXIT THEN ... [+]LOOP ...
\ >>----------------------^
\ >>--------------------------------------------^
\
\ v-------------------<<
\ [?]DO a1 ... WHILE a2 ... [+]LOOP ... ELSE a4 ... UNLOOP THEN ...
\ >>--------------------------^ >>-----------------^
\ >>-------------------------^
: _DO ( l i -- ) ( R: a -- a l i )
BEGIN SWAP R> CELL+ DUP >R SWAP >R SWAP >R >R ; \ ???
: _?DO ( l i -- ) ( R: a -- a l i )
2DUP = UNTIL 2DROP R> @ >R ; \ ???
: _LOOP ( -- ) ( R: a l i a -- a l i | )
R> R> 1 + R> 2DUP XOR
IF R@ SWAP >R SWAP >R >R DROP EXIT
THEN 2DROP R> DROP >R ;
: _+LOOP ( n -- ) ( R: a l i a -- a l i | )
R> SWAP DUP R@ + SWAP
DUP R> NEGATE R@ + NEGATE UM+ >R DROP ( l i - n - save carry )
INVERT 0< R> + ( overflow ? sign of n and carry )
IF R> R@ SWAP >R SWAP >R >R DROP EXIT
THEN R> 2DROP R> DROP >R ;
: DO ( -- a ) ['] _DO COMPILE, MARK ; IMMEDIATE
: ?DO ( -- a ) ['] _?DO COMPILE, MARK ; IMMEDIATE
: LOOP ( a -- ) ['] _LOOP COMPILE, [COMPILE] THEN ; IMMEDIATE
: +LOOP ( a -- ) ['] _+LOOP COMPILE, [COMPILE] THEN ; IMMEDIATE
: UNLOOP ( -- ) ( R: a l i a -- ) R> R> R> 2DROP R> DROP >R ;
: LEAVE ( -- ) ( R: a l i a -- )
R> DROP R> R> 2DROP R> CELL- @ >R ; \ ???
: ?LEAVE ( f -- ) IF R> DROP LEAVE THEN ;
: I ( -- n ) ( R: a l i a -- a l i ) R> R@ SWAP >R ;
: J ( -- n ) ( R: a l i a l i a -- a l i a l i )
R> R> R> R> R@ SWAP >R SWAP >R SWAP >R SWAP >R ;
( test DO-LOOP ============================================== )
: L1 ( -- ) 9 0 DO I . LOOP ;
: L2 ( -- ) 9 0 ?DO I . LOOP ;
: L3 ( -- ) 9 9 ?DO I . LOOP ;
: L4 ( -- ) 9 0 ?DO I 3 = IF UNLOOP ." UNLOOP " EXIT THEN I . LOOP 99 . ;
: L5 ( -- ) 9 0 ?DO I 3 = IF LEAVE ." LEAVE " THEN I . LOOP 99 . ;
: L6 ( -- ) 9 0 ?DO I 3 = ?LEAVE I . LOOP 99 . ;
: L7 ( -- ) 9 0 ?DO I . 2 +LOOP ;
: L8 ( -- ) 0 9 ?DO I . -2 +LOOP ;
: L9 ( -- ) 9 0 ?DO 4 0 ?DO J . LOOP LOOP ;
( =========================================================== )
\ v--------<<
\ FOR ... NEXT a1 ...
\
\ v---------------------<< >>----------v
\ FOR ... WHILE a1 ... NEXT a2 ... ELSE a3 ... THEN ...
\ >>-------------------------^
\
\ v-----------------<<
\ FOR ... AFT a1 ... THEN ... NEXT a2 ...
\ >>----------^
: _NEXT ( -- ) ( R: u -- u )
R> R> DUP
IF 1 - >R @ >R EXIT \ ???
THEN DROP CELL+ >R ; \ ???
: FOR ( -- a ) ['] >R COMPILE, [COMPILE] BEGIN ; IMMEDIATE
: NEXT ( a -- ) ['] _NEXT COMPILE, RESOLVE ; IMMEDIATE
: AFT ( a -- a a )
DROP [COMPILE] AHEAD [COMPILE] BEGIN SWAP ; IMMEDIATE
( test FOR-NEXT ============================================= )
: N1 ( -- ) 9 FOR R@ . NEXT ;
: N2 ( -- )
9 FOR 5 R@ < WHILE R@ . NEXT ." X" ELSE R> DROP ." Y" THEN ;
: N3 ( -- ) 9 FOR ." X" AFT ." Y" THEN R@ . NEXT ;
( =========================================================== )
( CASE structure )
0 CONSTANT CASE ( -- 0 ) IMMEDIATE
: OF ( -- sys )
['] OVER COMPILE, ['] = COMPILE,
[COMPILE] IF ['] DROP COMPILE, ; IMMEDIATE
: ENDOF ( sys -- sys ) [COMPILE] ELSE ; IMMEDIATE
: ESAC ( 0 i*sys -- ) ( a useful factor )
BEGIN ?DUP WHILE [COMPILE] THEN REPEAT ; IMMEDIATE
: ENDCASE ( 0 i*sys -- ) ['] DROP COMPILE, [COMPILE] ESAC ; IMMEDIATE
( test CASE )
: TT ( n -- )
CR ." TEST BEGIN "
CASE
1 OF ." HI BEE" ENDOF
2 OF ." OH BEZEL" ENDOF
." NO WAY " DUP 0 .R
ENDCASE ." TEST END" ;
( ============================================================ )
( multitask information exchange and synchronization extension )
( modified polled version from Michael B. Montvelishsky )
( ============================================================ )
: CHAN ( 'name' -- ) ( -- a )
CREATE
0 , ( flag )
0 , ( data )
;
: C> ( a -- n ) ( get data from a channel )
BEGIN PAUSE DUP @ ( data ready ? )
UNTIL 0 OVER ! CELL+ @ ( get data, flag free )
;
: >C ( n a -- ) ( put data to a channel )
BEGIN PAUSE DUP @ 0= ( channel free ? )
UNTIL DUP 2! ( flag inuse, put data )
;
( =========================================================== )
( ??? simplify )
( =========================================================== )
: BUFF ( n 'name' -- ) ( -- a ) ( ONLY powers of 2 )
CREATE 0 , ( in and out index )
DUP 1 - , ALLOT ( mask and circular buffer )
;
: B> ( a -- n ) ( get data from the buffer )
>R ( save buffer )
R@ CHAR+ C@ ( out index )
BEGIN DUP R@ C@ = ( buffer empty ? )
WHILE PAUSE ( yes, wait )
REPEAT DUP R@ CELL+ CELL+ + @ ( get data )
SWAP CELL+ R@ CELL+ C@ AND
R> CHAR+ C! ( update out index )
;
: >B ( n a -- ) ( put data to the buffer )
>R ( save buffer )
R@ C@ ( in index )
DUP CELL+ R@ CELL+ C@ AND ( next in index )
BEGIN DUP R@ CHAR+ C@ = ( buffer full ? )
WHILE PAUSE ( yes, wait )
REPEAT R@ C! ( update in index )
R> CELL+ CELL+ + ! ( put data )
;
( =========================================================== )
: []CHAN ( 'name' n -- ) ( n a -- a )
CREATE CELLS 2 * HERE OVER ERASE ALLOT ?STACK
DOES> SWAP CELLS 2 * + ;
: []CELL ( 'name' n -- ) ( n a -- a )
CREATE CELLS HERE OVER ERASE ALLOT ?STACK
DOES> SWAP CELLS + ;
( =========================================================== )
?CSP BASE !
FROM CON