ok2
b7256e3130
Move memory allocation words to boot.fth: - ALLOT: `: ALLOT HERE + 12 ! ;` - , (comma): `: , HERE ! 1 CELLS ALLOT ;` - C, : `: C, HERE C! 1 ALLOT ;` - ALIGN: `: ALIGN HERE ALIGNED 12 ! ;` - FALIGN, SFALIGN, DFALIGN: float-aligned variants These write directly to WASM memory[SYSVAR_HERE]. The Rust side picks up Forth-side HERE changes via refresh_user_here() which now reads both here_cell (for Rust host functions) and memory[12] (for Forth words), taking the maximum to ensure no allocation is lost. Removed 222 lines of Rust. All 426 tests pass.
300 lines
8.5 KiB
Forth
300 lines
8.5 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.
|
|
|
|
\ ---------------------------------------------------------------
|
|
\ Foundation: stack introspection (needed by 2OVER et al.)
|
|
\ ---------------------------------------------------------------
|
|
|
|
\ DEPTH ( -- n ) number of items on the data stack
|
|
\ DATA_STACK_TOP = 5440, uses arithmetic right shift for / 4
|
|
: DEPTH 5440 SP@ - 2 RSHIFT ;
|
|
|
|
\ PICK ( xn..x0 n -- xn..x0 xn ) copy nth stack item
|
|
: PICK 1+ CELLS SP@ + @ ;
|
|
|
|
\ ---------------------------------------------------------------
|
|
\ 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.
|
|
|
|
\ ALLOT ( n -- ) advance HERE by n bytes
|
|
: ALLOT HERE + 12 ! ;
|
|
|
|
\ , ( x -- ) store cell at HERE, advance by cell
|
|
: , HERE ! 1 CELLS ALLOT ;
|
|
|
|
\ C, ( char -- ) store byte at HERE, advance by 1
|
|
: C, HERE C! 1 ALLOT ;
|
|
|
|
\ ALIGN ( -- ) align HERE to cell boundary
|
|
: ALIGN HERE ALIGNED 12 ! ;
|
|
|
|
\ ---------------------------------------------------------------
|
|
\ 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).
|
|
|
|
\ ---------------------------------------------------------------
|
|
\ Phase 7: More easy replacements
|
|
\ ---------------------------------------------------------------
|
|
|
|
\ SOURCE ( -- c-addr u ) input buffer address and length
|
|
\ INPUT_BUFFER_BASE = 64, SYSVAR_NUM_TIB = 24
|
|
: SOURCE 64 24 @ ;
|
|
|
|
\ FALIGNED ( addr -- addr ) align to 8-byte float boundary
|
|
: FALIGNED 7 + -8 AND ;
|
|
|
|
\ SFALIGNED ( addr -- addr ) align to 4-byte single-float boundary
|
|
: SFALIGNED 3 + -4 AND ;
|
|
|
|
\ DFALIGNED ( addr -- addr ) align to 8-byte double-float boundary
|
|
: DFALIGNED 7 + -8 AND ;
|
|
|
|
\ FALIGN ( -- ) align HERE to 8-byte float boundary
|
|
: FALIGN HERE FALIGNED 12 ! ;
|
|
|
|
\ SFALIGN ( -- ) align HERE to 4-byte single-float boundary
|
|
: SFALIGN ALIGN ;
|
|
|
|
\ DFALIGN ( -- ) align HERE to 8-byte double-float boundary
|
|
: DFALIGN FALIGN ;
|
|
|
|
\ .S keeps its Rust host function (complex stack introspection).
|