cdo/wipforth
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
main
wipforth/wipforth.ws

2107 lines
33 KiB
Plaintext
Raw Permalink Blame History

.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
Reference in New Issue View Git Blame Copy Permalink