ok
d30670ebf7
DEFER! and DEFER@ are trivially `: DEFER! >BODY ! ;` and `: DEFER@ >BODY @ ;`. COMPARE uses a byte-by-byte loop with early exit. Removed 148 lines of Rust. All 426 tests pass.
249 lines
6.9 KiB
Forth
249 lines
6.9 KiB
Forth
\ WAFER Bootstrap -- Forth definitions replacing Rust host functions.
|
|
\ Loaded at startup after IR primitives are compiled.
|
|
\ Compiled WASM with direct calls outperforms host function dispatch.
|
|
|
|
\ ---------------------------------------------------------------
|
|
\ Phase 1: Pure stack and memory operations
|
|
\ ---------------------------------------------------------------
|
|
|
|
\ 2OVER ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 )
|
|
: 2OVER 3 PICK 3 PICK ;
|
|
|
|
\ 2ROT ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 )
|
|
: 2ROT 2>R 2SWAP 2R> 2SWAP ;
|
|
|
|
\ WITHIN ( n lo hi -- flag ) true if lo <= n < hi (unsigned)
|
|
: WITHIN OVER - >R - R> U< ;
|
|
|
|
\ 2@ ( addr -- x1 x2 ) fetch double-cell, low addr = deeper stack
|
|
: 2@ DUP CELL+ @ SWAP @ ;
|
|
|
|
\ 2! ( x1 x2 addr -- ) store double-cell
|
|
: 2! SWAP OVER ! CELL+ ! ;
|
|
|
|
\ 2R@ stays as host function (needs direct return-stack access)
|
|
|
|
\ FILL ( addr u char -- ) fill u bytes with char
|
|
: FILL ROT ROT 0 ?DO 2DUP I + C! LOOP 2DROP ;
|
|
|
|
\ CMOVE ( src dst u -- ) forward byte copy
|
|
: CMOVE 0 ?DO OVER I + C@ OVER I + C! LOOP 2DROP ;
|
|
|
|
\ CMOVE> ( src dst u -- ) backward byte copy (for overlap)
|
|
: CMOVE>
|
|
DUP 0= IF DROP 2DROP EXIT THEN
|
|
1- >R
|
|
BEGIN R@ 0< INVERT WHILE
|
|
OVER R@ + C@ OVER R@ + C!
|
|
R> 1- >R
|
|
REPEAT
|
|
R> DROP 2DROP ;
|
|
|
|
\ MOVE ( src dst u -- ) smart copy (handles overlap)
|
|
: MOVE
|
|
DUP 0= IF DROP 2DROP EXIT THEN
|
|
>R 2DUP U< IF R> CMOVE> ELSE R> CMOVE THEN ;
|
|
|
|
\ ERASE ( addr u -- ) zero fill
|
|
: ERASE 0 FILL ;
|
|
|
|
\ BLANK ( addr u -- ) space fill
|
|
: BLANK BL FILL ;
|
|
|
|
\ /STRING ( addr u n -- addr+n u-n )
|
|
: /STRING ROT OVER + ROT ROT - ;
|
|
|
|
\ -TRAILING ( addr u -- addr u' ) remove trailing spaces
|
|
: -TRAILING
|
|
BEGIN DUP 0> WHILE
|
|
2DUP + 1- C@ BL <> IF EXIT THEN
|
|
1-
|
|
REPEAT ;
|
|
|
|
\ ---------------------------------------------------------------
|
|
\ Phase 2: Double-cell arithmetic
|
|
\ ---------------------------------------------------------------
|
|
|
|
\ D+ ( d1 d2 -- d3 ) double-cell addition with carry
|
|
: D+ >R SWAP >R DUP >R + DUP R> U< IF R> R> + 1+ ELSE R> R> + THEN ;
|
|
|
|
\ DNEGATE ( d -- -d ) double-cell negate (two's complement)
|
|
: DNEGATE INVERT SWAP INVERT SWAP 1 0 D+ ;
|
|
|
|
\ D- ( d1 d2 -- d3 ) double-cell subtraction
|
|
: D- DNEGATE D+ ;
|
|
|
|
\ DABS ( d -- |d| ) double-cell absolute value
|
|
: DABS DUP 0< IF DNEGATE THEN ;
|
|
|
|
\ D0= ( d -- flag ) true if d is zero
|
|
: D0= OR 0= ;
|
|
|
|
\ D0< ( d -- flag ) true if d is negative
|
|
: D0< NIP 0< ;
|
|
|
|
\ D= ( d1 d2 -- flag ) true if d1 = d2
|
|
: D= D- D0= ;
|
|
|
|
\ D< ( d1 d2 -- flag ) true if d1 < d2 (signed)
|
|
: D< D- D0< ;
|
|
|
|
\ D2* ( d -- d*2 ) double-cell shift left
|
|
: D2* 2DUP D+ ;
|
|
|
|
\ D2/ ( d -- d/2 ) double-cell arithmetic shift right
|
|
: D2/ DUP 1 AND 31 LSHIFT >R 2/ SWAP 1 RSHIFT R> OR SWAP ;
|
|
|
|
\ DMAX ( d1 d2 -- d-max ) double-cell maximum
|
|
: DMAX 2OVER 2OVER D< IF 2SWAP THEN 2DROP ;
|
|
|
|
\ DMIN ( d1 d2 -- d-min ) double-cell minimum
|
|
: DMIN 2OVER 2OVER D< INVERT IF 2SWAP THEN 2DROP ;
|
|
|
|
\ M+ ( d n -- d+n ) add single to double
|
|
: M+ S>D D+ ;
|
|
|
|
\ DU< ( ud1 ud2 -- flag ) unsigned double-cell less-than
|
|
: DU< ROT 2DUP = IF 2DROP U< ELSE U< NIP NIP THEN ;
|
|
|
|
\ ---------------------------------------------------------------
|
|
\ Phase 3: Mixed arithmetic (built on M* and UM/MOD host primitives)
|
|
\ ---------------------------------------------------------------
|
|
|
|
\ SM/REM ( d n -- rem quot ) symmetric (truncated) division
|
|
\ Quotient sign: negative if dividend and divisor signs differ.
|
|
\ Remainder sign: same as dividend.
|
|
: SM/REM
|
|
OVER >R
|
|
2DUP XOR >R
|
|
ABS >R DABS R>
|
|
UM/MOD
|
|
R> 0< IF NEGATE THEN
|
|
SWAP R> 0< IF NEGATE THEN
|
|
SWAP ;
|
|
|
|
\ FM/MOD ( d n -- rem quot ) floored division
|
|
: FM/MOD
|
|
DUP >R
|
|
SM/REM
|
|
OVER 0<> OVER 0< AND IF
|
|
1- SWAP R> + SWAP
|
|
ELSE
|
|
R> DROP
|
|
THEN ;
|
|
|
|
\ */ ( n1 n2 n3 -- n4 ) n1*n2/n3 with double intermediate
|
|
: */ >R M* R> FM/MOD SWAP DROP ;
|
|
|
|
\ */MOD ( n1 n2 n3 -- rem quot )
|
|
: */MOD >R M* R> FM/MOD ;
|
|
|
|
\ ---------------------------------------------------------------
|
|
\ Phase 4: HERE and ALIGNED
|
|
\ ---------------------------------------------------------------
|
|
|
|
\ HERE reads from SYSVAR_HERE (offset 12 in WASM memory).
|
|
\ The Rust side syncs user_here to memory[12] before each evaluate call
|
|
\ and whenever host ALLOT/comma modifies it.
|
|
: HERE 12 @ ;
|
|
|
|
\ ALIGNED is already an IR primitive in the compiler.
|
|
|
|
\ ---------------------------------------------------------------
|
|
\ Phase 5: I/O, pictured numeric output, formatted output
|
|
\ ---------------------------------------------------------------
|
|
|
|
\ TYPE ( c-addr u -- ) output u characters
|
|
: TYPE 0 ?DO DUP C@ EMIT 1+ LOOP DROP ;
|
|
|
|
\ SPACES ( n -- ) output n spaces
|
|
: SPACES 0 ?DO SPACE LOOP ;
|
|
|
|
\ Pictured numeric output constants
|
|
\ PAD_BASE = 0x0440, PAD_SIZE = 256, SYSVAR_HLD = 28
|
|
|
|
\ <# ( -- ) begin pictured numeric output
|
|
: <# 1344 28 ! ;
|
|
|
|
\ HOLD ( char -- ) add character to pictured output
|
|
: HOLD 28 @ 1- DUP 28 ! C! ;
|
|
|
|
\ HOLDS ( addr u -- ) add string to pictured output
|
|
: HOLDS
|
|
BEGIN DUP 0> WHILE
|
|
1- 2DUP + C@ HOLD
|
|
REPEAT 2DROP ;
|
|
|
|
\ SIGN ( n -- ) if negative, add '-'
|
|
: SIGN 0< IF 45 HOLD THEN ;
|
|
|
|
\ # ( ud -- ud2 ) extract one digit from ud, convert to char, HOLD it.
|
|
\ Double-cell division by BASE using two UM/MODs:
|
|
\ First UM/MOD divides (0 ud-hi) by BASE -> rem1, quot-hi
|
|
\ Second UM/MOD divides (rem1 ud-lo) by BASE -> digit, quot-lo
|
|
: #
|
|
BASE @
|
|
>R 0 R@ UM/MOD R> SWAP >R
|
|
UM/MOD
|
|
SWAP DUP 9 > IF 7 + THEN 48 + HOLD
|
|
R> ;
|
|
|
|
\ #S ( ud -- 0 0 ) convert all digits
|
|
: #S BEGIN # 2DUP OR 0= UNTIL ;
|
|
|
|
\ #> ( ud -- c-addr u ) end pictured output, return string
|
|
: #> 2DROP 28 @ 1344 OVER - ;
|
|
|
|
\ Formatted output built on pictured numeric output
|
|
|
|
\ . ( n -- ) print signed number and space
|
|
: . DUP ABS 0 <# #S ROT SIGN #> TYPE SPACE ;
|
|
|
|
\ U. ( u -- ) print unsigned number and space
|
|
: U. 0 <# #S #> TYPE SPACE ;
|
|
|
|
\ .R ( n width -- ) print right-justified signed number
|
|
: .R >R DUP ABS 0 <# #S ROT SIGN #> R> OVER - SPACES TYPE ;
|
|
|
|
\ U.R ( u width -- ) print right-justified unsigned number
|
|
: U.R >R 0 <# #S #> R> OVER - SPACES TYPE ;
|
|
|
|
\ D. ( d -- ) print signed double number and space
|
|
: D. SWAP OVER DABS <# #S ROT SIGN #> TYPE SPACE ;
|
|
|
|
\ D.R ( d width -- ) print right-justified signed double
|
|
: D.R >R SWAP OVER DABS <# #S ROT SIGN #> R> OVER - SPACES TYPE ;
|
|
|
|
\ ---------------------------------------------------------------
|
|
\ Phase 6: DEFER support
|
|
\ ---------------------------------------------------------------
|
|
|
|
\ DEFER! ( xt xt-deferred -- ) store xt into a deferred word
|
|
: DEFER! >BODY ! ;
|
|
|
|
\ DEFER@ ( xt-deferred -- xt ) retrieve xt from a deferred word
|
|
: DEFER@ >BODY @ ;
|
|
|
|
\ ---------------------------------------------------------------
|
|
\ String operations
|
|
\ ---------------------------------------------------------------
|
|
|
|
\ COMPARE ( addr1 u1 addr2 u2 -- n ) compare two strings lexicographically
|
|
: COMPARE
|
|
ROT 2DUP - >R
|
|
MIN 0 ?DO
|
|
OVER I + C@
|
|
OVER I + C@
|
|
2DUP <> IF
|
|
< IF 2DROP R> DROP -1 UNLOOP EXIT
|
|
ELSE 2DROP R> DROP 1 UNLOOP EXIT
|
|
THEN
|
|
THEN 2DROP
|
|
LOOP
|
|
2DROP R>
|
|
DUP 0< IF DROP -1 EXIT THEN
|
|
0> IF 1 EXIT THEN
|
|
0 ;
|
|
|
|
\ SEARCH stays as a host function (complex multi-line control flow).
|