Create assembler driver script for recording word addresses

This will allow the profiler to sample the current return stack and
instruction pointer.  It can't just use the ip and rsp globals
directly, as I had initially planned, since these cannot be sent
in between threads.

README.md

@@ -1,39 +1,85 @@
 # Wipforth
 
-## Building and Running
+Wipforth is a Forth implementation that runs in the WebAssembly
+virtual machine.  The system is bootstrapped from source on page load:
+the only non-text file is the favicon :)
 
-To run, first compile the WebAssembly module:
+I/O is done via memory-mapped peripherals, which are emulated in
+JavaScript.
+
+- For the Forth kernel, see [wipforth.ws](./wipforth.ws)
+- For the emulator, see [emu.js](./emu.js)
+- For the assembler, see [asm.js](./asm.js)
+- For the prelude (Forth code loaded right after the kernel boots),
+  see [prelude.f](./prelude.f)
+- For a description of the peripherals, see the
+  [Peripherals](#peripherals) section below.
+
+## Building and Running Locally
+
+There's a [Guile](https://www.gnu.org/software/guile/) script in the
+repo you can use for this:
 
 ```
-wat2wasm --enable-threads wipforth.wat
+guile server.scm
-```
-
-Then run the server:
-
-```
-python3 server.py
 ```
 
 You should then be able to open <http://localhost:8080> in a browser
 and use the system from there.
 
-**NOTE**: The server is just a very simple instantiation of Python's
+However, since everything is bootstrapped on the client, basically any
-built-in `http.server.HTTPServer`, configured to set the cross-origin
+HTTP server will do as long as it sets the appropriate response
-headers required for `SharedMemoryBuffer` use.  You could use any HTTP
+headers for `SharedMemoryBuffer` use:
-server that sets these headers.
+
+- `Cross-Origin-Opener-Policy: same-origin`
+- `Cross-Origin-Embedder-Policy: require-corp`
+
+So, if you don't have Guile on your system you can use something else
+like Python's `http.server`.
+
+**NOTE**: You should **definitely not** use `server.scm` to serve the
+application on the open internet or anything like that; I just hacked
+it together for testing on localhost during development and it's
+probably hilariously insecure.
+
+## End-to-End Tests
+
+There's a (fairly minimal at the moment) end-to-end test suite defined
+in [tests.scm](./tests.scm).  To run it you'll need:
+
+- [Guile](https://www.gnu.org/software/guile/) again (no substitute
+  this time, sorry)
+- [guile-json](https://github.com/aconchillo/guile-json)
+- Firefox
+
+I'm also pretty sure it won't work on a non-POSIX system, though I
+haven't tried it.
+
+Given that's all sorted, you should be able to run:
+
+```
+guile tests.scm
+```
+
+It will print a JUnit XML report to standard out.  You can
+pretty-print it with `xmllint` if you have it installed:
+
+```
+guile tests.scm | xmllint --format -
+```
 
 ## Peripherals
 
-# Terminal
+### Terminal
 
-| Name   | Offset | Size / B | Access       |
+| Name   | Address | Size / B | Access       |
-|--------|--------|----------|--------------|
+|--------|---------|----------|--------------|
-| TXBUF  | 0      | 32       | write        |
+| TXBUF  | 00h     | 32       | write        |
-| RXBUF  | 32     | 32       | read         |
+| RXBUF  | 20h     | 32       | read         |
-| TXHEAD | 64     | 1        | atomic read  |
+| TXHEAD | 40h     | 4        | atomic read  |
-| TXTAIL | 65     | 1        | atomic write |
+| TXTAIL | 44h     | 4        | atomic write |
-| RXHEAD | 66     | 1        | atomic write |
+| RXHEAD | 48h     | 4        | atomic write |
-| RXTAIL | 67     | 1        | atomic read  |
+| RXTAIL | 4Ch     | 4        | atomic read  |
 
 For both sending (`TX`) and receiving (`RX`), there are three
 registers: `xBUF`, `xHEAD` and `xTAIL`:
@@ -46,3 +92,12 @@ registers: `xBUF`, `xHEAD` and `xTAIL`:
 In order to be distinguishable from the empty state, the ring buffers
 must never be completely full -- there must always be *at least one*
 unoccupied byte between the tail and the head.
+
+### System status
+
+| Name     | Address | Size / B | Access       |
+|----------|---------|----------|--------------|
+| SYSREADY | 50h     | 1        | atomic write |
+
+The `SYSREADY` register is used to indicate when the system has booted
+up and is ready for user input.

boot.js

@@ -1,7 +1,26 @@
+import { Assembler } from './asm.js';
+
+const assemble = (async () => {
+	const asm = new Assembler();
+	const resp = await fetch('wipforth.ws');
+	for await (const chunk of resp.body) {
+		asm.push(chunk);
+	}
+	return asm.wasm();
+})();
+
 self.onmessage = async (e) => {
-	const exports = { emu: { mem: e.data } };
+	switch (e.data.type) {
-	const mod = await WebAssembly.instantiateStreaming(
+	case "load":
-		fetch('wipforth.wasm'), exports)
+		const exports = { emu: { mem: e.data.mem } };
-	mod.instance.exports.reset();
+		const wasm = await assemble;
-	console.log('System halt');
+		self.mod = await WebAssembly.instantiate(wasm, exports);
+		await self.postMessage('ready');
+		break;
+
+	case "boot":
+		self.mod.instance.exports.reset();
+		console.log('System halt');
+		break;
+	}
 };

deploy-manifest.conf

@@ -0,0 +1,6 @@
+boot.js
+emu.js
+index.html
+prelude.f
+styles.css
+wipforth.ws

e2e/marionette.scm

@@ -0,0 +1,139 @@
+(define-module (e2e marionette)
+  #:export (with-marionette
+			start-firefox
+			close-firefox
+			client-setup
+			client-teardown
+			navigate
+			input-line
+			get-display))
+
+(use-modules
+ (json)
+ (scheme base)
+ (srfi srfi-9))
+
+(define-syntax-rule (with-marionette client body ...)
+  (let ((client #f) (pid #f))
+	(dynamic-wind
+	  (lambda ()
+		(set! pid (start-firefox))
+		(set! client (client-setup)))
+	  (lambda () body ...)
+	  (lambda ()
+		(when client (client-teardown client))
+		(when pid (close-firefox pid))))))
+
+(define (start-firefox)
+  (let* ((profile-dir (mkdtemp "/tmp/marionette-XXXXXX"))
+		 (i/o (pipe))
+		 (pid (spawn "firefox"
+					 `("firefox" "--marionette" "--headless"
+					   "--profile" ,profile-dir "about:blank")
+					 #:output (cdr i/o)
+					 #:error (cdr i/o))))
+	(let loop ((line (read-line (car i/o))))
+	  (cond
+	   ((string-contains line "Listening on port") #nil)
+	   ((eof-object? line) (format #t "EOF when starting firefox~%"))
+	   (#t (loop (read-line (car i/o))))))
+	(close-port (car i/o))
+	(close-port (cdr i/o))
+	pid))
+
+(define (close-firefox pid)
+  (kill pid SIGINT)
+  (waitpid pid)
+  *unspecified*)
+
+(define-record-type client
+  (make-client socket msg-num)
+  client?
+  (socket client-socket)
+  (msg-num client-msg-num client-msg-num-set!))
+
+(define (client-msg-num-1+! client)
+  (client-msg-num-set! client (1+ (client-msg-num client))))
+
+(define (open-socket host port)
+  (let ((sock (socket PF_INET SOCK_STREAM 0))
+		(addr (inet-pton AF_INET host)))
+	(connect sock AF_INET addr port)
+	sock))
+
+(define (handle-start-msg client)
+  (let* ((msg (read-msg (client-socket client)))
+		 (protocol (assoc-ref msg "marionetteProtocol")))
+	(unless (= 3 protocol)
+	  (format #t "Unsupported protocol: ~a~%" protocol))))
+
+(define* (client-setup #:key (host "127.0.0.1") (port 2828))
+  (let ((client (make-client (open-socket host port) 0)))
+	(handle-start-msg client)
+	(create-session client)
+	client))
+
+(define (client-teardown client)
+  (close (client-socket client)))
+
+(define (add-digit val digit)
+  (+ (* val 10) (- digit 48)))
+
+(define (read-msg-len sock)
+  (let loop ((len 0) (byte (read-u8 sock)))
+	(if (eq? byte 58)
+		len
+		(loop (add-digit len byte)
+			  (read-u8 sock)))))
+
+(define (read-msg sock)
+  (let ((len (read-msg-len sock)))
+	(json-string->scm (utf8->string (read-bytevector len sock)))))
+
+(define (send-msg sock msg)
+  (let* ((payload (string->utf8 (scm->json-string msg)))
+		 (len (bytevector-length payload)))
+	(write-bytevector (string->utf8 (number->string len)) sock)
+	(write-u8 58 sock)
+	(write-bytevector payload sock)))
+
+(define (send-command client command params)
+  (send-msg (client-socket client)
+			(vector 0 (client-msg-num client) command params))
+  (client-msg-num-1+! client)
+  (let* ((response (read-msg (client-socket client)))
+		 (error (vector-ref response 2))
+		 (result (vector-ref response 3)))
+	(unless (eq? 'null error)
+	  (format #t "Error: ~a~%" (assoc-ref error "message")))
+	(assoc-ref result "value")))
+
+(define (create-session client)
+  (send-command client "WebDriver:NewSession" '())
+  *unspecified*)
+
+(define (navigate client url)
+  (send-command client "WebDriver:Navigate" `(("url" . ,url)))
+  *unspecified*)
+
+(define (find-element client selector)
+  (assoc-ref
+   (send-command client "WebDriver:FindElement"
+				 `(("using" . "css selector")
+				   ("value" . ,selector)))
+   "element-6066-11e4-a52e-4f735466cecf"))
+
+(define (send-keys client text)
+  (let ((id (find-element client "body")))
+	(send-command client "WebDriver:ElementSendKeys"
+				  `(("id" . ,id) ("text" . ,text)))))
+
+(define (get-element-text client selector)
+  (let ((id (find-element client selector)))
+	(send-command client "WebDriver:GetElementText" `(("id" . ,id)))))
+
+(define (input-line client text)
+  (send-keys client (string-append text "\ue007")))
+
+(define (get-display client)
+  (get-element-text client "#output"))

e2e/testing.scm

@@ -0,0 +1,71 @@
+(define-module (e2e testing)
+  #:export (assert define-test run-tests run-tests-with-cleanup))
+
+(use-modules
+ (sxml simple)
+ (srfi srfi-1))
+
+(define *tests* (make-fluid '()))
+
+(define (assert condition . args)
+  (unless condition
+	(let ((msg (if (null? args) "Assertion failed" (car args))))
+	  (raise-exception `(assertion-failed . ,msg)))))
+
+(define-syntax-rule (define-test name body ...)
+  (fluid-set!
+   *tests*
+   (append (fluid-ref *tests*)
+		   (list (cons 'name (lambda () body ...))))))
+
+(define (fail-handler ex)
+  (if (and (pair? ex) (eq? 'assertion-failed (car ex)))
+	  (cons 'fail (cdr ex))
+	  (cons 'error (format #f "~a" ex))))
+
+(define (run-test test)
+  (cons (car test)
+		(with-exception-handler fail-handler
+		  (lambda ()
+			((cdr test))
+			'pass)
+		  #:unwind? #t)))
+
+(define (fail? result)
+  (and (pair? (cdr result))
+	   (eq? 'fail (cadr result))))
+
+(define (error? result)
+  (and (pair? (cdr result))
+	   (eq? 'error (cadr result))))
+
+(define (test-junit-report result)
+  `(testcase
+	(@ (name ,(symbol->string (car result))))
+	,@(cond
+	   ((fail? result) `((failure (@ (message ,(cddr result))))))
+	   ((error? result) `((error (@ (message ,(cddr result))))))
+	   (#t '()))))
+
+(define (junit-report results fails errors)
+  (let ((count (length results)))
+	`(testsuites
+	  (testsuite
+	   (@ (name "wipforth e2e")
+		  (tests ,count)
+		  (failures ,fails)
+		  (errors ,errors))
+	   ,@(map test-junit-report results)))))
+
+(define (run-tests)
+  (let* ((results (map run-test (fluid-ref *tests*)))
+		 (fails (length (filter fail? results)))
+		 (errors (length (filter error? results))))
+	(sxml->xml (junit-report results fails errors))
+	(exit (if (= (+ fails errors) 0) 0 1))))
+
+(define-syntax-rule (run-tests-with-cleanup body ...)
+  (dynamic-wind
+	(lambda () #f)
+	run-tests
+	(lambda () body ...)))

emu.js

@@ -1,18 +1,19 @@
-const TXBUF = 0;
+const TXBUF = 0x00;
-const RXBUF = 32;
+const RXBUF = 0x20;
-const TXHEAD = 64;
+const TXHEAD = 0x40;
-const TXTAIL = 65;
+const TXTAIL = 0x44;
-const RXHEAD = 66;
+const RXHEAD = 0x48;
-const RXTAIL = 67;
+const RXTAIL = 0x4c;
+const SYSREADY = 0x50;
 
 const TXBUF_SIZE = 32;
 const RXBUF_SIZE = 32;
-const PERIPHS_SIZE = 68;
+const PERIPHS_SIZE = 81;
 
 const POLL_INTERVAL_MS = 20;
+const DOT_INTERVAL_MS = 120;
 
 const COLS = 80;
-const ROWS = 36;
 const TAB_WIDTH = 8;
 
 const CURSOR_IDLE_TIME_MS = 1000;
@@ -27,6 +28,7 @@ class Emulator {
 		this.mem_u8 = new Uint8Array(this.mem.buffer);
 		for (let i = 0; i < PERIPHS_SIZE; ++i)
 			this.mem_u8[i] = 0;
+		this.mem_i32 = new Int32Array(this.mem.buffer);
 
 		this.decoder = new TextDecoder('utf-8');
 		this.encoder = new TextEncoder('utf-8');
@@ -35,8 +37,9 @@ class Emulator {
 		this.rx_queue = [];
 		this.timer = setInterval(() => this.poll(), POLL_INTERVAL_MS);
 
+		this.rows = this.max_rows();
 		this.grid = Array.from(
-			{ length: ROWS },
+			{ length: this.rows },
 			() => new Array(COLS).fill(' '));
 		this.cursor = { x: 0, y: 0 };
 		this.range = {
@@ -44,13 +47,40 @@ class Emulator {
 			end: { x: 0, y: 0 }
 		};
 		this.idle_timer = null;
+		this.input_enable = false;
 		document.addEventListener('keydown', (e) => this.handle_keydown(e));
+		window.addEventListener('resize', () => this.handle_resize());
 
-		this.flush_output();
+		this.prof = new Worker("prof.js");
-		document.getElementById('cursor').classList.add('blinking');
+		this.prof.onmessage = (e) => {
+			const blob = new Blob(
+				[JSON.stringify(e.data)],
+				{ type: "application/json" });
+			const url = URL.createObjectURL(blob);
+			const a = document.createElement("a");
+			a.href = url;
+			a.download = "wipforth-profile.json";
+			a.click();
+			URL.revokeObjectURL(url);
+		};
 
-		this.worker = new Worker('boot.js');
+		this.print("Assembling kernel ");
-		this.worker.postMessage(this.mem);
+		const dots = setInterval(() => this.print("."), DOT_INTERVAL_MS);
+		this.worker = new Worker('boot.js', { type: 'module' });
+		this.worker.postMessage({ type: "load", mem: this.mem });
+		this.worker.onmessage = (e) => {
+			clearInterval(dots);
+			this.print(" done\n");
+			this.worker.postMessage({ type: "boot" });
+			this.prof.postMessage({ type: "start", mem: this.mem });
+		};
+
+		fetch('prelude.f')
+			.then(res => res.text())
+			.then(text => {
+				for (const cu of this.encoder.encode(text))
+					this.rx_queue.push(cu);
+			});
 	}
 
 	poll() {
@@ -65,6 +95,16 @@ class Emulator {
 			if (this.fifo_next(rxtail) != rxhead)
 				this.handle_rx_data(rxhead, rxtail);
 		}
+
+		if (!this.input_enable) {
+			const sysready = Atomics.load(this.mem_u8, SYSREADY);
+			if (sysready != 0) {
+				this.prof.postMessage({ type: "stop" });
+				this.input_enable = true;
+				this.flush_output();
+				document.getElementById('cursor').classList.add('blinking');
+			}
+		}
 	}
 
 	fifo_next(idx) {
@@ -87,6 +127,7 @@ class Emulator {
 			tail = this.fifo_next(tail);
 		} while (this.fifo_next(tail) != head && this.rx_queue.length != 0);
 		Atomics.store(this.mem_u8, RXTAIL, tail);
+		Atomics.notify(this.mem_i32, RXTAIL / 4);
 	}
 
 	print(str) {
@@ -118,12 +159,17 @@ class Emulator {
 	}
 
 	handle_keydown(e) {
+		if (!this.input_enable)
+			return;
+
 		if (e.key.length == 1 && !e.ctrlKey && !e.altKey && !e.metaKey) {
 			this.shift_up(this.cursor);
 			this.grid[this.cursor.y][this.cursor.x] = e.key;
 			this.cursor_move(1, 0);
 		} else if (e.key == 'Enter') {
 			this.cursor.y = this.range.end.y + 1;
+			while (this.cursor.y >= this.rows)
+				this.scroll();
 			this.cursor.x = 0;
 			this.submit_line();
 			Object.assign(this.range.start, this.cursor);
@@ -208,7 +254,7 @@ class Emulator {
 	next_cell(cell) {
 		if (cell.x < COLS - 1)
 			return { x: cell.x + 1, y: cell.y };
-		else if (cell.y < ROWS - 1)
+		else if (cell.y < this.rows - 1)
 			return { x: 0, y: cell.y + 1 };
 		else
 			return null;
@@ -221,6 +267,8 @@ class Emulator {
 			this.grid[cell.y][cell.x] = this.grid[prev.y][prev.x];
 			cell = prev;
 		}
+		if (this.next_cell(this.range.end) == null)
+			this.scroll();
 		this.range.end = this.next_cell(this.range.end);
 	}
 
@@ -239,11 +287,12 @@ class Emulator {
 		const html = this.grid.map((row, y) => {
 			return row.map((c, x) => {
 				const ec = this.html_escape(c);
-				if (x == this.cursor.x && y == this.cursor.y)
+				if (this.input_enable
+					&& x == this.cursor.x && y == this.cursor.y)
 					return '<span id="cursor">' + ec + '</span>';
 				else
 					return ec;
-			}).join('');
+			}).join('').trimEnd();
 		}).join('\n');
 		this.output.innerHTML = html;
 	}
@@ -264,6 +313,38 @@ class Emulator {
 			return c;
 		}
 	}
+
+	scroll() {
+		this.grid.shift()
+		this.grid.push(new Array(COLS).fill(' '));
+		this.cursor.y -= 1;
+		this.range.start.y -= 1;
+		this.range.end.y -= 1;
+	}
+
+	max_rows() {
+		const style = getComputedStyle(this.output);
+		const line_height = parseFloat(style.lineHeight);
+		const margin_top = parseFloat(style.marginTop);
+		const margin_bottom = parseFloat(style.marginBottom);
+
+		const viewport_height = window.innerHeight;
+		const output_height = viewport_height - margin_top - margin_bottom;
+		return Math.floor(output_height / line_height) - 1;
+	}
+
+	handle_resize() {
+		this.rows = this.max_rows();
+		while (this.grid.length < this.rows)
+			this.grid.push(new Array(COLS).fill(' '));
+		while (this.grid.length > this.rows) {
+			this.grid.shift()
+			this.cursor.y -= 1;
+			this.range.start.y -= 1;
+			this.range.end.y -= 1;
+		}
+		this.flush_output();
+	}
 }
 
 window.addEventListener('DOMContentLoaded', () => {

index.html

@@ -3,6 +3,7 @@
   <head>
 	<title>Wipforth</title>
 	<link rel="stylesheet" type="text/css" href="styles.css"/>
+	<link rel="icon" type="image/png" href="favicon.png"/>
   </head>
   <body>
 	<script type="text/javascript" src="emu.js"></script>

prelude.f

@@ -0,0 +1,284 @@
+76 EMIT 111 EMIT 97 EMIT 100 EMIT 105 EMIT 110 EMIT 103 EMIT 32 EMIT
+112 EMIT 114 EMIT 101 EMIT 108 EMIT 117 EMIT 100 EMIT 101 EMIT 32 EMIT
+
+: \ KEY 10 = 0BRANCH [ -20 , ] ; IMMEDIATE \ Now we have line comments :)
+
+\ We'll periodically sprinkle these in so that it's clear to the user
+\ that things are happening.
+46 EMIT
+
+\ Conditionals
+
+: IF
+  LIT 0BRANCH ,
+  HERE @ 0 ,
+; IMMEDIATE
+
+: THEN
+  DUP HERE @ SWAP -
+  SWAP !
+; IMMEDIATE
+
+: ELSE
+  LIT BRANCH ,
+  HERE @ 0 ,
+  SWAP
+  DUP HERE @ SWAP -
+  SWAP !
+; IMMEDIATE
+
+46 EMIT
+
+\ Loops
+
+: BEGIN HERE @ ; IMMEDIATE
+
+: UNTIL
+  LIT 0BRANCH ,
+  HERE @ - ,
+; IMMEDIATE
+
+: AGAIN
+  LIT BRANCH ,
+  HERE @ - ,
+; IMMEDIATE
+
+46 EMIT
+
+\ Recursive calls
+
+: RECURSE LATEST @ >CFA , ; IMMEDIATE
+
+\ Block comments (with nesting)
+
+: (
+  BEGIN
+    KEY DUP
+    40 = IF RECURSE THEN
+    41 =
+  UNTIL
+; IMMEDIATE
+
+( ( Take that, C ) )
+
+46 EMIT
+
+\ Printing utilities
+
+: CR 10 EMIT ;
+: SPACE 32 EMIT ;
+
+: CHAR
+  KEY
+  STATE @ 0<> IF
+	LIT LIT , , \ Append LIT <key> to definition if compiling
+  THEN
+; IMMEDIATE
+
+: EMIT-DIGIT
+  DUP 10 < IF CHAR 0 ELSE 10 - CHAR A THEN
+  + EMIT
+;
+
+CHAR . EMIT
+
+: .
+  \ Handle negatives
+  DUP 0< IF CHAR - EMIT NEGATE THEN
+
+  \ Determine starting place value
+  1 BEGIN BASE @ * 2DUP / 0= UNTIL
+
+  \ Print leading non-zero digits
+  BEGIN
+	BASE @ /
+	2DUP / EMIT-DIGIT
+	TUCK MOD SWAP
+	OVER 0=
+  UNTIL
+
+  \ Print any trailing zeros
+  BASE @ /
+  DUP 0<> IF
+    BEGIN
+      CHAR 0 EMIT
+      BASE @ /
+      DUP 0=
+    UNTIL
+  THEN
+
+  2DROP
+;
+
+CHAR . EMIT
+
+: TYPE ( addr len -- )
+  BEGIN
+	DUP 0= IF 2DROP EXIT THEN
+	SWAP DUP C@ EMIT 1+
+	SWAP 1-
+  AGAIN
+;
+
+CHAR . EMIT
+
+: C, HERE @ C! 1 HERE +! ;
+
+: ."
+  STATE @ IF
+	LIT BRANCH , \ Compile BRANCH for jumping over string data
+	HERE @ 0 ,   \ Compile placeholder offset and push offset cell address
+	0 BEGIN
+	  KEY
+	  DUP CHAR " = IF
+		DROP
+		HERE @ ALIGN HERE !    \ Pad to alignment
+		SWAP DUP HERE @ SWAP - \ Compute offset
+		OVER !                 \ Update branch offset to skip data
+		4+ LIT LIT , ,         \ Append LIT <addr>
+		LIT LIT , ,            \ Append LIT <len>
+		LIT TYPE ,             \ Append TYPE
+		EXIT
+	  THEN
+	  C, 1+       \ Write byte and increment length
+	AGAIN
+  ELSE
+	BEGIN
+	  KEY
+	  DUP CHAR " = IF DROP EXIT THEN
+	  EMIT
+	AGAIN
+  THEN
+; IMMEDIATE
+
+CHAR . EMIT
+
+\ Misc utilities
+
+: NIP SWAP DROP ;
+
+: HEX 16 BASE ! ;
+
+: DECIMAL 10 BASE ! ;
+
+: '
+  WORD FIND DUP 0<> IF
+	>CFA
+  ELSE
+	DROP WNFHOOK EXECUTE
+  THEN
+;
+
+: [COMPILE] ' , ; IMMEDIATE
+
+CHAR . EMIT
+
+\ Constants, variables and values
+
+: CONSTANT
+  WORD CREATE
+  DOCOL ,
+  LIT LIT ,
+  ,
+  LIT EXIT ,
+;
+
+: VARIABLE
+  WORD CREATE
+  DOVAR ,
+  0 ,
+;
+
+: VALUE
+  WORD CREATE
+  DOVAL , ,
+;
+
+: TO
+  ' 4+
+  STATE @ IF
+	LIT LIT , ,
+	LIT ! ,
+  ELSE
+	!
+  THEN
+; IMMEDIATE
+
+CHAR . EMIT
+
+\ Peripheral register addresses
+
+HEX
+
+00 CONSTANT TXBUF
+20 CONSTANT RXBUF
+40 CONSTANT TXHEAD
+44 CONSTANT TXTAIL
+48 CONSTANT RXHEAD
+4C CONSTANT RXTAIL
+50 CONSTANT SYSREADY
+
+DECIMAL
+
+46 EMIT
+
+\ A better word-not-found handler
+
+: ANY-RX? RXHEAD AC@ RXTAIL AC@ <> ;
+
+: WNF-HANDLER
+  ." Unknown word: "
+  WORDBUF SWAP TYPE CR
+  STATE @ IF
+	\ Remove incomplete definition and switch back to interpret mode
+	LATEST @ HERE !
+	LATEST @ @ LATEST !
+	[COMPILE] [
+  THEN
+  \ We only consume to the next newline if there is RX data available,
+  \ because if the offending word was at the end of the line then the
+  \ newline would have already been consumed by WORD.
+  ANY-RX? IF BEGIN KEY 10 = UNTIL THEN
+  QUIT
+;
+
+' WNF-HANDLER TO WNFHOOK
+
+CHAR . EMIT
+
+\ Version number
+
+0 CONSTANT VERSION-MAJOR
+2 CONSTANT VERSION-MINOR
+1 CONSTANT VERSION-PATCH
+
+: PRINT-VERSION
+  CHAR v EMIT VERSION-MAJOR .
+  CHAR . EMIT VERSION-MINOR .
+  CHAR . EMIT VERSION-PATCH .
+;
+
+CHAR . EMIT
+
+\ Welcome banner
+
+: BANNER
+  ."          _            __ " CR
+  ."  _    __(_)__    ___ / / " CR
+  ." | |/|/ / / _ \_ (_-./ _ \" CR
+  ." |__,__/_/ .__(_)___/_//_/" CR
+  ."        /_/               " CR
+  CR
+  ." Wipforth " PRINT-VERSION CR
+  ." Copyright (c) Camden Dixie O'Brien" CR
+  CR
+  ." Wipforth is freely available to use, modify and distribute for personal use" CR
+  ." under the Komorebi license, version 2.0.0." CR
+  CR
+;
+
+."  done" CR
+BANNER
+
+\ Set SYSREADY high to enable user input
+1 SYSREADY AC!

prof.js

@@ -0,0 +1,48 @@
+const INTERVAL_MS = 1;
+const RS_TOP_ADDR = 0x10000;
+const PROF_DATA_ADDR = 0x58;
+const PROF_DATA_IDX = PROF_DATA_ADDR / 8;
+
+let mem_8;
+let mem_64;
+let sampler;
+
+const samples = [];
+
+function sample() {
+	const data = Atomics.load(mem_64, PROF_DATA_IDX);
+	const ip = Number(data & 0xffffffffn);
+	const rsp = Number(data >> 32n);
+	samples.push({ ip, rs_bytes: mem_8.slice(rsp, RS_TOP_ADDR) });
+}
+
+function i32(bytes) {
+	return bytes[0]
+		| (bytes[1] << 8)
+		| (bytes[2] << 16)
+		| (bytes[3] << 24);
+}
+function postproc({ ip, rs_bytes }) {
+	const rs = [];
+	for (let i = 0; i < rs_bytes.length; i += 4)
+		rs.push(i32(rs_bytes.slice(i, i + 4)));
+	rs.reverse();
+	return { ip, rs };
+}
+
+self.onmessage = (e) => {
+	switch (e.data.type) {
+	case "start":
+		console.log("Starting profiler");
+		mem_8 = new Uint8Array(e.data.mem.buffer);
+		mem_64 = new BigUint64Array(e.data.mem.buffer);
+		ip = e.data.ip;
+		rsp = e.data.rsp;
+		sampler = setInterval(sample, INTERVAL_MS);
+		break;
+	case "stop":
+		clearInterval(sample);
+		console.log("Stopped profiler");
+		self.postMessage(samples.map(postproc));
+	}
+};

server.py

@@ -1,16 +0,0 @@
-from http.server import HTTPServer, SimpleHTTPRequestHandler
-import sys
-
-class CORSRequestHandler(SimpleHTTPRequestHandler):
-	def end_headers(self):
-		self.send_header(
-			'Cross-Origin-Opener-Policy', 'same-origin')
-		self.send_header(
-			'Cross-Origin-Embedder-Policy', 'require-corp')
-		self.send_header(
-			'Cache-Control', 'no-store, no-cache, must-revalidate')
-		super().end_headers()
-
-if __name__ == '__main__':
-	server = HTTPServer(('localhost', 8080), CORSRequestHandler)
-	server.serve_forever()

server.scm

@@ -0,0 +1,81 @@
+(define-module (server)
+  #:export (run start stop main))
+
+(use-modules
+ (ice-9 atomic)
+ (ice-9 binary-ports)
+ (ice-9 threads)
+ (srfi srfi-9)
+ (web client)
+ (web server)
+ (web request)
+ (web response)
+ (web uri))
+
+(define mime-types
+  '(("html" . (text/html))
+	("css"  . (text/css))
+	("js"   . (application/javascript))
+	("f"    . (text/plain))
+	("ws"   . (text/plain))
+	("png"  . (image/png))))
+
+(define (mime-type path)
+  (let* ((dot (string-rindex path #\.))
+		 (ext (when dot (substring path (1+ dot)))))
+	(or (assoc-ref mime-types ext) "application/octet-stream")))
+
+(define headers
+  '((cross-origin-opener-policy . "same-origin")
+	(cross-origin-embedder-policy . "require-corp")
+	(cache-control . (no-store no-cache must-revalidate))))
+
+(define (is-dir? path)
+  (eq? 'directory (stat:type (stat path))))
+
+(define (request-path request)
+  (let ((path (string-append "." (uri-path (request-uri request)))))
+	(cond ((not (file-exists? path)) #nil)
+		  ((is-dir? path) (string-append path "index.html"))
+		  (#t path))))
+
+(define (file-handler request body)
+  (let ((path (request-path request)))
+	(if path
+		(values (cons `(content-type . ,(mime-type path)) headers)
+				(get-bytevector-all (open-input-file path)))
+		(values (build-response #:code 404) #f))))
+
+(define* (run #:key (port 8080))
+  (run-server file-handler 'http `(#:port ,port)))
+
+(define-record-type <handle>
+  (make-handle close-flag thread port)
+  handle?
+  (close-flag handle-close-flag)
+  (thread handle-thread)
+  (port handle-port))
+
+(define (serve impl server should-close)
+  (let loop ()
+	(unless (atomic-box-ref should-close)
+	  (serve-one-client file-handler impl server '())
+	  (loop)))
+  (close-server impl server))
+
+(define* (start #:key (port 8080))
+  (let* ((impl (lookup-server-impl 'http))
+		 (server (open-server impl `(#:port ,port)))
+		 (should-close (make-atomic-box #f))
+		 (thread
+		  (call-with-new-thread
+		   (lambda () (serve impl server should-close)))))
+	(make-handle should-close thread port)))
+
+(define (stop handle)
+  (atomic-box-set! (handle-close-flag handle) #t)
+  (http-request (format #f "http://localhost:~a/" (handle-port handle)))
+  (join-thread (handle-thread handle)))
+
+(when (string=? (basename (current-filename)) (car (command-line)))
+  (run))

styles.css

@@ -14,6 +14,7 @@ body {
 }
 
 #output {
+	width: 80ch;
 	margin: 1.5em auto;
 	white-space: pre;
 }

tests.scm

@@ -0,0 +1,52 @@
+(add-to-load-path (dirname (current-filename)))
+
+(use-modules
+ (e2e marionette)
+ (e2e testing)
+ (ice-9 regex)
+ ((server) #:prefix server-)
+ (srfi srfi-1))
+
+(define (lines s)
+  (string-split s #\newline))
+
+(define (get-result-line client)
+  (let ((display (get-display client)))
+	(last (lines (string-trim-right display)))))
+
+(define server (server-start))
+(define firefox (start-firefox))
+(define client (client-setup))
+
+(navigate client "http://localhost:8080")
+(sleep 5)
+
+(define-test kernel-assembles-successfully
+  (let* ((display (get-display client))
+		 (line (first (lines display))))
+	(assert (string-match "Assembling kernel \\.+ done" line)
+			(format #f "Kernel assemble line: ~s" line))))
+
+(define-test prelude-loads-successfully
+  (let* ((display (get-display client))
+		 (line (second (lines display))))
+	(assert (string-match "Loading prelude \\.+ done" line)
+			(format #f "Prelude load line: ~s" line))))
+
+(define-test six-seven-times-dot-cr-yields-42
+  (input-line client "6 7 * . CR")
+  (let* ((result-line (get-result-line client)))
+	(assert (string=? "42" result-line)
+			(format #f "Result line: ~s" result-line))))
+
+(define-test define-hello-then-run-hello-prints-message
+  (input-line client ": HELLO .\" Hello, world!\" CR ;")
+  (input-line client "HELLO")
+  (let* ((result-line (get-result-line client)))
+	(assert (string=? "Hello, world!" result-line)
+			(format #f "Result line: ~s" result-line))))
+
+(run-tests-with-cleanup
+ (client-teardown client)
+ (close-firefox firefox)
+ (server-stop server))

words.js

@@ -0,0 +1,16 @@
+import { Assembler } from "./asm.js";
+
+const asm = new Assembler();
+for await (const chunk of Deno.stdin.readable) {
+	asm.push(chunk);
+}
+asm.wasm();
+
+const defs = Object.entries(asm.defs);
+while (defs[0][0] != '_DUP')
+	defs.shift();
+while (defs.at(-1)[0] != 'WNF_HANDLER')
+	defs.pop();
+const words = Object.fromEntries(defs.filter(([k,v]) => !k.startsWith("_")));
+
+console.log(JSON.stringify(words));