ok2
58db238731
New IrOp::SpFetch pushes the current data-stack pointer value, enabling Forth-level stack introspection. This unblocks: - DEPTH: `: DEPTH 5440 SP@ - 2 RSHIFT ;` (DATA_STACK_TOP - sp) / 4 - PICK: `: PICK 1+ CELLS SP@ + @ ;` direct memory read - SOURCE: `: SOURCE 64 24 @ ;` reads INPUT_BUFFER_BASE + SYSVAR_NUM_TIB - FALIGNED, SFALIGNED, DFALIGNED: address alignment (shadowed in boot.fth) DEPTH and PICK are now compiled to native WASM — faster than the previous host-function dispatch through call_indirect + Rust closure + mutex. Removed ~109 lines of Rust. All 426 tests pass.
279 lines
7.9 KiB
Forth
279 lines
7.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.
|
|
|
|
\ ---------------------------------------------------------------
|
|
\ 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.
|
|
|
|
\ ---------------------------------------------------------------
|
|
\ 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 ;
|
|
|
|
\ .S keeps its Rust host function (complex stack introspection).
|