.mem main 1 1 shared .import main "emu" "mem" ;; Peripheral registers .def TXBUF 000h .def RXBUF 080h .def TXHEAD 100h .def TXTAIL 104h .def RXHEAD 108h .def RXTAIL 10Ch .def DICT_START 0200h .def RSP_INIT 10000h .def SP_INIT F000h ;; Forth registers .global rsp i32 .global sp i32 .global ip i32 .global cfa i32 .global fn i32 ;; Trampoline control flag .global run i32 0 ;; Some little helper functions .func push .param x i32 global.get sp i32.const 4 i32.sub global.set sp global.get sp local.get x i32.store 2 0 .func pop .result i32 global.get sp i32.load 2 0 global.get sp i32.const 4 i32.add global.set sp .func pushrsp .param x i32 global.get rsp i32.const 4 i32.sub global.set rsp global.get rsp local.get x i32.store 2 0 .func poprsp .result i32 global.get rsp i32.load 2 0 global.get rsp i32.const 4 i32.add global.set rsp ;; The rather bizzare nature of WebAssembly means that we can't ;; actually jump to code, which makes this NEXT implemenation somewhat ;; strange. Instead of doing the jump here, we store the function ;; index (seemingly the closest you can get to a code address in ;; WebAssembly) in the fn global and return. It's then down to the ;; trampoline loop to actually run the codeword. .func next global.get ip global.get ip i32.const 4 i32.add global.set ip i32.load 2 0 global.set cfa global.get cfa i32.load 2 0 global.set fn ;; The codewords function table must contain every codeword we want to ;; be able to run, as it's indices into this table that can be ran ;; with call_indirect in the $trampoline loop. .type codeword result .table codewords 100 ;; Our special inner interpreters <3 .func docol .elem codewords docol DOCOL_CODEWORD global.get ip call pushrsp global.get cfa i32.const 4 i32.add global.set ip call next .func doval .elem codewords doval DOVAL_CODEWORD global.get cfa i32.const 4 i32.add i32.load 2 0 call push call next .func dovar .elem codewords dovar DOVAR_CODEWORD global.get cfa i32.const 4 i32.add call push call next ;; Codewords! ;; ;; Most of these are implemented here (as opposed to in the forth ;; itself) for performance rather than necessity. ;; Stack manipulation .func dup .elem codewords dup DUP_CODEWORD global.get sp i32.load 2 0 call push call next .func drop .elem codewords drop DROP_CODEWORD global.get sp i32.const 4 i32.add global.set sp call next .func swap .elem codewords swap SWAP_CODEWORD global.get sp i32.const 4 i32.add global.get sp i32.load 2 0 global.get sp global.get sp i32.const 4 i32.add i32.load 2 0 i32.store 2 0 i32.store 2 0 call next .func rot .elem codewords rot ROT_CODEWORD global.get sp i32.const 4 i32.add global.get sp i32.load 2 0 global.get sp i32.const 8 i32.add global.get sp i32.const 4 i32.add i32.load 2 0 global.get sp global.get sp i32.const 8 i32.add i32.load 2 0 i32.store 2 0 i32.store 2 0 i32.store 2 0 call next .func nrot .elem codewords nrot NROT_CODEWORD global.get sp i32.const 8 i32.add global.get sp i32.load 2 0 global.get sp global.get sp i32.const 4 i32.add i32.load 2 0 global.get sp i32.const 4 i32.add global.get sp i32.const 8 i32.add i32.load 2 0 i32.store 2 0 i32.store 2 0 i32.store 2 0 call next .func over .elem codewords over OVER_CODEWORD global.get sp i32.const 4 i32.add i32.load 2 0 call push call next .func twodup .elem codewords twodup TWODUP_CODEWORD global.get sp i32.load 2 0 global.get sp i32.const 4 i32.add i32.load 2 0 call push call push call next .func twodrop .elem codewords twodrop TWODROP_CODEWORD global.get sp i32.const 8 i32.add global.set sp call next .func twoswap .elem codewords twoswap TWOSWAP_CODEWORD global.get sp i32.const 8 i32.add global.get sp i32.load 2 0 global.get sp i32.const 12 i32.add global.get sp i32.const 4 i32.add i32.load 2 0 global.get sp global.get sp i32.const 8 i32.add i32.load 2 0 global.get sp i32.const 4 i32.add global.get sp i32.const 12 i32.add i32.load 2 0 i32.store 2 0 i32.store 2 0 i32.store 2 0 i32.store 2 0 call next ;; Arithmetic and logic .func inc .elem codewords inc INC_CODEWORD global.get sp global.get sp i32.load 2 0 i32.const 1 i32.add i32.store 2 0 call next .func dec .elem codewords dec DEC_CODEWORD global.get sp global.get sp i32.load 2 0 i32.const 1 i32.sub i32.store 2 0 call next .func inc4 .elem codewords inc4 INC4_CODEWORD global.get sp global.get sp i32.load 2 0 i32.const 4 i32.add i32.store 2 0 call next .func dec4 .elem codewords dec4 DEC4_CODEWORD global.get sp global.get sp i32.load 2 0 i32.const 4 i32.sub i32.store 2 0 call next .func add .elem codewords add ADD_CODEWORD call pop call pop i32.add call push call next .func sub .elem codewords sub SUB_CODEWORD .local tmp i32 call pop local.set tmp call pop local.get tmp i32.sub call push call next .func mul .elem codewords mul MUL_CODEWORD call pop call pop i32.mul call push call next .func div .elem codewords div DIV_CODEWORD .local tmp i32 call pop local.set tmp call pop local.get tmp i32.div_s call push call next .func mod .elem codewords mod MOD_CODEWORD .local tmp i32 call pop local.set tmp call pop local.get tmp i32.rem_s call push call next .func eq .elem codewords eq EQ_CODEWORD call pop call pop i32.eq i32.const 0 i32.sub call push call next .func neq .elem codewords neq NEQ_CODEWORD call pop call pop i32.ne i32.const 0 i32.sub call push call next .func lt .elem codewords lt LT_CODEWORD .local tmp i32 call pop local.set tmp call pop local.get tmp i32.lt_s i32.const 0 i32.sub call push call next .func gt .elem codewords gt GT_CODEWORD .local tmp i32 call pop local.set tmp call pop local.get tmp i32.gt_s i32.const 0 i32.sub call push call next .func lte .elem codewords lte LTE_CODEWORD .local tmp i32 call pop local.set tmp call pop local.get tmp i32.le_s i32.const 0 i32.sub call push call next .func gte .elem codewords gte GTE_CODEWORD .local tmp i32 call pop local.set tmp call pop local.get tmp i32.ge_s i32.const 0 i32.sub call push call next .func zeq .elem codewords zeq ZEQ_CODEWORD call pop i32.eqz i32.const 0 i32.sub call push call next .func zneq .elem codewords zneq ZNEQ_CODEWORD call pop i32.const 0 i32.ne i32.const 0 i32.sub call push call next .func zlt .elem codewords zlt ZLT_CODEWORD call pop i32.const 0 i32.lt_s i32.const 0 i32.sub call push call next .func zgt .elem codewords zgt ZGT_CODEWORD call pop i32.const 0 i32.gt_s i32.const 0 i32.sub call push call next .func zlte .elem codewords zlte ZLTE_CODEWORD call pop i32.const 0 i32.le_s i32.const 0 i32.sub call push call next .func zgte .elem codewords zgte ZGTE_CODEWORD call pop i32.const 0 i32.ge_s i32.const 0 i32.sub call push call next .func and .elem codewords and AND_CODEWORD call pop call pop i32.and call push call next .func or .elem codewords or OR_CODEWORD call pop call pop i32.or call push call next .func xor .elem codewords xor XOR_CODEWORD call pop call pop i32.xor call push call next .func invert .elem codewords invert INVERT_CODEWORD call pop i32.const FFFFFFFFh i32.xor call push call next ;; Memory .func store .elem codewords store STORE_CODEWORD call pop call pop i32.store 2 0 call next .func fetch .elem codewords fetch FETCH_CODEWORD call pop i32.load 2 0 call push call next .func addstore .elem codewords addstore ADDSTORE_CODEWORD .local tmp i32 call pop local.tee tmp local.get tmp i32.load 2 0 call pop i32.add i32.store 2 0 call next .func substore .elem codewords substore SUBSTORE_CODEWORD .local tmp i32 call pop local.tee tmp local.get tmp i32.load 2 0 call pop i32.sub i32.store 2 0 call next .func storebyte .elem codewords storebyte STOREBYTE_CODEWORD call pop call pop i32.store8 0 0 call next .func fetchbyte .elem codewords fetchbyte FETCHBYTE_CODEWORD call pop i32.load8_u 0 0 call push call next .func atomic-store .elem codewords atomic-store ATOMIC_STORE_CODEWORD call pop call pop i32.atomic.store 2 0 call next .func atomic-fetch .elem codewords atomic-fetch ATOMIC_FETCH_CODEWORD call pop i32.atomic.load 2 0 call push call next .func atomic-storebyte .elem codewords atomic-storebyte ATOMIC_STOREBYTE_CODEWORD call pop call pop i32.atomic.store8 0 0 call next .func atomic-fetchbyte .elem codewords atomic-fetchbyte ATOMIC_FETCHBYTE_CODEWORD call pop i32.atomic.load8_u 0 0 call push call next .func copy .elem codewords copy COPY_CODEWORD .local src i32 dst i32 n i32 call pop local.set dst call pop local.set src call pop local.set n block done loop iter local.get n i32.eqz br_if done local.get dst local.get src i32.load8_u 0 0 i32.store8 0 0 local.get dst i32.const 1 i32.add local.set dst local.get src i32.const 1 i32.add local.set src local.get n i32.const 1 i32.sub local.set n br iter end end call next .func wait .elem codewords wait WAIT_CODEWORD call pop i32.const 0 i64.const -1 memory.atomic.wait32 2 0 call push call next ;; Core utility words .func exit .elem codewords exit EXIT_CODEWORD call poprsp global.set ip call next .func lit .elem codewords lit LIT_CODEWORD global.get ip i32.load 2 0 call push global.get ip i32.const 4 i32.add global.set ip call next .func execute .elem codewords execute EXECUTE_CODEWORD call pop global.set cfa global.get cfa i32.load 2 0 global.set fn .func halt .elem codewords halt HALT_CODEWORD i32.const 0 global.set run ;; Return and parameter stack primitives .func tor .elem codewords tor TOR_CODEWORD call pop call pushrsp call next .func fromr .elem codewords fromr FROMR_CODEWORD call poprsp call push call next .func rspfetch .elem codewords rspfetch RSPFETCH_CODEWORD global.get rsp call push call next .func rspstore .elem codewords rspstore RSPSTORE_CODEWORD call pop global.set rsp call next .func rdrop .elem codewords rdrop RDROP_CODEWORD global.get rsp i32.const 4 i32.add global.set rsp call next .func spfetch .elem codewords spfetch SPFETCH_CODEWORD global.get sp call push call next .func spstore .elem codewords spstore SPSTORE_CODEWORD call pop global.set sp call next ;; Serial I/O .func key .elem codewords key KEY_CODEWORD .local head i32 i32.const RXHEAD i32.atomic.load8_u 0 0 local.set head ;; Wait for RXBUF to be non-empty loop wait local.get head i32.const RXTAIL i32.atomic.load8_u 0 0 i32.eq if i32.const RXTAIL local.get head i64.const -1 memory.atomic.wait32 2 0 br wait end end ;; Read byte at head position i32.const RXBUF local.get head i32.add i32.load8_u 0 0 call push ;; Advance RXHEAD i32.const RXHEAD local.get head i32.const 1 i32.add i32.const 7Fh i32.and i32.atomic.store8 0 0 call next .func emit .elem codewords emit EMIT_CODEWORD .local tail i32 n i32 ;; Wait for TXBUF to be non-full loop wait i32.const TXTAIL i32.atomic.load8_u 0 0 local.tee tail i32.const 1 i32.add i32.const 7Fh i32.and local.tee n i32.const TXHEAD i32.atomic.load8_u 0 0 i32.eq br_if wait end ;; Write byte at tail position i32.const TXBUF local.get tail i32.add call pop i32.store8 0 0 ;; Advance TXTAIL i32.const TXTAIL local.get n i32.atomic.store8 0 0 call next ;; Branching .func branch .elem codewords branch BRANCH_CODEWORD global.get ip i32.load 2 0 global.get ip i32.add global.set ip call next .func zbranch .elem codewords zbranch ZBRANCH_CODEWORD call pop if _ i32 i32.const 4 else global.get ip i32.load 2 0 end global.get ip i32.add global.set ip call next ;; Dictionary time :D .at main DICT_START .def PREV 0 _DUP: .word PREV .byte 3 .utf8 "DUP" .align DUP: .word DUP_CODEWORD .def PREV _DUP _DROP: .word PREV .byte 4 .utf8 "DROP" .align DROP: .word DROP_CODEWORD .def PREV _DROP _SWAP: .word PREV .byte 4 .utf8 "SWAP" .align SWAP: .word SWAP_CODEWORD .def PREV _SWAP _ROT: .word PREV .byte 3 .utf8 "ROT" .align ROT: .word ROT_CODEWORD .def PREV _ROT _NROT: .word PREV .byte 4 .utf8 "-ROT" .align NROT: .word NROT_CODEWORD .def PREV _NROT _OVER: .word PREV .byte 4 .utf8 "OVER" .align OVER: .word OVER_CODEWORD .def PREV _OVER _TWODUP: .word PREV .byte 4 .utf8 "2DUP" .align TWODUP: .word TWODUP_CODEWORD .def PREV _TWODUP _TWODROP: .word PREV .byte 5 .utf8 "2DROP" .align TWODROP: .word TWODROP_CODEWORD .def PREV _TWODROP _TWOSWAP: .word PREV .byte 5 .utf8 "2SWAP" .align TWOSWAP: .word TWOSWAP_CODEWORD .def PREV _TWOSWAP _INC: .word PREV .byte 2 .utf8 "1+" .align INC: .word INC_CODEWORD .def PREV _INC _DEC: .word PREV .byte 2 .utf8 "1-" .align DEC: .word DEC_CODEWORD .def PREV _DEC _INC4: .word PREV .byte 2 .utf8 "4+" .align INC4: .word INC4_CODEWORD .def PREV _INC4 _DEC4: .word PREV .byte 2 .utf8 "4-" .align DEC4: .word DEC4_CODEWORD .def PREV _DEC4 _ADD: .word PREV .byte 1 .utf8 "+" .align ADD: .word ADD_CODEWORD .def PREV _ADD _SUB: .word PREV .byte 1 .utf8 "-" .align SUB: .word SUB_CODEWORD .def PREV _SUB _MUL: .word PREV .byte 1 .utf8 "*" .align MUL: .word MUL_CODEWORD .def PREV _MUL _DIV: .word PREV .byte 1 .utf8 "/" .align DIV: .word DIV_CODEWORD .def PREV _DIV _MOD: .word PREV .byte 3 .utf8 "MOD" .align MOD: .word MOD_CODEWORD .def PREV _MOD _EQ: .word PREV .byte 1 .utf8 "=" .align EQ: .word EQ_CODEWORD .def PREV _EQ _NEQ: .word PREV .byte 2 .utf8 "<>" .align NEQ: .word NEQ_CODEWORD .def PREV _NEQ _LT: .word PREV .byte 1 .utf8 "<" .align LT: .word LT_CODEWORD .def PREV _LT _GT: .word PREV .byte 1 .utf8 ">" .align GT: .word GT_CODEWORD .def PREV _GT _LTE: .word PREV .byte 2 .utf8 "<=" .align LTE: .word LTE_CODEWORD .def PREV _LTE _GTE: .word PREV .byte 2 .utf8 ">=" .align GTE: .word GTE_CODEWORD .def PREV _GTE _ZEQ: .word PREV .byte 2 .utf8 "0=" .align ZEQ: .word ZEQ_CODEWORD .def PREV _ZEQ _ZNEQ: .word PREV .byte 3 .utf8 "0<>" .align ZNEQ: .word ZNEQ_CODEWORD .def PREV _ZNEQ _ZLT: .word PREV .byte 2 .utf8 "0<" .align ZLT: .word ZLT_CODEWORD .def PREV _ZLT _ZGT: .word PREV .byte 2 .utf8 "0>" .align ZGT: .word ZGT_CODEWORD .def PREV _ZGT _ZLTE: .word PREV .byte 3 .utf8 "0<=" .align ZLTE: .word ZLTE_CODEWORD .def PREV _ZLTE _ZGTE: .word PREV .byte 3 .utf8 "0>=" .align ZGTE: .word ZGTE_CODEWORD .def PREV _ZGTE _AND: .word PREV .byte 3 .utf8 "AND" .align AND: .word AND_CODEWORD .def PREV _AND _OR: .word PREV .byte 2 .utf8 "OR" .align OR: .word OR_CODEWORD .def PREV _OR _XOR: .word PREV .byte 3 .utf8 "XOR" .align XOR: .word XOR_CODEWORD .def PREV _XOR _INVERT: .word PREV .byte 6 .utf8 "INVERT" .align INVERT: .word INVERT_CODEWORD .def PREV _INVERT _STORE: .word PREV .byte 1 .utf8 "!" .align STORE: .word STORE_CODEWORD .def PREV _STORE _FETCH: .word PREV .byte 1 .utf8 "@" .align FETCH: .word FETCH_CODEWORD .def PREV _FETCH _ADDSTORE: .word PREV .byte 2 .utf8 "+!" .align ADDSTORE: .word ADDSTORE_CODEWORD .def PREV _ADDSTORE _SUBSTORE: .word PREV .byte 2 .utf8 "-!" .align SUBSTORE: .word SUBSTORE_CODEWORD .def PREV _SUBSTORE _STOREBYTE: .word PREV .byte 2 .utf8 "C!" .align STOREBYTE: .word STOREBYTE_CODEWORD .def PREV _STOREBYTE _FETCHBYTE: .word PREV .byte 2 .utf8 "C@" .align FETCHBYTE: .word FETCHBYTE_CODEWORD .def PREV _FETCHBYTE _ATOMIC_STORE: .word PREV .byte 2 .utf8 "A!" .align ATOMIC_STORE: .word ATOMIC_STORE_CODEWORD .def PREV _ATOMIC_STORE _ATOMIC_FETCH: .word PREV .byte 2 .utf8 "A@" .align ATOMIC_FETCH: .word ATOMIC_FETCH_CODEWORD .def PREV _ATOMIC_FETCH _ATOMIC_STOREBYTE: .word PREV .byte 3 .utf8 "AC!" .align ATOMIC_STOREBYTE: .word ATOMIC_STOREBYTE_CODEWORD .def PREV _ATOMIC_STOREBYTE _ATOMIC_FETCHBYTE: .word PREV .byte 3 .utf8 "AC@" .align ATOMIC_FETCHBYTE: .word ATOMIC_FETCHBYTE_CODEWORD .def PREV _ATOMIC_FETCHBYTE _COPY: .word PREV .byte 4 .utf8 "COPY" .align COPY: .word COPY_CODEWORD .def PREV _COPY _WAIT: .word PREV .byte 4 .utf8 "WAIT" .align WAIT: .word WAIT_CODEWORD .def PREV _WAIT _EXIT: .word PREV .byte 4 .utf8 "EXIT" .align EXIT: .word EXIT_CODEWORD .def PREV _EXIT _LIT: .word PREV .byte 3 .utf8 "LIT" .align LIT: .word LIT_CODEWORD .def PREV _LIT _EXECUTE: .word PREV .byte 7 .utf8 "EXECUTE" .align EXECUTE: .word EXECUTE_CODEWORD .def PREV _EXECUTE _HALT: .word PREV .byte 4 .utf8 "HALT" .align HALT: .word HALT_CODEWORD .def PREV _HALT _TOR: .word PREV .byte 2 .utf8 ">R" .align TOR: .word TOR_CODEWORD .def PREV _TOR _FROMR: .word PREV .byte 2 .utf8 "R>" .align FROMR: .word FROMR_CODEWORD .def PREV _FROMR _RSPFETCH: .word PREV .byte 4 .utf8 "RSP@" .align RSPFETCH: .word RSPFETCH_CODEWORD .def PREV _RSPFETCH _RSPSTORE: .word PREV .byte 4 .utf8 "RSP!" .align RSPSTORE: .word RSPSTORE_CODEWORD .def PREV _RSPSTORE _RDROP: .word PREV .byte 5 .utf8 "RDROP" .align RDROP: .word RDROP_CODEWORD .def PREV _RDROP _SPFETCH: .word PREV .byte 3 .utf8 "SP@" .align SPFETCH: .word SPFETCH_CODEWORD .def PREV _SPFETCH _SPSTORE: .word PREV .byte 3 .utf8 "SP!" .align SPSTORE: .word SPSTORE_CODEWORD .def PREV _SPSTORE _KEY: .word PREV .byte 3 .utf8 "KEY" .align KEY: .word KEY_CODEWORD .def PREV _KEY _EMIT: .word PREV .byte 4 .utf8 "EMIT" .align EMIT: .word EMIT_CODEWORD .def PREV _EMIT _BRANCH: .word PREV .byte 6 .utf8 "BRANCH" .align BRANCH: .word BRANCH_CODEWORD .def PREV _BRANCH _ZBRANCH: .word PREV .byte 7 .utf8 "0BRANCH" .align ZBRANCH: .word ZBRANCH_CODEWORD .def PREV _ZBRANCH ;; Built-in values and variables _DOCOL: .word PREV .byte 5 .utf8 "DOCOL" .align DOCOL: .word DOVAL_CODEWORD .word DOCOL_CODEWORD .def PREV _DOCOL _DOVAL: .word PREV .byte 5 .utf8 "DOVAL" .align DOVAL: .word DOVAL_CODEWORD .word DOVAL_CODEWORD .def PREV _DOVAL _DOVAR: .word PREV .byte 5 .utf8 "DOVAR" .align DOVAR: .word DOVAL_CODEWORD .word DOVAR_CODEWORD .def PREV _DOVAR _R0: .word PREV .byte 2 .utf8 "R0" .align R0: .word DOVAL_CODEWORD .word RSP_INIT .def PREV _R0 _S0: .word PREV .byte 2 .utf8 "S0" .align S0: .word DOVAL_CODEWORD .word SP_INIT .def PREV _S0 _FALSE: .word PREV .byte 5 .utf8 "FALSE" .align FALSE: .word DOVAL_CODEWORD .word 0 .def PREV _FALSE _TRUE: .word PREV .byte 4 .utf8 "TRUE" .align TRUE: .word DOVAL_CODEWORD .word FFFFFFFFh .def PREV _TRUE _STATE: .word PREV .byte 5 .utf8 "STATE" .align STATE: .word DOVAR_CODEWORD .word 0 .def PREV _STATE _BASE: .word PREV .byte 4 .utf8 "BASE" .align BASE: .word DOVAR_CODEWORD .word 10 .def PREV _BASE _HERE: .word PREV .byte 4 .utf8 "HERE" .align HERE: .word DOVAR_CODEWORD .word KERNEL_DEFS_END .def PREV _HERE _LATEST: .word PREV .byte 6 .utf8 "LATEST" .align LATEST: .word DOVAR_CODEWORD .word KERNEL_DEFS_LAST .def PREV _LATEST _WORDBUF: .word PREV .byte 7 .utf8 "WORDBUF" .align WORDBUF: .word DOVAR_CODEWORD .zero 20h .def PREV _WORDBUF _WNFHOOK: .word PREV .byte 7 .utf8 "WNFHOOK" .align WNFHOOK: .word DOVAL_CODEWORD .word WNF_HANDLER .def PREV _WNFHOOK ;; And now, it's time for some colon words! ;; : TUCK DUP -ROT ; _TUCK: .word PREV .byte 4 .utf8 "TUCK" .align TUCK: .word DOCOL_CODEWORD .word DUP NROT .word EXIT .def PREV _TUCK ;; : NSPACE ( byte -- bool ) ;; DUP 9 <> SWAP \ Compare to horizontal tab ;; DUP 10 <> SWAP \ Compare to line-feed ;; DUP 13 <> SWAP \ Compare to carriage return ;; 32 <> \ Compare to space ;; AND AND AND \ And all results together ;; ; _NSPACE: .word PREV .byte 6 .utf8 "NSPACE" .align NSPACE: .word DOCOL_CODEWORD .word DUP LIT 9 NEQ SWAP .word DUP LIT 10 NEQ SWAP .word DUP LIT 13 NEQ SWAP .word LIT 32 NEQ .word AND AND AND .word EXIT .def PREV _NSPACE ;; : WORD ( -- len ) ;; 0 \ Initial length ;; ;; KEY \ Get byte from input ;; TUCK NSPACE 0BRANCH [60] \ Check if whitespace ;; TUCK WORDBUF + C! \ Append byte to WORDBUF ;; 1+ \ Increment length ;; DUP 32 >= 0BRANCH [8] EXIT \ Exit if at max length ;; BRANCH [-72] \ Loop back to KEY ;; ;; \ Byte is whitespace ;; SWAP DROP ;; DUP 0<> 0BRANCH [-96] \ Loop back to KEY if zero length ;; ; _WORD: .word PREV .byte 4 .utf8 "WORD" .align WORD: .word DOCOL_CODEWORD .word LIT 0 .word KEY .word TUCK NSPACE ZBRANCH 60 .word TUCK WORDBUF ADD STOREBYTE .word INC .word DUP LIT 32 GTE ZBRANCH 8 EXIT .word BRANCH -72 .word SWAP DROP .word DUP ZNEQ ZBRANCH -96 .word EXIT .def PREV _WORD ;; : STRING= ( len str1 str2 -- bool ) ;; 2DUP C@ SWAP C@ \ Load a byte from each address ;; = 0BRANCH [48] \ Check for byte mismatch ;; 1+ -ROT 1+ -ROT 1- \ Increment addresses, decrement length ;; DUP 0BRANCH [32] \ Check for zero remaining bytes ;; -ROT BRANCH [-68] \ Loop ;; ;; 2DROP DROP FALSE EXIT \ Strings not equal ;; 2DROP DROP TRUE \ Strings equal ;; ; _STRINGEQ: .word PREV .byte 7 .utf8 "STRING=" .align STRINGEQ: .word DOCOL_CODEWORD .word TWODUP FETCHBYTE SWAP FETCHBYTE .word EQ ZBRANCH 48 .word INC NROT INC NROT DEC .word DUP ZBRANCH 32 .word NROT BRANCH -68 .word TWODROP DROP FALSE EXIT .word TWODROP DROP TRUE .word EXIT .def PREV _STRINGEQ ;; : FIND-NAME-LEN 4+ C@ 63 AND ; ;; The 3Fh mask we use here includes the hidden flag, so that FIND ;; never matches a hidden entry as its length will appear to be ;; greater than the maximum length returned by WORD. _FIND_NAME_LEN: .word PREV .byte 13 .utf8 "FIND-NAME-LEN" .align FIND_NAME_LEN: .word DOCOL_CODEWORD .word INC4 FETCHBYTE LIT 3Fh AND .word EXIT .def PREV _FIND_NAME_LEN ;; : FIND ( len -- entry ) ;; LATEST @ \ Initial entry ;; ;; TUCK FIND-NAME-LEN \ Get name length ;; OVER = 0BRANCH [52] \ Check for length mismatch ;; OVER 5 + \ Get name address ;; OVER SWAP WORDBUF STRING= \ Check if name matches ;; 0BRANCH [12] ;; DROP EXIT ;; ;; \ Name doesn't match ;; OVER @ 0<> 0BRANCH [20] \ Check for nil link ;; SWAP @ BRANCH [-104] \ Follow link and loop ;; 2DROP FALSE \ Return false ;; ; _FIND: .word PREV .byte 4 .utf8 "FIND" .align FIND: .word DOCOL_CODEWORD .word LATEST FETCH .word TUCK FIND_NAME_LEN .word OVER EQ ZBRANCH 52 .word OVER LIT 5 ADD .word OVER SWAP WORDBUF STRINGEQ .word ZBRANCH 12 .word DROP EXIT .word OVER FETCH ZNEQ ZBRANCH 20 .word SWAP FETCH BRANCH -104 .word TWODROP FALSE .word EXIT .def PREV _FIND ;; : NAME-LEN 4+ C@ 31 AND ; _NAME_LEN: .word PREV .byte 8 .utf8 "NAME-LEN" .align NAME_LEN: .word DOCOL_CODEWORD .word INC4 FETCHBYTE LIT 31 AND .word EXIT .def PREV _NAME_LEN ;; : >CFA ( entry -- cfa ) ;; DUP NAME-LEN \ Get name length ;; 5 + + \ Increment address to end of name ;; DUP 3 AND 0BRANCH [16] \ Check if aligned ;; 1+ BRANCH [-32] \ Increment address, loop to align check ;; ; _TOCFA: .word PREV .byte 4 .utf8 ">CFA" .align TOCFA: .word DOCOL_CODEWORD .word DUP NAME_LEN .word LIT 5 ADD ADD .word DUP LIT 3 AND ZBRANCH 16 .word INC BRANCH -32 .word EXIT .def PREV _TOCFA ;; : DIGIT ( byte -- value ) ;; DUP DUP 48 >= SWAP 57 <= AND \ Test if 0-9 ;; 0BRANCH [24] \ Jump to A-Z test if not ;; 48 - \ Get digit value ;; BRANCH [64] \ Go to range check ;; ;; DUP DUP 65 >= SWAP 90 <= AND \ Test if A-Z ;; 0BRANCH [60] \ Jump to invalid digit if not ;; 55 - \ Get digit value ;; ;; DUP DUP 0>= SWAP BASE @ < AND \ Test if 0 <= value < BASE ;; 0BRANCH [8] \ Jump to invalid digit if not ;; EXIT ;; ;; DROP TRUE \ Return -1 for an invalid digit ;; ; _DIGIT: .word PREV .byte 5 .utf8 "DIGIT" .align DIGIT: .word DOCOL_CODEWORD .word DUP DUP LIT 48 GTE SWAP LIT 57 LTE AND .word ZBRANCH 24 .word LIT 48 SUB .word BRANCH 64 .word DUP DUP LIT 65 GTE SWAP LIT 90 LTE AND .word ZBRANCH 60 .word LIT 55 SUB .word DUP DUP ZGTE SWAP BASE FETCH LT AND .word ZBRANCH 8 .word EXIT .word DROP TRUE .word EXIT .def PREV _DIGIT ;; : NEGATE INVERT 1+ ; _NEGATE: .word PREV .byte 6 .utf8 "NEGATE" .align NEGATE: .word DOCOL_CODEWORD .word INVERT INC .word EXIT .def PREV _NEGATE ;; : NUMBER? ( len -- value TRUE | FALSE ) ;; WORDBUF \ Initial address ;; ;; DUP C@ 45 = 0BRANCH [60] \ Check for minus sign ;; 1+ \ Increment address ;; SWAP 1- \ Decrement length ;; DUP 0BRANCH [24] \ Check if any characters remain ;; TRUE -ROT \ Set negate flag true ;; SWAP BRANCH [24] \ Jump to setting initial value ;; ;; \ No characters after minus, exit with failure ;; 2DROP FALSE EXIT ;; ;; \ No leading minus, set negate flag false ;; FALSE -ROT ;; ;; \ Set initial value ;; 0 ;; ;; \ Main loop ;; OVER C@ DIGIT \ Get byte's digit value ;; DUP 0>= 0BRANCH [68] \ Check if digit valid ;; ;; SWAP BASE @ * + \ Incorporate digit ;; SWAP 1+ \ Increment address ;; ROT 1- \ Decrement length ;; DUP 0BRANCH [40] \ Go to end if length zero ;; -ROT SWAP BRANCH [-88] \ Loop if characters remain ;; ;; \ Invalid digit ;; 2DROP 2DROP DROP FALSE EXIT \ Exit with failure ;; ;; \ Reached end of word ;; 2DROP \ Discard pointer and length ;; SWAP 0BRANCH [8] NEGATE \ Negate if -ve flag set ;; TRUE \ Exit with success ;; ; _NUMBER: .word PREV .byte 7 .utf8 "NUMBER?" .align NUMBER: .word DOCOL_CODEWORD .word WORDBUF .word DUP FETCHBYTE LIT 45 EQ ZBRANCH 60 .word INC .word SWAP DEC .word DUP ZBRANCH 24 .word TRUE NROT .word SWAP BRANCH 24 .word TWODROP FALSE EXIT .word FALSE NROT .word LIT 0 .word OVER FETCHBYTE DIGIT .word DUP ZGTE ZBRANCH 68 .word SWAP BASE FETCH MUL ADD .word SWAP INC .word ROT DEC .word DUP ZBRANCH 40 .word NROT SWAP BRANCH -88 .word TWODROP TWODROP DROP FALSE EXIT .word TWODROP .word SWAP ZBRANCH 8 NEGATE .word TRUE .word EXIT .def PREV _NUMBER ;; : , HERE @ ! 4 HERE +! ; _COMMA: .word PREV .byte 1 .utf8 "," .align COMMA: .word DOCOL_CODEWORD .word HERE FETCH STORE LIT 4 HERE ADDSTORE .word EXIT .def PREV _COMMA ;; : IMMEDIATE? 4+ @ 128 AND 0BRANCH [12] TRUE EXIT FALSE ; _IS_IMMEDIATE: .word PREV .byte 10 .utf8 "IMMEDIATE?" .align IS_IMMEDIATE: .word DOCOL_CODEWORD .word INC4 FETCH LIT 128 AND ZBRANCH 12 TRUE EXIT FALSE .word EXIT .def PREV _IS_IMMEDIATE ;; : INTERPRET ;; WORD \ Read a word ;; DUP FIND \ Look it up ;; DUP 0BRANCH [72] \ Branch to number handling if not found ;; SWAP DROP \ Discard word length ;; ;; \ Handle word ;; DUP IMMEDIATE? \ Check if the word is immediate ;; INVERT 0BRANCH [32] \ Jump straight to executing if so ;; STATE @ 0BRANCH [16] \ Check state ;; >CFA , EXIT \ Compile word ;; >CFA EXECUTE EXIT \ Execute word ;; ;; \ Handle number ;; DROP \ Discard nil entry ;; DUP NUMBER? 0BRANCH [48] \ Convert to number ;; SWAP DROP \ Discard word length ;; STATE @ 0BRANCH [20] \ Check state ;; LIT LIT , , \ If compiling, append LIT and the value ;; EXIT ;; ;; \ Word was not found ;; WNFHOOK EXECUTE ;; ; _INTERPRET: .word PREV .byte 9 .utf8 "INTERPRET" .align INTERPRET: .word DOCOL_CODEWORD .word WORD .word DUP FIND .word DUP ZBRANCH 72 .word SWAP DROP .word DUP IS_IMMEDIATE .word INVERT ZBRANCH 32 .word STATE FETCH ZBRANCH 16 .word TOCFA COMMA EXIT .word TOCFA EXECUTE EXIT .word DROP .word DUP NUMBER ZBRANCH 48 .word SWAP DROP .word STATE FETCH ZBRANCH 20 .word LIT LIT COMMA COMMA .word EXIT .word WNFHOOK EXECUTE .word EXIT .def PREV _INTERPRET ;; : QUIT R0 RSP! INTERPRET BRANCH [-8] ; _QUIT: .word PREV .byte 4 .utf8 "QUIT" .align QUIT: .word DOCOL_CODEWORD .word R0 RSPSTORE .word INTERPRET BRANCH -8 .word EXIT .def PREV _QUIT ;; And now to make myself obsolete as the compiler (finally) ;; : [ 0 STATE ! ; IMMEDIATE _LBRAC: .word PREV .byte 81h .utf8 "[" .align LBRAC: .word DOCOL_CODEWORD .word LIT 0 STATE STORE .word EXIT .def PREV _LBRAC ;; : ] 1 STATE ! ; _RBRAC: .word PREV .byte 1 .utf8 "]" .align RBRAC: .word DOCOL_CODEWORD .word LIT 1 STATE STORE .word EXIT .def PREV _RBRAC ;; : ALIGN ;; DUP 3 AND 0BRANCH [32] ;; 0 OVER C! 1+ BRANCH [-48] ;; ; _ALIGN: .word PREV .byte 5 .utf8 "ALIGN" .align ALIGN: .word DOCOL_CODEWORD .word DUP LIT 3 AND ZBRANCH 32 .word LIT 0 OVER STOREBYTE INC BRANCH -48 .word EXIT .def PREV _ALIGN ;; : HIDDEN 4+ DUP C@ 32 XOR SWAP C! ; _HIDDEN: .word PREV .byte 6 .utf8 "HIDDEN" .align HIDDEN: .word DOCOL_CODEWORD .word INC4 DUP FETCHBYTE LIT 32 XOR SWAP STOREBYTE .word EXIT .def PREV _HIDDEN ;; : IMMEDIATE ;; LATEST @ ;; 4+ DUP C@ 128 XOR SWAP C! ;; ; IMMEDIATE _IMMEDIATE: .word PREV .byte 89h .utf8 "IMMEDIATE" .align IMMEDIATE: .word DOCOL_CODEWORD .word LATEST FETCH .word INC4 DUP FETCHBYTE LIT 128 XOR SWAP STOREBYTE .word EXIT .def PREV _IMMEDIATE ;; : CREATE ;; HERE @ \ Get initial address ;; LATEST @ OVER ! 4+ \ Write link ;; 2DUP C! 1+ \ Write length ;; 2DUP WORDBUF SWAP COPY + \ Write name ;; ALIGN \ Pad to alignment ;; ;; HERE @ LATEST ! \ Update LATEST ;; HERE ! \ Update HERE ;; ; _CREATE: .word PREV .byte 6 .utf8 "CREATE" .align CREATE: .word DOCOL_CODEWORD .word HERE FETCH .word LATEST FETCH OVER STORE INC4 .word TWODUP STOREBYTE INC .word TWODUP WORDBUF SWAP COPY ADD .word ALIGN .word HERE FETCH LATEST STORE .word HERE STORE .word EXIT .def PREV _CREATE ;; : : ;; WORD ;; CREATE ;; DOCOL , ;; LATEST @ HIDDEN ;; ] ;; ; _COLON: .word PREV .byte 1 .utf8 ":" .align COLON: .word DOCOL_CODEWORD .word WORD .word CREATE .word DOCOL COMMA .word LATEST FETCH HIDDEN .word RBRAC .word EXIT .def PREV _COLON ;; : ; ;; LIT EXIT , ;; LATEST @ HIDDEN ;; [ ;; ; IMMEDIATE _SEMICOLON: .word PREV .byte 81h .utf8 ";" .align SEMICOLON: .word DOCOL_CODEWORD .word LIT EXIT COMMA .word LATEST FETCH HIDDEN .word LBRAC .word EXIT .def PREV _SEMICOLON ;; : WNF-HANDLER ;; DROP \ Discard word length ;; 87 EMIT 78 EMIT 70 EMIT 10 EMIT \ Print WNF ;; QUIT \ Reset return stack ;; ; _WNF_HANDLER: .word PREV .byte 11 .utf8 "WNF-HANDLER" .align WNF_HANDLER: .word DOCOL_CODEWORD .word DROP .word LIT 87 EMIT LIT 78 EMIT LIT 70 EMIT LIT 10 EMIT .word QUIT .word EXIT .def PREV _WNF_HANDLER COLD_START: .word QUIT .def KERNEL_DEFS_LAST PREV KERNEL_DEFS_END: ;; The trampoline is a workaround for WebAssembly's lack of indirect ;; jumps and code addresses. Instead of jumping into the next ;; codeword, NEXT sets the fn global to the function index of the next ;; codeword and returns to the trampoline. ;; ;; This way, we can simulate jumping to the code within WebAssembly's ;; restrictions without the WebAssembly call stack growing unbounded ;; as would happen if we used call_indirect inside NEXT. .func trampoline loop iter global.get fn call_indirect codeword codewords global.get run br_if iter end .func reset i32.const RSP_INIT global.set rsp ;; Set the return stack pointer i32.const SP_INIT global.set sp ;; Set the stack pointer i32.const COLD_START global.set ip ;; Set the IP to the cold start call next i32.const 1 global.set run call trampoline .export reset