From 6ee4adfea5cb44c9a6f3e7f9bd75814ced10265b Mon Sep 17 00:00:00 2001 From: Camden Dixie O'Brien Date: Wed, 18 Mar 2026 10:36:12 +0000 Subject: [PATCH] Translate kernel to Wasmasm --- wipforth.wat | 2024 ------------------------------------------------ wipforth.ws | 2088 ++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 2088 insertions(+), 2024 deletions(-) delete mode 100644 wipforth.wat create mode 100644 wipforth.ws diff --git a/wipforth.wat b/wipforth.wat deleted file mode 100644 index 5e8d7ce..0000000 --- a/wipforth.wat +++ /dev/null @@ -1,2024 +0,0 @@ -;; Don't panic! WAT's just like assembly, really -- if you're missing -;; macros, labels and jumps. - -(module - (import "emu" "mem" (memory 1 1 shared)) - - ;; Peripheral registers - (global $TXBUF i32 (i32.const 0x0000)) - (global $RXBUF i32 (i32.const 0x0020)) - (global $TXHEAD i32 (i32.const 0x0040)) - (global $TXTAIL i32 (i32.const 0x0044)) - (global $RXHEAD i32 (i32.const 0x0048)) - (global $RXTAIL i32 (i32.const 0x004c)) - - ;; Forth registers - (global $rsp (mut i32) (i32.const 0)) - (global $sp (mut i32) (i32.const 0)) - (global $ip (mut i32) (i32.const 0)) - (global $cfa (mut i32) (i32.const 0)) - (global $fn (mut i32) (i32.const 0)) - - ;; Trampoline control flag - (global $run (mut i32) (i32.const 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) - - (func $pop (result i32) - global.get $sp - i32.load - - 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) - - (func $poprsp (result i32) - global.get $rsp - i32.load - - 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 - global.set $cfa - global.get $cfa - i32.load - global.set $fn) - - ;; Our special inner interpreters <3 - - (func $docol - global.get $ip - call $pushrsp - - global.get $cfa - i32.const 4 - i32.add - global.set $ip - - call $next) - - (func $doval - global.get $cfa - i32.const 4 - i32.add - i32.load - call $push - call $next) - - (func $dovar - 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 - global.get $sp - i32.load - call $push - call $next) - - (func $drop - global.get $sp - i32.const 4 - i32.add - global.set $sp - call $next) - - (func $swap - global.get $sp - i32.const 4 - i32.add - global.get $sp - i32.load - - global.get $sp - global.get $sp - i32.const 4 - i32.add - i32.load - - i32.store - i32.store - - call $next) - - (func $rot - global.get $sp - i32.const 4 - i32.add - global.get $sp - i32.load - - global.get $sp - i32.const 8 - i32.add - global.get $sp - i32.const 4 - i32.add - i32.load - - global.get $sp - global.get $sp - i32.const 8 - i32.add - i32.load - - i32.store - i32.store - i32.store - - call $next) - - (func $nrot - global.get $sp - i32.const 8 - i32.add - global.get $sp - i32.load - - global.get $sp - global.get $sp - i32.const 4 - i32.add - i32.load - - global.get $sp - i32.const 4 - i32.add - global.get $sp - i32.const 8 - i32.add - i32.load - - i32.store - i32.store - i32.store - - call $next) - - (func $over - global.get $sp - i32.const 4 - i32.add - i32.load - call $push - call $next) - - (func $twodup - global.get $sp i32.load - global.get $sp i32.const 4 i32.add i32.load - call $push - call $push - call $next) - - (func $twodrop - global.get $sp - i32.const 8 - i32.add - global.set $sp - call $next) - - (func $twoswap - global.get $sp - i32.const 8 - i32.add - global.get $sp - i32.load - - global.get $sp - i32.const 12 - i32.add - global.get $sp - i32.const 4 - i32.add - i32.load - - global.get $sp - global.get $sp - i32.const 8 - i32.add - i32.load - - global.get $sp - i32.const 4 - i32.add - global.get $sp - i32.const 12 - i32.add - i32.load - - i32.store - i32.store - i32.store - i32.store - - call $next) - - ;; Arithmetic and logic - - (func $inc - global.get $sp - global.get $sp - i32.load - i32.const 1 - i32.add - i32.store - call $next) - - (func $dec - global.get $sp - global.get $sp - i32.load - i32.const 1 - i32.sub - i32.store - call $next) - - (func $inc4 - global.get $sp - global.get $sp - i32.load - i32.const 4 - i32.add - i32.store - call $next) - - (func $dec4 - global.get $sp - global.get $sp - i32.load - i32.const 4 - i32.sub - i32.store - call $next) - - (func $add - call $pop - call $pop - i32.add - call $push - call $next) - - (func $sub (local $tmp i32) - call $pop - local.set $tmp - call $pop - local.get $tmp - i32.sub - call $push - call $next) - - (func $mul - call $pop - call $pop - i32.mul - call $push - call $next) - - (func $div (local $tmp i32) - call $pop - local.set $tmp - call $pop - local.get $tmp - i32.div_s - call $push - call $next) - - (func $mod (local $tmp i32) - call $pop - local.set $tmp - call $pop - local.get $tmp - i32.rem_s - call $push - call $next) - - (func $eq - call $pop - call $pop - i32.eq - i32.const 0 i32.sub - call $push - call $next) - - (func $neq - call $pop - call $pop - i32.ne - i32.const 0 i32.sub - call $push - call $next) - - (func $lt (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 (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 (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 (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 - call $pop - i32.eqz - i32.const 0 i32.sub - call $push - call $next) - - (func $zneq - call $pop - i32.const 0 - i32.ne - i32.const 0 i32.sub - call $push - call $next) - - (func $zlt - call $pop - i32.const 0 - i32.lt_s - i32.const 0 i32.sub - call $push - call $next) - - (func $zgt - call $pop - i32.const 0 - i32.gt_s - i32.const 0 i32.sub - call $push - call $next) - - (func $zlte - call $pop - i32.const 0 - i32.le_s - i32.const 0 i32.sub - call $push - call $next) - - (func $zgte - call $pop - i32.const 0 - i32.ge_s - i32.const 0 i32.sub - call $push - call $next) - - (func $and - call $pop - call $pop - i32.and - call $push - call $next) - - (func $or - call $pop - call $pop - i32.or - call $push - call $next) - - (func $xor - call $pop - call $pop - i32.xor - call $push - call $next) - - (func $invert - call $pop - i32.const 0xffffffff - i32.xor - call $push - call $next) - - ;; Memory - - (func $store - call $pop - call $pop - i32.store - call $next) - - (func $fetch - call $pop - i32.load - call $push - call $next) - - (func $addstore (local $tmp i32) - call $pop - local.tee $tmp - local.get $tmp - i32.load - call $pop - i32.add - i32.store - call $next) - - (func $substore (local $tmp i32) - call $pop - local.tee $tmp - local.get $tmp - i32.load - call $pop - i32.sub - i32.store - call $next) - - (func $storebyte - call $pop - call $pop - i32.store8 - call $next) - - (func $fetchbyte - call $pop - i32.load8_u - call $push - call $next) - - (func $atomic-store - call $pop - call $pop - i32.atomic.store - call $next) - - (func $atomic-fetch - call $pop - i32.atomic.load - call $push - call $next) - - (func $atomic-storebyte - call $pop - call $pop - i32.atomic.store8 - call $next) - - (func $atomic-fetchbyte - call $pop - i32.atomic.load8_u - call $push - call $next) - - (func $copy (local $src i32) (local $dst i32) (local $n i32) - call $pop local.set $dst - call $pop local.set $src - call $pop local.set $n - - block $done - loop $loop - local.get $n - i32.eqz br_if $done - - local.get $dst - local.get $src - i32.load8_u i32.store8 - - 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 $loop - end - end - - call $next) - - ;; Core utility words - - (func $exit - call $poprsp - global.set $ip - call $next) - - (func $lit - global.get $ip - i32.load - call $push - global.get $ip - i32.const 4 - i32.add - global.set $ip - call $next) - - (func $execute - call $pop - global.set $cfa - global.get $cfa - i32.load - global.set $fn) - - (func $halt i32.const 0 global.set $run) - - ;; Return and parameter stack primitives - - (func $tor - call $pop - call $pushrsp - call $next) - - (func $fromr - call $poprsp - call $push - call $next) - - (func $rspfetch - global.get $rsp - call $push - call $next) - - (func $rspstore - call $pop - global.set $rsp - call $next) - - (func $rdrop - global.get $rsp - i32.const 4 - i32.add - global.set $rsp - call $next) - - (func $spfetch - global.get $sp - call $push - call $next) - - (func $spstore - call $pop - global.set $sp - call $next) - - ;; Serial I/O - - (func $key (local $head i32) - global.get $RXHEAD - i32.atomic.load8_u - local.set $head - - ;; Wait for RXBUF to be non-empty - loop $wait - local.get $head - - global.get $RXTAIL - i32.atomic.load8_u - i32.eq - if - global.get $RXTAIL - local.get $head - i64.const -1 - memory.atomic.wait32 - - br $wait - end - end - - ;; Read byte at head position - global.get $RXBUF - local.get $head - i32.add - i32.load8_u - call $push - - ;; Advance RXHEAD - global.get $RXHEAD - local.get $head - i32.const 1 - i32.add - i32.const 0x1f - i32.and - i32.atomic.store8 - - call $next) - - (func $emit (local $tail i32) (local $next i32) - ;; Wait for TXBUF to be non-full - loop $wait - global.get $TXTAIL - i32.atomic.load8_u - local.tee $tail - i32.const 1 - i32.add - i32.const 0x1f - i32.and - local.tee $next - global.get $TXHEAD - i32.atomic.load8_u - i32.eq - br_if $wait - end - - ;; Write byte at tail position - global.get $TXBUF - local.get $tail - i32.add - call $pop - i32.store8 - - ;; Advance TXTAIL - global.get $TXTAIL - local.get $next - i32.atomic.store8 - - call $next) - - ;; Branching - - (func $branch - global.get $ip - i32.load - global.get $ip - i32.add - global.set $ip - call $next) - - (func $zbranch - call $pop - if (result i32) - i32.const 4 - else - global.get $ip - i32.load - end - global.get $ip - i32.add - global.set $ip - call $next) - - ;; 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. Fantastically, there - ;; doesn't seem to be a way to sensibly give symbolic names to the - ;; indices the functions are inserted at so, instead of having all - ;; the entries here, most of them are defined in-line with the - ;; dictionary entries so that the definition of the index isn't too - ;; far from its use. - ;; - ;; The exceptions are the special inner interpreters, DOCOL, DOVAL - ;; and DOVAR, which I've put here in indices 0, 1 and 2 for - ;; convenience. - - (type $codeword (func)) - (table $codewords 100 funcref) - - (elem (i32.const 0x00) $docol) - (elem (i32.const 0x01) $doval) - (elem (i32.const 0x02) $dovar) - - ;; Dictionary time D: - ;; - ;; I <3 writing dictionary entries by hand! - - (elem (i32.const 0x03) $dup) - (data (i32.const 0x0200) - "\00\00\00\00" - "\03DUP" - "\03\00\00\00") - - (elem (i32.const 0x04) $drop) - (data (i32.const 0x020c) - "\00\02\00\00" - "\04DROP\00\00\00" - "\04\00\00\00") - - (elem (i32.const 0x05) $swap) - (data (i32.const 0x021c) - "\0c\02\00\00" - "\04SWAP\00\00\00" - "\05\00\00\00") - - (elem (i32.const 0x06) $rot) - (data (i32.const 0x022c) - "\1c\02\00\00" - "\03ROT" - "\06\00\00\00") - - (elem (i32.const 0x07) $nrot) - (data (i32.const 0x0238) - "\2c\02\00\00" - "\04-ROT\00\00\00" - "\07\00\00\00") - - (elem (i32.const 0x08) $over) - (data (i32.const 0x0248) - "\38\02\00\00" - "\04OVER\00\00\00" - "\08\00\00\00") - - (elem (i32.const 0x09) $twodup) - (data (i32.const 0x0258) - "\48\02\00\00" - "\042DUP\00\00\00" - "\09\00\00\00") - - (elem (i32.const 0x0a) $twodrop) - (data (i32.const 0x0268) - "\58\02\00\00" - "\052DROP\00\00" - "\0a\00\00\00") - - (elem (i32.const 0x0b) $twoswap) - (data (i32.const 0x0278) - "\68\02\00\00" - "\052SWAP\00\00" - "\0b\00\00\00") - - (elem (i32.const 0x0c) $inc) - (data (i32.const 0x0288) - "\78\02\00\00" - "\021+\00" - "\0c\00\00\00") - - (elem (i32.const 0x0d) $dec) - (data (i32.const 0x0294) - "\88\02\00\00" - "\021-\00" - "\0d\00\00\00") - - (elem (i32.const 0x0e) $inc4) - (data (i32.const 0x02a0) - "\94\02\00\00" - "\024+\00" - "\0e\00\00\00") - - (elem (i32.const 0x0f) $dec4) - (data (i32.const 0x02ac) - "\a0\02\00\00" - "\024-\00" - "\0f\00\00\00") - - (elem (i32.const 0x10) $add) - (data (i32.const 0x02b8) - "\ac\02\00\00" - "\01+\00\00" - "\10\00\00\00") - - (elem (i32.const 0x11) $sub) - (data (i32.const 0x02c4) - "\b8\02\00\00" - "\01-\00\00" - "\11\00\00\00") - - (elem (i32.const 0x12) $mul) - (data (i32.const 0x02d0) - "\c4\02\00\00" - "\01*\00\00" - "\12\00\00\00") - - (elem (i32.const 0x13) $div) - (data (i32.const 0x02dc) - "\d0\02\00\00" - "\01/\00\00" - "\13\00\00\00") - - (elem (i32.const 0x14) $mod) - (data (i32.const 0x02e8) - "\dc\02\00\00" - "\03MOD" - "\14\00\00\00") - - (elem (i32.const 0x15) $eq) - (data (i32.const 0x02f4) - "\e8\02\00\00" - "\01=\00\00" - "\15\00\00\00") - - (elem (i32.const 0x16) $neq) - (data (i32.const 0x0300) - "\f4\02\00\00" - "\02<>\00" - "\16\00\00\00") - - (elem (i32.const 0x17) $lt) - (data (i32.const 0x030c) - "\00\03\00\00" - "\01<\00\00" - "\17\00\00\00") - - (elem (i32.const 0x18) $gt) - (data (i32.const 0x0318) - "\0c\03\00\00" - "\01>\00\00" - "\18\00\00\00") - - (elem (i32.const 0x19) $lte) - (data (i32.const 0x0324) - "\18\03\00\00" - "\02<=\00" - "\19\00\00\00") - - (elem (i32.const 0x1a) $gte) - (data (i32.const 0x0330) - "\24\03\00\00" - "\02>=\00" - "\1a\00\00\00") - - (elem (i32.const 0x1b) $zeq) - (data (i32.const 0x033c) - "\30\03\00\00" - "\020=\00" - "\1b\00\00\00") - - (elem (i32.const 0x1c) $zneq) - (data (i32.const 0x0348) - "\3c\03\00\00" - "\030<>" - "\1c\00\00\00") - - (elem (i32.const 0x1d) $zlt) - (data (i32.const 0x0354) - "\48\03\00\00" - "\020<\00" - "\1d\00\00\00") - - (elem (i32.const 0x1e) $zgt) - (data (i32.const 0x0360) - "\54\03\00\00" - "\020>\00" - "\1e\00\00\00") - - (elem (i32.const 0x1f) $zlte) - (data (i32.const 0x036c) - "\60\03\00\00" - "\030<=" - "\1f\00\00\00") - - (elem (i32.const 0x20) $zgte) - (data (i32.const 0x0378) - "\6c\03\00\00" - "\030>=" - "\20\00\00\00") - - (elem (i32.const 0x21) $and) - (data (i32.const 0x0384) - "\78\03\00\00" - "\03AND" - "\21\00\00\00") - - (elem (i32.const 0x22) $or) - (data (i32.const 0x0390) - "\84\03\00\00" - "\02OR\00" - "\22\00\00\00") - - (elem (i32.const 0x23) $xor) - (data (i32.const 0x039c) - "\90\03\00\00" - "\03XOR" - "\23\00\00\00") - - (elem (i32.const 0x24) $invert) - (data (i32.const 0x03a8) - "\9c\03\00\00" - "\06INVERT\00" - "\24\00\00\00") - - (elem (i32.const 0x25) $store) - (data (i32.const 0x03b8) - "\a8\03\00\00" - "\01!\00\00" - "\25\00\00\00") - - (elem (i32.const 0x26) $fetch) - (data (i32.const 0x03c4) - "\b8\03\00\00" - "\01@\00\00" - "\26\00\00\00") - - (elem (i32.const 0x27) $addstore) - (data (i32.const 0x03d0) - "\c4\03\00\00" - "\02+!\00" - "\27\00\00\00") - - (elem (i32.const 0x28) $substore) - (data (i32.const 0x03dc) - "\d0\03\00\00" - "\02-!\00" - "\28\00\00\00") - - (elem (i32.const 0x29) $storebyte) - (data (i32.const 0x03e8) - "\dc\03\00\00" - "\02C!\00" - "\29\00\00\00") - - (elem (i32.const 0x2a) $fetchbyte) - (data (i32.const 0x03f4) - "\e8\03\00\00" - "\02C@\00" - "\2a\00\00\00") - - (elem (i32.const 0x2b) $exit) - (data (i32.const 0x0400) - "\f4\03\00\00" - "\04EXIT\00\00\00" - "\2b\00\00\00") - - (elem (i32.const 0x2c) $lit) - (data (i32.const 0x0410) - "\00\04\00\00" - "\03LIT" - "\2c\00\00\00") - - (elem (i32.const 0x2d) $tor) - (data (i32.const 0x041c) - "\10\04\00\00" - "\02>R\00" - "\2d\00\00\00") - - (elem (i32.const 0x2e) $fromr) - (data (i32.const 0x0428) - "\1c\04\00\00" - "\02R>\00" - "\2e\00\00\00") - - (elem (i32.const 0x2f) $rspfetch) - (data (i32.const 0x434) - "\28\04\00\00" - "\04RSP@\00\00\00" - "\2f\00\00\00") - - (elem (i32.const 0x30) $rspstore) - (data (i32.const 0x0444) - "\34\04\00\00" - "\04RSP!\00\00\00" - "\30\00\00\00") - - (elem (i32.const 0x31) $rdrop) - (data (i32.const 0x0454) - "\44\04\00\00" - "\05RDROP\00\00" - "\31\00\00\00") - - (elem (i32.const 0x32) $spfetch) - (data (i32.const 0x0464) - "\54\04\00\00" - "\03SP@" - "\32\00\00\00") - - (elem (i32.const 0x33) $spstore) - (data (i32.const 0x0470) - "\64\04\00\00" - "\03SP!" - "\33\00\00\00") - - (elem (i32.const 0x34) $key) - (data (i32.const 0x047c) - "\70\04\00\00" - "\03KEY" - "\34\00\00\00") - - (elem (i32.const 0x35) $emit) - (data (i32.const 0x0488) - "\7c\04\00\00" - "\04EMIT\00\00\00" - "\35\00\00\00") - - (elem (i32.const 0x36) $branch) - (data (i32.const 0x0498) - "\88\04\00\00" - "\06BRANCH\00" - "\36\00\00\00") - - (elem (i32.const 0x37) $zbranch) - (data (i32.const 0x04a8) - "\98\04\00\00" - "\070BRANCH" - "\37\00\00\00") - - ;; Built-in values and variables - - (data (i32.const 0x04b8) - "\a8\04\00\00" - "\05DOCOL\00\00" - "\01\00\00\00" - "\00\00\00\00") - - (data (i32.const 0x04cc) - "\b8\04\00\00" - "\05DOVAL\00\00" - "\01\00\00\00" - "\01\00\00\00") - - (data (i32.const 0x04e0) - "\cc\04\00\00" - "\05DOVAR\00\00" - "\01\00\00\00" - "\02\00\00\00") - - (data (i32.const 0x04f4) - "\e0\04\00\00" - "\07LIT-CFA" - "\01\00\00\00" - "\18\04\00\00") - - (data (i32.const 0x0508) - "\f4\04\00\00" - "\02R0\00" - "\01\00\00\00" - "\00\00\01\00") - - (data (i32.const 0x0518) - "\08\05\00\00" - "\02S0\00" - "\01\00\00\00" - "\00\f0\00\00") - - (data (i32.const 0x0528) - "\18\05\00\00" - "\04TRUE\00\00\00" - "\01\00\00\00" - "\ff\ff\ff\ff") - - (data (i32.const 0x053c) - "\28\05\00\00" - "\05FALSE\00\00" - "\01\00\00\00" - "\00\00\00\00") - - (data (i32.const 0x0550) - "\3c\05\00\00" - "\05STATE\00\00" - "\02\00\00\00" - "\00\00\00\00") - - (data (i32.const 0x0564) - "\50\05\00\00" - "\04BASE\00\00\00" - "\02\00\00\00" - "\0a\00\00\00") - - (data (i32.const 0x0578) - "\64\05\00\00" - "\04HERE\00\00\00" - "\02\00\00\00" - "\60\0e\00\00") - - (data (i32.const 0x058c) - "\78\05\00\00" - "\06LATEST\00" - "\02\00\00\00" - "\30\0e\00\00") - - (data (i32.const 0x05a0) - "\8c\05\00\00" - "\07WORDBUF" - "\02\00\00\00") - - ;; Skip 0x20 bytes for the word buffer - - (data (i32.const 0x05d0) - "\a0\05\00\00" - "\07WNFHOOK" - "\01\00\00\00" - "\f0\0d\00\00") - - ;; And now, it's time for some hand-compiled colon words. It - ;; probably would have made more sense to write most of these - ;; directly in WAT, but I think this is way cooler. - - ;; : TUCK DUP -ROT ; - - (data (i32.const 0x05e4) - "\d0\05\00\00" - "\04TUCK\00\00\00" - "\00\00\00\00" - "\08\02\00\00" ;; DUP - "\44\02\00\00" ;; -ROT - "\0c\04\00\00") ;; EXIT - - ;; => 0x1c bytes - - ;; : 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 - ;; ; - - (data (i32.const 0x0600) - "\e4\05\00\00" - "\06NSPACE\00" - "\00\00\00\00" - "\08\02\00\00" ;; DUP - "\18\04\00\00" ;; LIT - "\09\00\00\00" ;; 9 - "\08\03\00\00" ;; <> - "\28\02\00\00" ;; SWAP - "\08\02\00\00" ;; DUP - "\18\04\00\00" ;; LIT - "\0a\00\00\00" ;; 10 - "\08\03\00\00" ;; <> - "\28\02\00\00" ;; SWAP - "\08\02\00\00" ;; DUP - "\18\04\00\00" ;; LIT - "\0d\00\00\00" ;; 13 - "\08\03\00\00" ;; <> - "\28\02\00\00" ;; SWAP - "\18\04\00\00" ;; LIT - "\20\00\00\00" ;; 32 - "\08\03\00\00" ;; <> - "\8c\03\00\00" ;; AND - "\8c\03\00\00" ;; AND - "\8c\03\00\00" ;; AND - "\0c\04\00\00") ;; EXIT - - ;; => 0x68 bytes - - ;; : 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 - ;; ; - - (data (i32.const 0x0668) - "\00\06\00\00" - "\04WORD\00\00\00" - "\00\00\00\00" - "\18\04\00\00" ;; LIT - "\00\00\00\00" ;; 0 - "\84\04\00\00" ;; KEY - "\f0\05\00\00" ;; TUCK - "\0c\06\00\00" ;; NSPACE - "\b4\04\00\00" ;; 0BRANCH - "\3c\00\00\00" ;; 60 - "\f0\05\00\00" ;; TUCK - "\ac\05\00\00" ;; WORDBUF - "\c0\02\00\00" ;; + - "\f0\03\00\00" ;; C! - "\90\02\00\00" ;; 1+ - "\08\02\00\00" ;; DUP - "\18\04\00\00" ;; LIT - "\20\00\00\00" ;; 32 - "\38\03\00\00" ;; >= - "\b4\04\00\00" ;; 0BRANCH - "\08\00\00\00" ;; 8 - "\0c\04\00\00" ;; EXIT - "\a4\04\00\00" ;; BRANCH - "\b8\ff\ff\ff" ;; -72 - "\28\02\00\00" ;; SWAP - "\18\02\00\00" ;; DROP - "\08\02\00\00" ;; DUP - "\50\03\00\00" ;; 0<> - "\b4\04\00\00" ;; 0BRANCH - "\a0\ff\ff\ff" ;; -96 - "\0c\04\00\00") ;; EXIT - - ;; => 0x80 bytes - - ;; : 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 - ;; ; - - (data (i32.const 0x06e8) - "\68\06\00\00" - "\07STRING=" - "\00\00\00\00" - "\64\02\00\00" ;; 2DUP - "\fc\03\00\00" ;; C@ - "\28\02\00\00" ;; SWAP - "\fc\03\00\00" ;; C@ - "\fc\02\00\00" ;; = - "\b4\04\00\00" ;; 0BRANCH - "\30\00\00\00" ;; 48 - "\90\02\00\00" ;; 1+ - "\44\02\00\00" ;; -ROT - "\90\02\00\00" ;; 1+ - "\44\02\00\00" ;; -ROT - "\9c\02\00\00" ;; 1- - "\08\02\00\00" ;; DUP - "\b4\04\00\00" ;; 0BRANCH - "\20\00\00\00" ;; 32 - "\44\02\00\00" ;; -ROT - "\a4\04\00\00" ;; BRANCH - "\bc\ff\ff\ff" ;; -68 - "\74\02\00\00" ;; 2DROP - "\18\02\00\00" ;; DROP - "\48\05\00\00" ;; FALSE - "\0c\04\00\00" ;; EXIT - "\74\02\00\00" ;; 2DROP - "\18\02\00\00" ;; DROP - "\34\05\00\00" ;; TRUE - "\0c\04\00\00") ;; EXIT - - ;; => 0x78 bytes - - ;; : NAME-LEN 4+ C@ 31 AND ; - - (data (i32.const 0x0760) - "\e8\06\00\00" - "\08NAME-LEN\00\00\00" - "\00\00\00\00" - "\a8\02\00\00" ;; 4+ - "\fc\03\00\00" ;; C@ - "\18\04\00\00" ;; LIT - "\1f\00\00\00" ;; 31 - "\8c\03\00\00" ;; AND - "\0c\04\00\00") ;; EXIT - - ;; => 0x2c bytes - - ;; : 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 - ;; ; - - (data (i32.const 0x078c) - "\60\07\00\00" - "\04FIND\00\00\00" - "\00\00\00\00" - "\98\05\00\00" ;; LATEST - "\cc\03\00\00" ;; @ - "\f0\05\00\00" ;; TUCK - "\44\0e\00\00" ;; FIND-NAME-LEN - "\54\02\00\00" ;; OVER - "\fc\02\00\00" ;; = - "\b4\04\00\00" ;; 0BRANCH - "\34\00\00\00" ;; 52 - "\54\02\00\00" ;; OVER - "\18\04\00\00" ;; LIT - "\05\00\00\00" ;; 5 - "\c0\02\00\00" ;; + - "\54\02\00\00" ;; OVER - "\28\02\00\00" ;; SWAP - "\ac\05\00\00" ;; WORDBUF - "\f4\06\00\00" ;; STRING= - "\b4\04\00\00" ;; 0BRANCH - "\0c\00\00\00" ;; 12 - "\18\02\00\00" ;; DROP - "\0c\04\00\00" ;; EXIT - "\54\02\00\00" ;; OVER - "\cc\03\00\00" ;; @ - "\50\03\00\00" ;; 0<> - "\b4\04\00\00" ;; 0BRANCH - "\14\00\00\00" ;; 20 - "\28\02\00\00" ;; SWAP - "\cc\03\00\00" ;; @ - "\a4\04\00\00" ;; BRANCH - "\98\ff\ff\ff" ;; -104 - "\74\02\00\00" ;; 2DROP - "\48\05\00\00" ;; FALSE - "\0c\04\00\00") ;; EXIT - - ;; => 0x90 bytes - - ;; : >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 alignment check - ;; ; - - (data (i32.const 0x081c) - "\8c\07\00\00" - "\04>CFA\00\00\00" - "\00\00\00\00" - "\08\02\00\00" ;; DUP - "\70\07\00\00" ;; NAME-LEN - "\18\04\00\00" ;; LIT - "\05\00\00\00" ;; 5 - "\c0\02\00\00" ;; + - "\c0\02\00\00" ;; + - "\08\02\00\00" ;; DUP - "\18\04\00\00" ;; LIT - "\03\00\00\00" ;; 3 - "\8c\03\00\00" ;; AND - "\b4\04\00\00" ;; 0BRANCH - "\10\00\00\00" ;; 16 - "\90\02\00\00" ;; 1+ - "\a4\04\00\00" ;; BRANCH - "\e0\ff\ff\ff" ;; -32 - "\0c\04\00\00") ;; EXIT - - ;; => 0x50 bytes - - ;; : 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 - ;; ; - - (data (i32.const 0x086c) - "\1c\08\00\00" - "\05DIGIT\00\00" - "\00\00\00\00" - "\08\02\00\00" ;; DUP - "\08\02\00\00" ;; DUP - "\18\04\00\00" ;; LIT - "\30\00\00\00" ;; 48 - "\38\03\00\00" ;; >= - "\28\02\00\00" ;; SWAP - "\18\04\00\00" ;; LIT - "\39\00\00\00" ;; 57 - "\2c\03\00\00" ;; <= - "\8c\03\00\00" ;; AND - "\b4\04\00\00" ;; 0BRANCH - "\18\00\00\00" ;; 24 - "\18\04\00\00" ;; LIT - "\30\00\00\00" ;; 48 - "\cc\02\00\00" ;; - - "\a4\04\00\00" ;; BRANCH - "\40\00\00\00" ;; 64 - "\08\02\00\00" ;; DUP - "\08\02\00\00" ;; DUP - "\18\04\00\00" ;; LIT - "\41\00\00\00" ;; 65 - "\38\03\00\00" ;; >= - "\28\02\00\00" ;; SWAP - "\18\04\00\00" ;; LIT - "\5a\00\00\00" ;; 90 - "\2c\03\00\00" ;; <= - "\8c\03\00\00" ;; AND - "\b4\04\00\00" ;; 0BRANCH - "\3c\00\00\00" ;; 60 - "\18\04\00\00" ;; LIT - "\37\00\00\00" ;; 55 - "\cc\02\00\00" ;; - - "\08\02\00\00" ;; DUP - "\08\02\00\00" ;; DUP - "\80\03\00\00" ;; 0>= - "\28\02\00\00" ;; SWAP - "\70\05\00\00" ;; BASE - "\cc\03\00\00" ;; @ - "\14\03\00\00" ;; < - "\8c\03\00\00" ;; AND - "\b4\04\00\00" ;; 0BRANCH - "\08\00\00\00" ;; 8 - "\0c\04\00\00" ;; EXIT - "\18\02\00\00" ;; DROP - "\34\05\00\00" ;; TRUE - "\0c\04\00\00") ;; EXIT - - ;; => 0xc8 bytes - - ;; : NEGATE INVERT 1+ ; - - (data (i32.const 0x0934) - "\6c\08\00\00" - "\06NEGATE\00" - "\00\00\00\00" - "\b4\03\00\00" ;; INVERT - "\90\02\00\00" ;; 1+ - "\0c\04\00\00") ;; EXIT - - ;; => 0x1c bytes - - ;; : 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 - ;; ; - - (data (i32.const 0x0950) - "\34\09\00\00" - "\07NUMBER?" - "\00\00\00\00" - "\ac\05\00\00" ;; WORDBUF - "\08\02\00\00" ;; DUP - "\fc\03\00\00" ;; C@ - "\18\04\00\00" ;; LIT - "\2d\00\00\00" ;; 45 - "\fc\02\00\00" ;; = - "\b4\04\00\00" ;; 0BRANCH - "\3c\00\00\00" ;; 60 - "\90\02\00\00" ;; 1+ - "\28\02\00\00" ;; SWAP - "\9c\02\00\00" ;; 1- - "\08\02\00\00" ;; DUP - "\b4\04\00\00" ;; 0BRANCH - "\18\00\00\00" ;; 24 - "\34\05\00\00" ;; TRUE - "\44\02\00\00" ;; -ROT - "\28\02\00\00" ;; SWAP - "\a4\04\00\00" ;; BRANCH - "\18\00\00\00" ;; 24 - "\74\02\00\00" ;; 2DROP - "\48\05\00\00" ;; FALSE - "\0c\04\00\00" ;; EXIT - "\48\05\00\00" ;; FALSE - "\44\02\00\00" ;; -ROT - "\18\04\00\00" ;; LIT - "\00\00\00\00" ;; 0 - "\54\02\00\00" ;; OVER - "\fc\03\00\00" ;; C@ - "\78\08\00\00" ;; DIGIT - "\08\02\00\00" ;; DUP - "\80\03\00\00" ;; 0>= - "\b4\04\00\00" ;; 0BRANCH - "\44\00\00\00" ;; 68 - "\28\02\00\00" ;; SWAP - "\70\05\00\00" ;; BASE - "\cc\03\00\00" ;; @ - "\d8\02\00\00" ;; * - "\c0\02\00\00" ;; + - "\28\02\00\00" ;; SWAP - "\90\02\00\00" ;; 1+ - "\34\02\00\00" ;; ROT - "\9c\02\00\00" ;; 1- - "\08\02\00\00" ;; DUP - "\b4\04\00\00" ;; 0BRANCH - "\28\00\00\00" ;; 40 - "\44\02\00\00" ;; -ROT - "\28\02\00\00" ;; SWAP - "\a4\04\00\00" ;; BRANCH - "\a8\ff\ff\ff" ;; -88 - "\74\02\00\00" ;; 2DROP - "\74\02\00\00" ;; 2DROP - "\18\02\00\00" ;; DROP - "\48\05\00\00" ;; FALSE - "\0c\04\00\00" ;; EXIT - "\74\02\00\00" ;; 2DROP - "\28\02\00\00" ;; SWAP - "\b4\04\00\00" ;; 0BRANCH - "\08\00\00\00" ;; 8 - "\40\09\00\00" ;; NEGATE - "\34\05\00\00" ;; TRUE - "\0c\04\00\00") ;; EXIT - - ;; => 0x104 bytes - - ;; : , HERE @ ! 4 HERE +! ; - - (data (i32.const 0x0a54) - "\50\09\00\00" - "\01,\00\00" - "\00\00\00\00" - "\84\05\00\00" ;; HERE - "\cc\03\00\00" ;; @ - "\c0\03\00\00" ;; ! - "\18\04\00\00" ;; LIT - "\04\00\00\00" ;; 4 - "\84\05\00\00" ;; HERE - "\d8\03\00\00" ;; +! - "\0c\04\00\00") ;; EXIT - - ;; => 0x2c bytes - - ;; : IMMEDIATE? 4+ @ 128 AND 0BRANCH [12] TRUE EXIT FALSE ; - - (data (i32.const 0x0a80) - "\54\0a\00\00" - "\0aIMMEDIATE?\00" - "\00\00\00\00" - "\a8\02\00\00" ;; 4+ - "\cc\03\00\00" ;; @ - "\18\04\00\00" ;; LIT - "\80\00\00\00" ;; 128 - "\8c\03\00\00" ;; AND - "\b4\04\00\00" ;; 0BRANCH - "\0c\00\00\00" ;; 12 - "\34\05\00\00" ;; TRUE - "\0c\04\00\00" ;; EXIT - "\48\05\00\00" ;; FALSE - "\0c\04\00\00") ;; EXIT - - ;; => 0x40 bytes - - ;; : 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 - ;; ; - - (data (i32.const 0x0ac0) - "\80\0a\00\00" - "\09INTERPRET\00\00" - "\00\00\00\00" - "\74\06\00\00" ;; WORD - "\08\02\00\00" ;; DUP - "\98\07\00\00" ;; FIND - "\08\02\00\00" ;; DUP - "\b4\04\00\00" ;; 0BRANCH - "\48\00\00\00" ;; 72 - "\28\02\00\00" ;; SWAP - "\18\02\00\00" ;; DROP - "\08\02\00\00" ;; DUP - "\90\0a\00\00" ;; IMMEDIATE? - "\b4\03\00\00" ;; INVERT - "\b4\04\00\00" ;; 0BRANCH - "\20\00\00\00" ;; 32 - "\5c\05\00\00" ;; STATE - "\cc\03\00\00" ;; @ - "\b4\04\00\00" ;; 0BRANCH - "\10\00\00\00" ;; 16 - "\28\08\00\00" ;; >CFA - "\5c\0a\00\00" ;; , - "\0c\04\00\00" ;; EXIT - "\28\08\00\00" ;; >CFA - "\bc\0b\00\00" ;; EXECUTE - "\0c\04\00\00" ;; EXIT - "\18\02\00\00" ;; DROP - "\08\02\00\00" ;; DUP - "\5c\09\00\00" ;; NUMBER? - "\b4\04\00\00" ;; 0BRANCH - "\30\00\00\00" ;; 48 - "\28\02\00\00" ;; SWAP - "\18\02\00\00" ;; DROP - "\5c\05\00\00" ;; STATE - "\cc\03\00\00" ;; @ - "\b4\04\00\00" ;; 0BRANCH - "\14\00\00\00" ;; 20 - "\18\04\00\00" ;; LIT - "\18\04\00\00" ;; LIT - "\5c\0a\00\00" ;; , - "\5c\0a\00\00" ;; , - "\0c\04\00\00" ;; EXIT - "\dc\05\00\00" ;; WNFHOOK - "\bc\0b\00\00" ;; EXECUTE - "\0c\04\00\00") ;; EXIT - - ;; => 0xbc bytes - - ;; The previous version of INTERPRET was 0xc4 bytes, so we have 8 - ;; unused bytes here lol - - ;; : QUIT R0 RSP! INTERPRET BRANCH [-8] ; - - (data (i32.const 0x0b84) - "\c0\0a\00\00" - "\04QUIT\00\00\00" - "\00\00\00\00" - "\10\05\00\00" ;; R0 - "\50\04\00\00" ;; RSP! - "\d0\0a\00\00" ;; INTERPRET - "\a4\04\00\00" ;; BRANCH - "\f8\ff\ff\ff" ;; -8 - "\0c\04\00\00") ;; EXIT - - ;; => 0x28 bytes - - ;; Cold start - - (data (i32.const 0x0bac) "\90\0b\00\00") ;; QUIT - - ;; Bro thought she didn't need EXECUTE - - (elem (i32.const 0x38) $execute) - (data (i32.const 0x0bb0) - "\84\0b\00\00" - "\07EXECUTE" - "\38\00\00\00") - - ;; Some extra codewords I forgot to define earlier - - (elem (i32.const 0x39) $atomic-store) - (data (i32.const 0x0bc0) - "\b0\0b\00\00" - "\02A!\00" - "\39\00\00\00") - - (elem (i32.const 0x3a) $atomic-fetch) - (data (i32.const 0x0bcc) - "\c0\0b\00\00" - "\02A@\00" - "\3a\00\00\00") - - (elem (i32.const 0x3b) $atomic-storebyte) - (data (i32.const 0x0bd8) - "\c0\0b\00\00" - "\03AC!" - "\3b\00\00\00") - - (elem (i32.const 0x3c) $atomic-fetchbyte) - (data (i32.const 0x0be4) - "\d8\0b\00\00" - "\03AC@" - "\3c\00\00\00") - - (elem (i32.const 0x3d) $copy) - (data (i32.const 0x0bf0) - "\e4\0b\00\00" - "\04COPY\00\00\00" - "\3d\00\00\00") - - (elem (i32.const 0x3e) $halt) - (data (i32.const 0x0c00) - "\f0\0b\00\00" - "\04HALT\00\00\00" - "\3e\00\00\00") - - ;; And now to make myself obsolete as the compiler (finally) - - ;; : [ 0 STATE ! ; IMMEDIATE - - (data (i32.const 0x0c10) - "\00\0c\00\00" - "\81[\00\00" - "\00\00\00\00" - "\18\04\00\00" ;; LIT - "\00\00\00\00" ;; 0 - "\5c\05\00\00" ;; STATE - "\c0\03\00\00" ;; ! - "\0c\04\00\00") ;; EXIT - - ;; => 0x20 bytes - - ;; : ] 1 STATE ! ; - - (data (i32.const 0x0c30) - "\10\0c\00\00" - "\01]\00\00" - "\00\00\00\00" - "\18\04\00\00" ;; LIT - "\01\00\00\00" ;; 1 - "\5c\05\00\00" ;; STATE - "\c0\03\00\00" ;; ! - "\0c\04\00\00") ;; EXIT - - ;; => 0x20 bytes - - ;; : ALIGN - ;; DUP 3 AND 0BRANCH [32] - ;; 0 OVER C! 1+ BRANCH [-48] - ;; ; - - (data (i32.const 0x0c50) - "\30\0c\00\00" - "\05ALIGN\00\00" - "\00\00\00\00" - "\08\02\00\00" ;; DUP - "\18\04\00\00" ;; LIT - "\03\00\00\00" ;; 3 - "\8c\03\00\00" ;; AND - "\b4\04\00\00" ;; 0BRANCH - "\20\00\00\00" ;; 32 - "\18\04\00\00" ;; LIT - "\00\00\00\00" ;; 0 - "\54\02\00\00" ;; OVER - "\f0\03\00\00" ;; C! - "\90\02\00\00" ;; 1+ - "\a4\04\00\00" ;; BRANCH - "\d0\ff\ff\ff" ;; -48 - "\0c\04\00\00") ;; EXIT - - ;; => 0x48 bytes - - ;; : HIDDEN 4+ DUP C@ 32 XOR SWAP C! ; - - (data (i32.const 0x0c98) - "\50\0c\00\00" - "\06HIDDEN\00" - "\00\00\00\00" - "\a8\02\00\00" ;; 4+ - "\08\02\00\00" ;; DUP - "\fc\03\00\00" ;; C@ - "\18\04\00\00" ;; LIT - "\20\00\00\00" ;; 32 - "\a4\03\00\00" ;; XOR - "\28\02\00\00" ;; SWAP - "\f0\03\00\00" ;; C! - "\0c\04\00\00") ;; EXIT - - ;; => 0x34 bytes - - ;; : IMMEDIATE - ;; LATEST @ - ;; 4+ DUP C@ 128 XOR SWAP C! - ;; ; IMMEDIATE - - (data (i32.const 0x0ccc) - "\98\0c\00\00" - "\89IMMEDIATE\00\00" - "\00\00\00\00" - "\98\05\00\00" ;; LATEST - "\cc\03\00\00" ;; @ - "\a8\02\00\00" ;; 4+ - "\08\02\00\00" ;; DUP - "\fc\03\00\00" ;; C@ - "\18\04\00\00" ;; LIT - "\80\00\00\00" ;; 128 - "\a4\03\00\00" ;; XOR - "\28\02\00\00" ;; SWAP - "\f0\03\00\00" ;; C! - "\0c\04\00\00") ;; EXIT - - ;; => 0x40 bytes - - ;; : 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 - ;; ; - - (data (i32.const 0x0d0c) - "\cc\0c\00\00" - "\06CREATE\00" - "\00\00\00\00" - "\84\05\00\00" ;; HERE - "\cc\03\00\00" ;; @ - "\98\05\00\00" ;; LATEST - "\cc\03\00\00" ;; @ - "\54\02\00\00" ;; OVER - "\c0\03\00\00" ;; ! - "\a8\02\00\00" ;; 4+ - "\64\02\00\00" ;; 2DUP - "\f0\03\00\00" ;; C! - "\90\02\00\00" ;; 1+ - "\64\02\00\00" ;; 2DUP - "\ac\05\00\00" ;; WORDBUF - "\28\02\00\00" ;; SWAP - "\fc\0b\00\00" ;; COPY - "\c0\02\00\00" ;; + - "\5c\0c\00\00" ;; ALIGN - "\84\05\00\00" ;; HERE - "\cc\03\00\00" ;; @ - "\98\05\00\00" ;; LATEST - "\c0\03\00\00" ;; ! - "\84\05\00\00" ;; HERE - "\c0\03\00\00" ;; ! - "\0c\04\00\00") ;; EXIT - - ;; => 0x6c bytes - - ;; : : - ;; WORD - ;; CREATE - ;; DOCOL , - ;; LATEST @ HIDDEN - ;; ] - ;; ; - - (data (i32.const 0x0d78) - "\0c\0d\00\00" - "\01:\00\00" - "\00\00\00\00" - "\74\06\00\00" ;; WORD - "\18\0d\00\00" ;; CREATE - "\c4\04\00\00" ;; DOCOL - "\5c\0a\00\00" ;; , - "\98\05\00\00" ;; LATEST - "\cc\03\00\00" ;; @ - "\a4\0c\00\00" ;; HIDDEN - "\38\0c\00\00" ;; ] - "\0c\04\00\00") ;; EXIT - - ;; => 0x30 bytes - - ;; : ; - ;; LIT EXIT , - ;; LATEST @ HIDDEN - ;; [ - ;; ; IMMEDIATE - - (data (i32.const 0x0db4) - "\78\0d\00\00" - "\81;\00\00" - "\00\00\00\00" - "\18\04\00\00" ;; LIT - "\0c\04\00\00" ;; EXIT - "\5c\0a\00\00" ;; , - "\98\05\00\00" ;; LATEST - "\cc\03\00\00" ;; @ - "\a4\0c\00\00" ;; HIDDEN - "\18\0c\00\00" ;; [ - "\0c\04\00\00") ;; EXIT - - ;; => 0x2c bytes - - ;; : WNF-HANDLER - ;; DROP \ Discard word length - ;; 87 EMIT 78 EMIT 70 EMIT 10 EMIT \ Print WNF - ;; QUIT \ Reset return stack - ;; ; - - (data (i32.const 0x0de0) - "\b4\0d\00\00" - "\0bWNF-HANDLER" - "\00\00\00\00" - "\18\02\00\00" ;; DROP - "\18\04\00\00" ;; LIT - "\57\00\00\00" ;; 87 - "\94\04\00\00" ;; EMIT - "\18\04\00\00" ;; LIT - "\4e\00\00\00" ;; 78 - "\94\04\00\00" ;; EMIT - "\18\04\00\00" ;; LIT - "\46\00\00\00" ;; 70 - "\94\04\00\00" ;; EMIT - "\18\04\00\00" ;; LIT - "\0a\00\00\00" ;; 10 - "\94\04\00\00" ;; EMIT - "\90\0b\00\00" ;; QUIT - "\0c\04\00\00") ;; EXIT - - ;; => 0x50 bytes - - ;; : FIND-NAME-LEN 4+ C@ 63 AND ; - - ;; The 0x3f 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. - - (data (i32.const 0x0e30) - "\e0\0d\00\00" - "\0dFIND-NAME-LEN\00\00" - "\00\00\00\00" - "\a8\02\00\00" ;; 4+ - "\fc\03\00\00" ;; C@ - "\18\04\00\00" ;; LIT - "\3f\00\00\00" ;; 63 - "\8c\03\00\00" ;; AND - "\0c\04\00\00") ;; EXIT - - ;; => 0x30 bytes - - ;; 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 $loop - global.get $fn call_indirect (type $codeword) - global.get $run br_if $loop - end) - - (func (export "reset") - i32.const 0x10000 global.set $rsp ;; Set the return stack pointer - i32.const 0xf000 global.set $sp ;; Set the stack pointer - i32.const 0x0bac global.set $ip ;; Set the IP to the cold start - call $next - - i32.const 1 global.set $run - call $trampoline)) diff --git a/wipforth.ws b/wipforth.ws new file mode 100644 index 0000000..2e84e8b --- /dev/null +++ b/wipforth.ws @@ -0,0 +1,2088 @@ +.mem main 1 1 shared +.import main "emu" "mem" + +;; Peripheral registers +.def TXBUF 00h +.def RXBUF 20h +.def TXHEAD 40h +.def TXTAIL 44h +.def RXHEAD 48h +.def RXTAIL 4Ch + +.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 + +;; 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 1Fh + 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 1Fh + 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 + +_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