commit 1626ff62eaed70bf452f325c38e3e733855a9ce9 Spenser Truex <truex@equwal.com> 2026-10-04 08:47:28 +0000 Initial import
.github/workflows/ci.yml | 14 +++ LICENSE | 21 ++++ NOTES.md | 122 +++++++++++++++++++ README.md | 55 +++++++++ asm.lisp | 168 ++++++++++++++++++++++++++ build-emu.sh | 16 +++ emu.sh | 14 +++ host.lisp | 143 ++++++++++++++++++++++ kernel.lisp | 270 +++++++++++++++++++++++++++++++++++++++++ lisp.fs | 304 +++++++++++++++++++++++++++++++++++++++++++++++ prelude.scm | 56 +++++++++ test-asm.lisp | 52 ++++++++ test.sh | 18 +++ z80-forth | 14 +++ z80-lisp | 16 +++ 15 files changed, 1283 insertions(+)
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..edda91f --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,14 @@ +name: ci +on: [push, pull_request] +jobs: + layers: + # Builds z80pack (cpmsim + z80asm) from source, then runs all three test layers. + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + with: { path: forthlisp-z80 } + - uses: actions/checkout@v4 + with: { repository: equwal/forthlisp, path: forthlisp } + - run: sudo apt-get update && sudo apt-get install -y sbcl build-essential + - run: cd forthlisp-z80 && sh build-emu.sh + - run: cd forthlisp-z80 && sh test.sh diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..da3111d --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Spenser Truex + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/NOTES.md b/NOTES.md new file mode 100644 index 0000000..c98141e --- /dev/null +++ b/NOTES.md @@ -0,0 +1,122 @@ +# Z80 Forth/Lisp machine + +A Scheme that runs on an emulated Z80 with 64 KiB of address space. Each layer +is built only from the layer below it. + +``` + 4. LISP prelude.scm (Scheme: lists, numbers, let/cond/case/do macros) + lisp.fs (Forth: heap, GC, reader, eval, printer, primitives) + | loaded as source text over the serial console by host.lisp + 3. FORTH kernel.lisp (our own indirect-threaded Forth: inner interpreter, + primitives, dictionary, outer interpreter, compiler, + serial console) + | assembled on the host + 2. SBCL asm.lisp (two-pass Z80 assembler hosted in SBCL) + | writes kernel.mos (Mostek header + bytes, loads at 0000) + 1. Z80 machine code, run by z80pack cpmsim +``` + +No third-party Forth is used. The Lisp is not generated by SBCL: SBCL only +sends `lisp.fs` and `prelude.scm` as text, line by line, and the Z80 Forth +compiles and evaluates them. + +## Layer 2: why a small assembler, not sb-assem + +SBCL's `sb-assem` (`define-instruction`, segments, emitters) is the right +model, and Paul Khuong's breadboard post uses it. But it is wired to the native +backend: instruction formats, registers (TNs), fixups and the disassembler all +belong to the x86-64 VOP machinery, and defining Z80 instructions there means +working inside `SB-VM` internals of one SBCL version. A Z80 needs about 70 +encodings. `asm.lisp` keeps the breadboard style (instructions are Lisp data, +emitters write into a byte vector, Lisp functions act as VOP-like templates: +`code`, `colon`, `flag-code` in `kernel.lisp`) in 170 lines that do not depend +on SBCL internals. + +Syntax: `(ld a (@ hl))`, `(ld (@ ix 3) b)`, `(jp nz loop)`, `(dw docol)`, +bare symbols are labels. `(@ x)` is indirection. + +## Layer 3: the Forth kernel + +- Indirect threaded. BC = IP, SP = data stack, IX = return stack. +- 51 primitives in assembly, 64 colon words threaded at build time by + `compile-tokens` (control flow resolved like a Forth compiler would). +- Words: stack, memory, arithmetic (`um*`, `um/mod`, `d+`), comparisons, + `key emit key?`, `cmove fill s=`, `: ; if else then begin while repeat until + again recurse exit variable constant create ' ['] literal ( \ s" ." char + [char] catch throw words depth bye`. +- Console: z80pack cpmsim TCP console 1, ports 40 (status: bit 0 rx ready, + bit 1 tx ready) and 41 (data). The kernel echoes input; CR, LF or CR LF end + a line; backspace edits. After each line it prints ` ok`. + +## Layer 4: the Scheme + +- One heap object = one 4-byte cell (car, cdr) + a type byte. Pairs, symbols, + closures, primitives, 32-bit integers, strings (list of char codes), + vectors (list of elements), macros. +- Mark-sweep GC. Roots: the symbol list plus a conservative scan of the data + and return stacks. +- Proper tail calls: `eval` is a loop; `if`, `begin`, bodies and closure + calls continue the loop. +- Special forms in Forth: `quote if define set! lambda begin define-macro`. + Everything else (`let let* letrec letrec* named let cond => case and or when + unless do`) is a `define-macro` in `prelude.scm`. An expansion replaces its + call form in place, so each form expands once. +- `(forth)` returns to the Forth prompt; `lisp` re-enters the REPL. + +## Emulator: z80pack cpmsim + +Chosen because it is maintained (release 1.39, 2025), MIT licensed, builds +from source with only a C compiler, runs headless, and has a TCP console built +in (`conf/net_server.conf`), so `PORT` works like QEMU's `-serial tcp:`. It +also ships `z80asm`, the reference assembler for the layer 2 tests. +RunCPM needs a CP/M program and stdio only; MAME is large to build on g. + +`build-emu.sh` clones z80pack to `~/src/z80pack` (tested at 91fd28e) and builds +it with three edits: the named-pipe auxiliary device is off (it needs a +helper and is shared between instances), a stale constant in that code path +is fixed, and a TCP console peer that disconnects is dropped instead of +stopping the CPU (upstream stops with a fatal I/O error; the Lisp launcher +reconnects after loading). + +## Memory map and limits + +| Range | Use | +|---|---| +| 0000-0DDC | kernel image (3549 bytes) | +| 0DDD-E7FF | dictionary: lisp.fs, heap, types, symbol names (`here` = B2FA after load, 13.5 KiB free) | +| E800-EBFF | terminal input buffer: 1023 characters per line | +| EC00-F7FF | return stack, 3 KiB (IX starts at F800) | +| F800-FFFF | data stack, 2 KiB (SP starts at 0000) | + +- Heap: 7000 cells (28000 bytes) + 7000 type bytes. 5129 cells free after the + prelude. `(room)` returns the free count after the last GC. +- Integers: 32-bit signed, boxed; overflow wraps. `quotient`, `remainder`, + `modulo` need a divisor in -32768..32767 (an error otherwise). +- `sqrt` is an integer square root (floor); `floor` is the identity. No + floats, rationals, characters (a char is its code), or `call/cc`. +- One expression may not span lines; a line holds 1023 characters. +- Vectors and strings are lists inside: `vector-ref` is O(n). +- No arity checks on closures; no stack overflow checks (deep non-tail + recursion over about 150 levels can overrun the 3 KiB return stack). +- Macros are not hygienic; expansions use the names `%t %c %k %do`. +- Symbols are never collected. + +## Running + +``` +z80-forth # Forth prompt +z80-lisp # Forth + lisp.fs + prelude.scm, Scheme REPL +PORT=4500 z80-lisp # another TCP port for the emulated console +./test.sh # all three test layers +``` + +## Tests and measured results (2026-10-04) + +| Layer | Test | Result | +|---|---|---| +| 2 assembler | `test-asm.lisp`: every encoding form vs z80pack `z80asm` | 434 passed, 0 failed | +| 3 kernel | `host.lisp test-forth`: kernel words over serial | 45 passed, 0 failed | +| 4 Lisp | `host.lisp test`: `../r7rs-tests.scm` | 205 passed, 0 failed | + +`test.sh` runs all three in 41 s. cpmsim runs unthrottled at about 450 MHz +of emulated Z80 clock. diff --git a/README.md b/README.md new file mode 100644 index 0000000..906b7b2 --- /dev/null +++ b/README.md @@ -0,0 +1,55 @@ +# forthlisp-z80 + +The same four layers as [forthlisp-stm32](https://github.com/equwal/forthlisp-stm32), for a +Z80 with a 64 KiB address space. A Z80 assembler in SBCL builds a Forth kernel written +from scratch, and a Z80-sized Scheme loads through that Forth. No third-party Forth. + +``` + 4 LISP lisp.fs + prelude.scm: a Z80-sized R7RS-small subset, loaded through the console + 3 FORTH kernel.lisp: an indirect-threaded Forth in Z80 assembly + 2 SBCL asm.lisp: a two-pass Z80 assembler in SBCL (test-asm.lisp checks it + against z80pack's z80asm) + 1 ASM Z80 instructions +``` + +## Quickstart + +```sh +git clone https://github.com/equwal/forthlisp # the core, next to this repo +git clone https://github.com/equwal/forthlisp-z80 +cd forthlisp-z80 +./build-emu.sh # fetch and build z80pack cpmsim + z80asm (MIT) in ~/src/z80pack +./z80-forth # the kernel's own prompt +./z80-lisp # Scheme: (+ 1 2) -> 3 +./test.sh # assembler, kernel words, conformance +``` + +Needs SBCL, a C compiler, git and `nc`. Override the tools with `SBCL`, `Z80PACK`, +`CPMSIM`, `Z80ASM`, `NC`, `STTY`. `PORT` picks the emulator's TCP console port. + +## Emulator + +z80pack's `cpmsim` (MIT licence, by Udo Munk) runs headless with its console on a TCP +port. `build-emu.sh` clones it and makes three small build edits, explained in `NOTES.md`. +The emulator is fetched, not vendored. + +## Tests + +- assembler encodings vs `z80asm`; +- kernel words over the console; +- the core's `r7rs-tests.scm`. + +`NOTES.md` gives the counts and every limit: heap size, integer range, line length, +stack depth. + +## Influences + +- Paul Khuong, "SBCL: the ultimate assembly code breadboard" + (https://pvk.ca/Blog/2014/03/15/sbcl-the-ultimate-assembly-code-breadboard/) +- Ron Garret, gll-mag-patch (https://github.com/rongarret/gll-mag-patch) +- Ron Garret, "Lisping at JPL" (https://flownet.com/gat/jpl-lisp.html) + +## Licence + +MIT (see `LICENSE`). z80pack is not part of this repo; `build-emu.sh` downloads it under +its own MIT licence. diff --git a/asm.lisp b/asm.lisp new file mode 100644 index 0000000..7ca1371 --- /dev/null +++ b/asm.lisp @@ -0,0 +1,168 @@ +;;; asm.lisp -- layer 2: a two-pass Z80 assembler hosted in SBCL. +;;; Source is a list of forms: a bare symbol is a label, a list is an +;;; instruction or directive, e.g. (ld a (@ hl)), (jp nz loop), (dw docol). +;;; (@ x) marks memory indirection: (@ hl), (@ ix 3) = (ix+3), (@ var) = (var). +;;; Immediates are numbers, label symbols, or (+ ...) / (- ...) / (lo x) / (hi x). + +(defpackage :z80 (:use :cl) (:export #:assemble #:insn->text)) +(in-package :z80) + +(defvar *labels*) +(defvar *pc*) +(defvar *out*) +(defvar *final* nil "True on pass 2, when every label must resolve.") + +(defun nm (x) (and (symbolp x) (symbol-name x))) +(defun is (x name) (equal (nm x) name)) + +(defparameter +r8+ '("B" "C" "D" "E" "H" "L" nil "A")) +(defparameter +r16+ '("BC" "DE" "HL" "SP")) +(defparameter +cc+ '("NZ" "Z" "NC" "C" "PO" "PE" "P" "M")) +(defparameter +alu+ '("ADD" "ADC" "SUB" "SBC" "AND" "XOR" "OR" "CP")) +(defparameter +rot+ '("RLC" "RRC" "RL" "RR" "SLA" "SRA" nil "SRL")) +(defparameter +simple+ + '(("NOP" #x00) ("RLCA" #x07) ("RRCA" #x0F) ("RLA" #x17) ("RRA" #x1F) + ("CPL" #x2F) ("SCF" #x37) ("CCF" #x3F) ("HALT" #x76) ("DI" #xF3) ("EI" #xFB) + ("RET" #xC9) ("EXX" #xD9) ("NEG" #xED #x44) ("LDIR" #xED #xB0) + ("LDDR" #xED #xB8) ("CPIR" #xED #xB1))) + +(defun r8 (x) + "Register code 0-7 of X, (@ hl) being 6, or NIL." + (cond ((and (consp x) (is (car x) "@") (is (cadr x) "HL") (null (cddr x))) 6) + ((symbolp x) (position (nm x) +r8+ :test #'equal)))) +(defun r16 (x &optional (list +r16+)) (and (symbolp x) (position (nm x) list :test #'equal))) +(defun ixd (x) "Displacement of (@ ix d), or NIL." + (and (consp x) (is (car x) "@") (is (cadr x) "IX") (or (caddr x) 0))) +(defun mem (x) "Address expression of (@ expr), or NIL." + (and (consp x) (is (car x) "@") (not (r16 (cadr x) '("HL" "BC" "DE" "SP" "IX"))) (cadr x))) +(defun imm-p (x) (or (integerp x) (and (symbolp x) (not (r8 x)) (not (r16 x '("BC" "DE" "HL" "SP" "IX" "AF")))) + (and (consp x) (not (is (car x) "@"))))) + +(defun value (x) + (cond ((integerp x) x) + ((characterp x) (char-code x)) + ((symbolp x) (or (gethash x *labels*) + (if *final* (error "undefined label ~s" x) 0))) + ((is (car x) "+") (reduce #'+ (mapcar #'value (cdr x)))) + ((is (car x) "-") (apply #'- (mapcar #'value (cdr x)))) + ((is (car x) "LO") (logand (value (cadr x)) 255)) + ((is (car x) "HI") (logand (ash (value (cadr x)) -8) 255)) + (t (error "bad expression ~s" x)))) + +(defun b (&rest bytes) (dolist (x bytes) (vector-push-extend (logand x 255) *out*) (incf *pc*))) +(defun w (x) (let ((v (value x))) (b v (ash v -8)))) +(defun d8 (x) (let ((v (value x))) + (when (and *final* (not (<= -128 v 127))) (error "displacement ~d out of range" v)) v)) +(defun rel (x) (let ((v (- (value x) (+ *pc* 1)))) + (when (and *final* (not (<= -128 v 127))) (error "jr to ~s out of range" x)) v)) + +(defun insn (form) + (let* ((op (nm (car form))) (x (cadr form)) (y (caddr form)) (n (length (cdr form)))) + (macrolet ((when-match (test &body body) `(when ,test ,@body (return-from insn)))) + (let ((s (assoc op +simple+ :test #'equal))) + (when-match (and s (= n 0)) (apply #'b (cdr s)))) + (cond + ((equal op "DB") (when-match t (dolist (v (cdr form)) (if (stringp v) (map nil (lambda (c) (b (char-code c))) v) (b (value v)))))) + ((equal op "DW") (when-match t (mapc #'w (cdr form)))) + ((equal op "LD") + (let ((rx (r8 x)) (ry (r8 y))) + (when-match (and rx ry (not (= rx ry 6))) (b (+ #x40 (* 8 rx) ry))) + (when-match (and rx (ixd y)) (b #xDD (+ #x46 (* 8 rx)) (d8 (ixd y)))) + (when-match (and (ixd x) ry) (b #xDD (+ #x70 ry) (d8 (ixd x)))) + (when-match (and (ixd x) (imm-p y)) (b #xDD #x36 (d8 (ixd x)) (value y))) + (when-match (and (is x "A") (consp y) (is (car y) "@") (is (cadr y) "BC")) (b #x0A)) + (when-match (and (is x "A") (consp y) (is (cadr y) "DE") (is (car y) "@")) (b #x1A)) + (when-match (and (is y "A") (consp x) (is (cadr x) "BC") (is (car x) "@")) (b #x02)) + (when-match (and (is y "A") (consp x) (is (cadr x) "DE") (is (car x) "@")) (b #x12)) + (when-match (and (is x "A") (mem y)) (b #x3A) (w (mem y))) + (when-match (and (is y "A") (mem x)) (b #x32) (w (mem x))) + (when-match (and rx (imm-p y)) (b (+ #x06 (* 8 rx)) (value y))) + (when-match (and (is x "SP") (is y "HL")) (b #xF9)) + (when-match (and (is x "SP") (is y "IX")) (b #xDD #xF9)) + (when-match (and (is x "IX") (imm-p y)) (b #xDD #x21) (w y)) + (when-match (and (is x "IX") (mem y)) (b #xDD #x2A) (w (mem y))) + (when-match (and (is y "IX") (mem x)) (b #xDD #x22) (w (mem x))) + (when-match (and (is x "HL") (mem y)) (b #x2A) (w (mem y))) + (when-match (and (is y "HL") (mem x)) (b #x22) (w (mem x))) + (when-match (and (r16 x) (mem y)) (b #xED (+ #x4B (* 16 (r16 x)))) (w (mem y))) + (when-match (and (r16 y) (mem x)) (b #xED (+ #x43 (* 16 (r16 y)))) (w (mem x))) + (when-match (and (r16 x) (imm-p y)) (b (+ #x01 (* 16 (r16 x)))) (w y)))) + ((member op '("PUSH" "POP") :test #'equal) + (let ((base (if (equal op "PUSH") #xC5 #xC1))) + (when-match (is x "IX") (b #xDD (+ base #x20))) + (when-match t (b (+ base (* 16 (r16 x '("BC" "DE" "HL" "AF")))))))) + ((member op +alu+ :test #'equal) + (let* ((k (position op +alu+ :test #'equal)) + (src (if (and (= n 2) (is x "A")) y (if (= n 1) x nil)))) + (when-match (and (= n 2) (is x "HL") (r16 y)) + (case k (0 (b (+ #x09 (* 16 (r16 y))))) (1 (b #xED (+ #x4A (* 16 (r16 y))))) + (3 (b #xED (+ #x42 (* 16 (r16 y))))) (t (error "bad ~s" form)))) + (when-match (and (= n 2) (is x "IX") (= k 0)) + (b #xDD (+ #x09 (* 16 (r16 y '("BC" "DE" "IX" "SP")))))) + (when-match (and src (r8 src)) (b (+ #x80 (* 8 k) (r8 src)))) + (when-match (and src (ixd src)) (b #xDD (+ #x86 (* 8 k)) (d8 (ixd src)))) + (when-match (and src (imm-p src)) (b (+ #xC6 (* 8 k)) (value src))))) + ((member op '("INC" "DEC") :test #'equal) + (let ((dec (equal op "DEC"))) + (when-match (is x "IX") (b #xDD (if dec #x2B #x23))) + (when-match (ixd x) (b #xDD (if dec #x35 #x34) (d8 (ixd x)))) + (when-match (r8 x) (b (+ (if dec 5 4) (* 8 (r8 x))))) + (when-match (r16 x) (b (+ (if dec #x0B #x03) (* 16 (r16 x))))))) + ((equal op "JP") + (when-match (and (consp x) (is (cadr x) "HL")) (b #xE9)) + (when-match (and (consp x) (is (cadr x) "IX")) (b #xDD #xE9)) + (when-match (= n 2) (b (+ #xC2 (* 8 (r16 x +cc+)))) (w y)) + (when-match t (b #xC3) (w x))) + ((equal op "CALL") + (when-match (= n 2) (b (+ #xC4 (* 8 (r16 x +cc+)))) (w y)) + (when-match t (b #xCD) (w x))) + ((equal op "RET") (when-match t (b (+ #xC0 (* 8 (r16 x +cc+)))))) + ((equal op "JR") + (when-match (= n 2) (b (+ #x20 (* 8 (r16 x '("NZ" "Z" "NC" "C"))))) (b (rel y))) + (when-match t (b #x18) (b (rel x)))) + ((equal op "DJNZ") (when-match t (b #x10) (b (rel x)))) + ((equal op "RST") (when-match t (b (+ #xC7 (value x))))) + ((equal op "EX") + (when-match (is x "DE") (b #xEB)) + (when-match (and (consp x) (is y "HL")) (b #xE3)) + (when-match (and (consp x) (is y "IX")) (b #xDD #xE3)) + (when-match (is x "AF") (b #x08))) + ((equal op "IN") (when-match (is x "A") (b #xDB (value (mem y))))) + ((equal op "OUT") (when-match (is y "A") (b #xD3 (value (mem x))))) + ((member op +rot+ :test #'equal) + (when-match (r8 x) (b #xCB (+ (* 8 (position op +rot+ :test #'equal)) (r8 x))))) + ((member op '("BIT" "RES" "SET") :test #'equal) + (when-match (r8 y) (b #xCB (+ (* 64 (1+ (position op '("BIT" "RES" "SET") :test #'equal))) + (* 8 (value x)) (r8 y)))))) + (error "cannot assemble ~s" form)))) + +(defun assemble (forms) + "Assemble FORMS at address 0. Return the byte vector and the label table." + (let ((*labels* (make-hash-table))) + (dolist (*final* '(nil t)) + (let ((*pc* 0) (*out* (make-array 0 :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0))) + (dolist (f forms) + (cond ((symbolp f) + (when (and (not *final*) (gethash f *labels*)) (error "duplicate label ~s" f)) + (setf (gethash f *labels*) *pc*)) + ((is (car f) "EQU") (setf (gethash (cadr f) *labels*) (value (caddr f)))) + (t (insn f)))) + (when *final* (return-from assemble (values (coerce *out* '(simple-array (unsigned-byte 8) (*))) *labels*))))))) + +;;; Standard-syntax printer, so the reference assembler can check our bytes. +(defun opnd->text (x) + (cond ((and (consp x) (is (car x) "@")) + (if (and (is (cadr x) "IX") (cddr x)) (format nil "(ix+~d)" (caddr x)) (format nil "(~a)" (opnd->text (cadr x))))) + ((consp x) (format nil "~{~a~^~a~}" (cdr (loop for a in (cdr x) collect (car x) collect (opnd->text a))))) + ((stringp x) (format nil "'~a'" x)) + ((is x "AF") "af") + ((symbolp x) (string-downcase (nm x))) + (t (princ-to-string x)))) +(defun insn->text (form) + (let ((op (string-downcase (nm (car form))))) + (cond ((and (equal op "ex") (is (cadr form) "AF")) "ex af,af'") + ((member op '("add" "adc" "sbc") :test #'equal) + (format nil "~a ~{~a~^,~}" op (mapcar #'opnd->text (if (= (length form) 2) (list 'a (cadr form)) (cdr form))))) + ((equal op "dw") (format nil "defw ~{~a~^,~}" (mapcar #'opnd->text (cdr form)))) + ((equal op "db") (format nil "defb ~{~a~^,~}" (mapcar #'opnd->text (cdr form)))) + (t (format nil "~a ~{~a~^,~}" op (mapcar #'opnd->text (cdr form))))))) diff --git a/build-emu.sh b/build-emu.sh new file mode 100755 index 0000000..14eecf0 --- /dev/null +++ b/build-emu.sh @@ -0,0 +1,16 @@ +#!/bin/sh +# build-emu.sh -- fetch and build the z80pack cpmsim emulator (MIT licence) and its +# z80asm reference assembler in ~/src/z80pack. Named pipes for the auxiliary device +# are switched off: they need a cpmrecv helper and are shared between instances. +set -e +Z=${Z80PACK:-$HOME/src/z80pack} +[ -d "$Z" ] || git clone --depth 1 https://github.com/udo-munk/z80pack.git "$Z" +sed -i 's|^#define PIPES|/* #define PIPES */|' "$Z/cpmsim/srcsim/sim.h" +# upstream's no-PIPES path still names the old constant STOPPED +sed -i 's/= STOPPED;/= ST_STOPPED;/' "$Z/cpmsim/srcsim/simio.c" +# a TCP console peer that disconnects (read returns 0) stops the CPU with a fatal I/O +# error upstream; drop the connection instead, so the next one can attach +sed -i 's/if ((errno == EAGAIN) || (errno == EINTR)) {/if (1) { \/* peer gone: drop it *\//' "$Z/cpmsim/srcsim/simio.c" +(cd "$Z/cpmsim/srcsim" && nice make clean >/dev/null && nice make >/dev/null) +(cd "$Z/z80asm" && nice make >/dev/null) +echo "built $Z/cpmsim/cpmsim and $Z/z80asm/z80asm ($(git -C "$Z" rev-parse --short HEAD))" diff --git a/emu.sh b/emu.sh new file mode 100755 index 0000000..0032c84 --- /dev/null +++ b/emu.sh @@ -0,0 +1,14 @@ +#!/bin/sh +# emu.sh IMAGE -- run the Z80 image in z80pack cpmsim, console on TCP 127.0.0.1:$PORT. +# Prints the emulator PID. The kernel waits for a connection before it prints its banner. +set -e +CPMSIM=${CPMSIM:-${Z80PACK:-$HOME/src/z80pack}/cpmsim/cpmsim} +PORT=${PORT:-4455} +IMG=$(cd "$(dirname "$1")" && pwd)/$(basename "$1") +RUN=/tmp/z80emu-$PORT # cpmsim reads ./conf/net_server.conf +mkdir -p "$RUN/conf" +printf '1 0 %s\n' "$PORT" > "$RUN/conf/net_server.conf" # console 1, no telnet, TCP port +cd "$RUN" +# -x loads the image (Mostek header: load at 0000). +"$CPMSIM" -x "$IMG" </dev/null >"$RUN/log" 2>&1 & +echo $! diff --git a/host.lisp b/host.lisp new file mode 100644 index 0000000..446537a --- /dev/null +++ b/host.lisp @@ -0,0 +1,143 @@ +;;; host.lisp -- serial driver for the Z80 Forth running in cpmsim (console on TCP). +;;; Run: PORT=n sbcl --script host.lisp COMMAND +;;; load send lisp.fs to the Forth, enter the Lisp, send prelude.scm +;;; test-forth kernel word tests over serial (fresh kernel expected) +;;; test [FILE] load, then run the R7RS subset (default ../r7rs-tests.scm), print pass counts +;;; eval EXPR load, then print the value of each EXPR +(require :sb-bsd-sockets) +(defpackage :z80host (:use :cl)) +(in-package :z80host) + +(defvar *dir* (directory-namestring *load-truename*)) +(defvar *io*) +(defvar *log* nil "Echo the conversation to stdout.") + +(defun connect () + (let ((port (parse-integer (or (sb-ext:posix-getenv "PORT") "4455")))) + (loop repeat 100 + do (handler-case + (let ((s (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) + (sb-bsd-sockets:socket-connect s #(127 0 0 1) port) + (setf *io* (sb-bsd-sockets:socket-make-stream s :input t :output t :element-type 'character + :external-format :latin-1 :buffering :full)) + (return-from connect)) + (error () (sleep 0.1)))) + (error "no emulator on port ~d" port))) + +(defun read-until (done-p) + "Read characters until (DONE-P text) is true; return the text." + (let ((buf (make-array 0 :element-type 'character :adjustable t :fill-pointer 0))) + (loop for c = (read-char *io*) + do (vector-push-extend c buf) (when *log* (write-char c) (finish-output)) + until (funcall done-p buf)) + (coerce buf 'simple-string))) + +(defun ends-with (s suffix) + (let ((n (length s)) (m (length suffix))) + (and (>= n m) (string= s suffix :start1 (- n m))))) + +(defun send (line) + (write-string line *io*) (write-char #\Return *io*) (finish-output *io*)) + +(defun strip-echo (text) + "Drop the echoed input line: everything up to the first CR LF." + (let ((p (search (coerce '(#\Return #\Newline) 'string) text))) + (if p (subseq text (+ p 2)) text))) + +(defun forth (line) + "Send one Forth line; return its output and whether it ended in ok." + (send line) + (let* ((out (read-until (lambda (b) (and (ends-with b (coerce '(#\Return #\Newline) 'string)) + (let ((l (string-right-trim '(#\Return #\Newline) b))) + (or (ends-with l " ok") (ends-with l " ?") (search " error " l))))))) + (body (string-right-trim '(#\Return #\Newline) out))) + (values (string-trim " " (subseq body (min (length line) (length body)) + (if (ends-with body " ok") (- (length body) 3) (length body)))) + (ends-with body " ok")))) + +(defparameter +prompt+ (coerce '(#\Return #\Newline #\> #\Space) 'string)) + +(defun lisp (line) + "Send one Lisp line; return what it printed." + (send line) + (let ((out (read-until (lambda (b) (ends-with b +prompt+))))) + (strip-echo (subseq out 0 (- (length out) (length +prompt+)))))) + +(defun file-lines (name) + (with-open-file (s (merge-pathnames name *dir*)) + (loop for l = (read-line s nil) while l collect l))) + +(defun load-target () + (read-until (lambda (b) (ends-with b (format nil "Forth~c~c" #\Return #\Newline)))) + (dolist (l (file-lines "lisp.fs")) + (unless (or (string= (string-trim " " l) "") (eql 0 (search "\\ " l))) + (multiple-value-bind (out ok) (forth l) + (unless ok (error "lisp.fs: ~a~% -> ~a" l out))))) + (send "lisp") + (read-until (lambda (b) (ends-with b +prompt+))) + (dolist (l (file-lines "prelude.scm")) + (unless (or (string= (string-trim " " l) "") (char= (char l 0) #\;)) + (let ((out (lisp l))) + (when (search "error:" out) (error "prelude.scm: ~a~% -> ~a" l out)))))) + +;;; ---- tests + +(defparameter *forth-tests* + '(("1 2 + ." "3") ("7 2 - ." "5") ("-3 4 * ." "-12") ("100 0 7 um/mod . ." "14 2") + ("65535 2 um* . ." "1 -2") ("5 negate ." "-5") ("6 2/ . -6 2/ ." "3 -3") + ("1 2 swap . ." "1 2") ("1 2 over . . ." "1 2 1") ("1 2 3 rot . . ." "1 3 2") ("1 2 nip ." "2") + ("3 dup * ." "9") ("1 2 drop ." "1") ("1 2 2dup . . . ." "2 1 2 1") + ("1 2 = . 2 2 = ." "0 -1") ("1 2 < . 2 1 < . -1 1 < ." "-1 0 -1") ("-1 1 u< ." "0") ("0 0= . 5 0= ." "-1 0") + ("-5 0< . 5 0< ." "-1 0") ("12 10 and . 12 10 or . 12 10 xor ." "8 14 6") ("0 invert ." "-1") + ("variable v 42 v ! v @ ." "42") ("5 v +! v @ ." "47") ("65 v c! v c@ ." "65") + ("7 constant seven seven ." "7") (": sq dup * ; 12 sq ." "144") + (": f if 1 else 2 then ; 0 f . 5 f ." "2 1") + (": cnt 0 begin dup 5 < while 1+ repeat ; cnt ." "5") + (": cd 3 begin dup . 1- dup 0= until drop ; cd" "3 2 1") + (": fact dup 1 > if dup 1- recurse * then ; 7 fact ." "5040") + ("1 2 3 depth . drop drop drop" "3") ("1 >r r@ r> . ." "1 1") + (": hi .\" hello\" ; hi" "hello") ("char A ." "65") (": c [char] B ; c ." "66") + ("3 ' sq execute ." "9") ("1 2 3 2 pick . drop drop drop" "1") + (": t 7 throw ; ' t catch ." "7") ("1 2 ' + catch . ." "0 3") + ("5 0 1 0 d+ . ." "0 6") ("s\" abc\" drop s\" abc\" drop 3 s= ." "-1") + ("here 10 allot here swap - ." "10") ("frobnicate" "frobnicate ?") + ("( a comment ) 4 ." "4") ("4 . \\ the rest is ignored" "4"))) + +(defun test-forth () + (read-until (lambda (b) (ends-with b (format nil "Forth~c~c" #\Return #\Newline)))) + (let ((pass 0) (fail 0)) + (loop for (in want) in *forth-tests* + for got = (forth in) + do (if (string= got want) (incf pass) + (progn (incf fail) (format t "FAIL ~a~% want ~s~% got ~s~%" in want got)))) + (format t "forth kernel: ~d passed, ~d failed, ~d total~%" pass fail (+ pass fail)) + fail)) + +(defun conformance (file) + (let ((pass 0) (fail 0)) + (dolist (l (with-open-file (s file) (loop for l = (read-line s nil) while l collect l))) + (unless (or (string= (string-trim " " l) "") (char= (char l 0) #\;)) + (let* ((p (search "==>" l)) + (expr (string-trim " " (if p (subseq l 0 p) l))) + (got (string-trim " " (lisp expr)))) + (cond ((search "error:" got) (incf fail) (format t "FAIL ~a~% got ~a~%" expr got)) + ((null p) (incf pass)) + ((string= got (string-trim " " (subseq l (+ p 3)))) (incf pass)) + (t (incf fail) (format t "FAIL ~a~% want ~a~% got ~a~%" expr (string-trim " " (subseq l (+ p 3))) got)))))) + (format t "conformance: ~d passed, ~d failed, ~d total~%" pass fail (+ pass fail)) + fail)) + +(defun main (args) + (let ((cmd (first args))) + (connect) + (cond ((equal cmd "load") (load-target)) + ((equal cmd "test-forth") (sb-ext:exit :code (if (zerop (test-forth)) 0 1))) + ((equal cmd "test") + (load-target) + (sb-ext:exit :code (if (zerop (conformance (or (second args) (merge-pathnames "../r7rs-tests.scm" *dir*)))) 0 1))) + ((equal cmd "eval") (load-target) (dolist (e (rest args)) (format t "~a~%" (lisp e)))) + (t (format t "usage: host.lisp load | test-forth | test [FILE] | eval EXPR...~%"))))) + +(handler-case (main (cdr sb-ext:*posix-argv*)) + (sb-sys:interactive-interrupt () (sb-ext:exit :code 130)) + (error (e) (format t "~&FAILED: ~a~%" e) (sb-ext:exit :code 1))) diff --git a/kernel.lisp b/kernel.lisp new file mode 100644 index 0000000..1f4b12f --- /dev/null +++ b/kernel.lisp @@ -0,0 +1,270 @@ +;;; kernel.lisp -- layer 3: the Forth kernel, as data for asm.lisp. +;;; Indirect-threaded. BC = IP, SP = data stack, IX = return stack, HL/DE/A scratch. +;;; Header: link(2) | flags+len(1) | name | CFA(2) | body. Flags: #x80 immediate, #x40 hidden. +;;; Run: sbcl --script kernel.lisp OUT.mos writes the image with a Mostek header (load at 0). +(load (merge-pathnames "asm.lisp" *load-truename*)) +(in-package :z80) + +;;; Memory map (64 KiB): image + dictionary 0000-E7FF, TIB E800-EBFF, +;;; return stack EC00-F7FF (IX starts at F800), data stack F800-FFFF (SP starts at 0000). +(defconstant +tib+ #xE800) +(defconstant +tib-size+ 1023) +(defconstant +r0+ #xF800) +(defconstant +console-status+ 40) ; z80pack cpmsim: TCP console 1 status (bit0 rx, bit1 tx) +(defconstant +console-data+ 41) + +(defvar *forms* '()) +(defvar *link* 0) +(defvar *current* nil) +(defun emit (&rest forms) (dolist (f forms) (push f *forms*))) +(defun wlabel (name) (intern (format nil "W:~a" name) :z80)) +(defun name-of (x) (if (stringp x) x (string-downcase (symbol-name x)))) + +(defun header (name &optional immediate) + (let ((hdr (gensym "HDR"))) + (setf *current* name) + (emit hdr `(dw ,*link*) `(db ,(+ (length name) (if immediate #x80 0))) `(db ,name) (wlabel name)) + (setf *link* hdr))) + +(defun code (name &rest asm) + "A primitive: CFA points at the code that follows it." + (let ((body (gensym "CODE"))) + (header (name-of name)) + (emit `(dw ,body) body) + (apply #'emit asm) + (emit '(jp next)))) + +(defun compile-tokens (tokens) + "Thread TOKENS, resolving control words at build time like a Forth compiler would." + (let ((cs '())) + (dolist (tk tokens) + (let ((s (and (symbolp tk) (symbol-name tk)))) + (flet ((label () (let ((l (gensym "L"))) (emit l) l)) + (fwd (op) (let ((l (gensym "F"))) (emit `(dw ,(wlabel op) ,l)) l))) + (cond ((integerp tk) (emit `(dw ,(wlabel "lit") ,(logand tk #xFFFF)))) + ((equal s "IF") (push (fwd "0branch") cs)) + ((equal s "ELSE") (let ((f (fwd "branch"))) (emit (pop cs)) (push f cs))) + ((equal s "THEN") (emit (pop cs))) + ((equal s "BEGIN") (push (label) cs)) + ((equal s "WHILE") (let ((f (fwd "0branch"))) (push f (cdr cs)))) + ((equal s "REPEAT") (emit `(dw ,(wlabel "branch") ,(pop cs))) (emit (pop cs))) + ((equal s "UNTIL") (emit `(dw ,(wlabel "0branch") ,(pop cs)))) + ((equal s "AGAIN") (emit `(dw ,(wlabel "branch") ,(pop cs)))) + ((equal s "RECURSE") (emit `(dw ,(wlabel *current*)))) + ((and (consp tk) (eq (car tk) 'quote)) (emit `(dw ,(wlabel "lit") ,(wlabel (name-of (cadr tk)))))) + ((and (consp tk) (symbolp (car tk)) (equal (symbol-name (car tk)) "ADDR")) (emit `(dw ,(wlabel "lit") ,(cadr tk)))) + ((and (consp tk) (member (car tk) '("s\"" ".\"") :test #'equal)) + (emit `(dw ,(wlabel "(s\")")) `(db ,(length (cadr tk))) `(db ,(cadr tk))) + (when (equal (car tk) ".\"") (emit `(dw ,(wlabel "type"))))) + (t (emit `(dw ,(wlabel (name-of tk))))))))) + (when cs (error "unbalanced control flow in ~a" *current*)))) + +(defun xt (name) (list 'quote name)) +(defun dq (s) (list ".\"" s)) +(defun colon (name &rest tokens) + (let ((imm (eq (car tokens) :immediate))) + (header (name-of name) imm) + (emit '(dw docol)) + (compile-tokens (if imm (cdr tokens) tokens)) + (emit `(dw ,(wlabel "exit"))))) + +(defun var (name &optional (init 0)) + (header (name-of name)) (emit '(dw dovar) `(dw ,init))) +(defun const (name value) + (header (name-of name)) (emit '(dw docon) `(dw ,value))) + +(defun flag-code (test) + "Push -1 when the condition jump TEST (e.g. z, c) is taken, else 0." + (let ((l (gensym))) + `((ld hl 0) (jr ,(if (eq test 'z) 'nz 'nc) ,l) (dec hl) ,l (push hl)))) + +(defun build () + (setf *forms* '() *link* 0) + ;; boot and inner interpreter + (emit '(jp start) + 'next '(ld a (@ bc)) '(ld l a) '(inc bc) '(ld a (@ bc)) '(ld h a) '(inc bc) + '(ld e (@ hl)) '(inc hl) '(ld d (@ hl)) '(inc hl) '(ex de hl) '(jp (@ hl)) + 'docol '(dec ix) '(ld (@ ix 0) b) '(dec ix) '(ld (@ ix 0) c) '(ld b d) '(ld c e) '(jp next) + 'dovar '(push de) '(jp next) + 'docon '(ex de hl) '(ld e (@ hl)) '(inc hl) '(ld d (@ hl)) '(push de) '(jp next) + 'ipsave '(dw 0) + 'start `(ld sp 0) `(ld ix ,+r0+) '(ld bc cold) '(jp next) + 'cold `(dw ,(wlabel "cold"))) + ;; primitives + (code 'exit '(ld c (@ ix 0)) '(inc ix) '(ld b (@ ix 0)) '(inc ix)) + (code 'lit '(ld a (@ bc)) '(ld l a) '(inc bc) '(ld a (@ bc)) '(ld h a) '(inc bc) '(push hl)) + (code 'branch 'branch '(ld a (@ bc)) '(ld l a) '(inc bc) '(ld a (@ bc)) '(ld b a) '(ld c l)) + (code '0branch '(pop hl) '(ld a h) '(or l) '(jr z branch) '(inc bc) '(inc bc)) + (header "execute") (emit '(dw execute) 'execute '(pop hl) '(ld e (@ hl)) '(inc hl) '(ld d (@ hl)) '(inc hl) '(ex de hl) '(jp (@ hl))) + (code 'dup '(pop hl) '(push hl) '(push hl)) + (code 'drop '(pop hl)) + (code 'swap '(pop hl) '(ex (@ sp) hl) '(push hl)) + (code 'over '(pop hl) '(pop de) '(push de) '(push hl) '(push de)) + (code 'rot '(pop de) '(pop hl) '(ex (@ sp) hl) '(push de) '(push hl)) + (code 'nip '(pop hl) '(pop de) '(push hl)) + (code '>r '(pop hl) '(dec ix) '(ld (@ ix 0) h) '(dec ix) '(ld (@ ix 0) l)) + (code 'r> '(ld l (@ ix 0)) '(inc ix) '(ld h (@ ix 0)) '(inc ix) '(push hl)) + (code 'r@ '(ld l (@ ix 0)) '(ld h (@ ix 1)) '(push hl)) + (code 'sp@ '(ld hl 0) '(add hl sp) '(push hl)) + (code 'sp! '(pop hl) '(ld sp hl)) + (code 'rp@ '(push ix)) + (code 'rp! '(pop ix)) + (code 'pick '(pop hl) '(add hl hl) '(add hl sp) '(ld e (@ hl)) '(inc hl) '(ld d (@ hl)) '(push de)) + (code '@ '(pop hl) '(ld e (@ hl)) '(inc hl) '(ld d (@ hl)) '(push de)) + (code '! '(pop hl) '(pop de) '(ld (@ hl) e) '(inc hl) '(ld (@ hl) d)) + (code 'c@ '(pop hl) '(ld l (@ hl)) '(ld h 0) '(push hl)) + (code 'c! '(pop hl) '(pop de) '(ld (@ hl) e)) + (code '+! '(pop hl) '(pop de) '(ld a (@ hl)) '(add a e) '(ld (@ hl) a) '(inc hl) '(ld a (@ hl)) '(adc a d) '(ld (@ hl) a)) + (code '+ '(pop hl) '(pop de) '(add hl de) '(push hl)) + (code '- '(pop de) '(pop hl) '(or a) '(sbc hl de) '(push hl)) + (dolist (op '(and or xor)) + (code op '(pop hl) '(pop de) '(ld a l) (list op 'e) '(ld l a) '(ld a h) (list op 'd) '(ld h a) '(push hl))) + (code 'd+ '(ld (@ ipsave) bc) '(pop bc) '(pop de) '(pop hl) '(ex (@ sp) hl) '(add hl de) '(ex (@ sp) hl) '(adc hl bc) '(push hl) '(ld bc (@ ipsave))) + (code 'invert '(pop hl) '(ld a l) '(cpl) '(ld l a) '(ld a h) '(cpl) '(ld h a) '(push hl)) + (code 'negate '(pop de) '(ld hl 0) '(or a) '(sbc hl de) '(push hl)) + (code '2* '(pop hl) '(add hl hl) '(push hl)) + (code '2/ '(pop hl) '(sra h) '(rr l) '(push hl)) + (code 'u2/ '(pop hl) '(srl h) '(rr l) '(push hl)) + (code '1+ '(pop hl) '(inc hl) '(push hl)) + (code '1- '(pop hl) '(dec hl) '(push hl)) + (apply #'code '= '(pop hl) '(pop de) '(or a) '(sbc hl de) (flag-code 'z)) + (apply #'code '0= '(pop hl) '(ld a h) '(or l) (flag-code 'z)) + (apply #'code '0< '(pop hl) '(add hl hl) (flag-code 'c)) + (apply #'code 'u< '(pop de) '(pop hl) '(or a) '(sbc hl de) (flag-code 'c)) + (let ((same (gensym)) (done (gensym))) + (apply #'code '< '(pop de) '(pop hl) '(ld a h) '(xor d) `(jp p ,same) '(ld a h) '(rla) `(jr ,done) + same '(or a) '(sbc hl de) done (flag-code 'c))) + (let ((l (gensym)) (s (gensym))) + (code 'um* '(ld (@ ipsave) bc) '(pop bc) '(pop de) '(ld hl 0) '(ld a 16) + l '(add hl hl) '(rl e) '(rl d) `(jr nc ,s) '(add hl bc) `(jr nc ,s) '(inc de) + s '(dec a) `(jr nz ,l) '(push hl) '(push de) '(ld bc (@ ipsave)))) + (let ((l (gensym)) (big (gensym)) (set (gensym)) (nx (gensym))) + (code 'um/mod '(ld (@ ipsave) bc) '(pop bc) '(pop hl) '(pop de) '(ld a 16) + l '(sla e) '(rl d) '(adc hl hl) `(jr c ,big) '(or a) '(sbc hl bc) `(jr nc ,set) '(add hl bc) `(jr ,nx) + big '(or a) '(sbc hl bc) set '(inc e) nx '(dec a) `(jr nz ,l) '(push hl) '(push de) '(ld bc (@ ipsave)))) + (let ((l (gensym))) + (code 'key l `(in a (@ ,+console-status+)) '(and 1) `(jr z ,l) `(in a (@ ,+console-data+)) '(ld l a) '(ld h 0) '(push hl))) + (let ((l (gensym))) + (code 'emit '(pop hl) l `(in a (@ ,+console-status+)) '(and 2) `(jr z ,l) '(ld a l) `(out (@ ,+console-data+) a))) + (apply #'code 'key? `(in a (@ ,+console-status+)) '(and 1) '(xor 1) (flag-code 'z)) + (let ((s (gensym))) + (code 'cmove '(ld (@ ipsave) bc) '(pop bc) '(pop de) '(pop hl) '(ld a b) '(or c) `(jr z ,s) '(ldir) s '(ld bc (@ ipsave)))) + (let ((l (gensym)) (d (gensym))) + (code 'fill '(ld (@ ipsave) bc) '(pop de) '(pop bc) '(pop hl) l '(ld a b) '(or c) `(jr z ,d) + '(ld (@ hl) e) '(inc hl) '(dec bc) `(jr ,l) d '(ld bc (@ ipsave)))) + (let ((l (gensym)) (eq (gensym)) (ne (gensym)) (out (gensym))) + (code 's= '(ld (@ ipsave) bc) '(pop bc) '(pop de) '(pop hl) l '(ld a b) '(or c) `(jr z ,eq) + '(ld a (@ de)) '(cp (@ hl)) `(jr nz ,ne) '(inc hl) '(inc de) '(dec bc) `(jr ,l) + eq '(ld hl -1) `(jr ,out) ne '(ld hl 0) out '(push hl) '(ld bc (@ ipsave)))) + (code 'bye '(halt)) + ;; variables and constants + (var 'state) (var '>in) (var "#tib") (var 'handler) (var 'erraddr) (var 'errlen) (var 'lastc) + (var 'dp 'dict-end) + (var 'latest 'last-header) + (const 'tib +tib+) (const 'r0 +r0+) (const 's0 0) (const 'bl 32) + (const 'docol 'docol) (const 'dovar 'dovar) (const 'docon 'docon) + ;; high-level words + (colon '2drop 'drop 'drop) + (colon '2dup 'over 'over) + (colon '?dup 'dup 'if 'dup 'then) + (colon '<> '= '0=) + (colon '> 'swap '<) + (colon '* 'um* 'drop) + (colon 'here 'dp '@) + (colon 'allot 'dp '+!) + (colon "," 'here '! 2 'allot) + (colon 'c\, 'here 'c! 1 'allot) + (colon 'count 'dup '1+ 'swap 'c@) + (colon 'type 'begin 'dup 'while 'swap 'dup 'c@ 'emit '1+ 'swap '1- 'repeat '2drop) + (colon 'cr 13 'emit 10 'emit) + (colon 'space 32 'emit) + (colon "(u.)" 0 10 'um/mod '?dup 'if 'recurse 'then 48 '+ 'emit) + (colon 'u. "(u.)" 'space) + (colon "." 'dup '0< 'if 45 'emit 'negate 'then 'u.) + (colon 'depth 'sp@ 'negate '2/) + (colon 'catch 'sp@ '>r 'handler '@ '>r 'rp@ 'handler '! 'execute 'r> 'handler '! 'r> 'drop 0) + (colon 'throw '?dup 'if 'handler '@ 'rp! 'r> 'handler '! 'r> 'swap '>r 'sp! 'drop 'r> 'then) + ;; line input: echo, backspace, CR/LF/CRLF all end a line + (colon 'eol? 'dup 13 '= 'over 10 '= 'or) + (colon 'refill 0 "#tib" '! 0 '>in '! + 'begin 'key 'dup 10 '= 'lastc '@ 13 '= 'and 'if 'drop 0 'lastc '! 'key 'then 'dup 'lastc '! + 'eol? '0= 'while + 'dup 8 '= 'over 127 '= 'or + 'if 'drop "#tib" '@ 'if -1 "#tib" '+! 8 'emit 'space 8 'emit 'then + 'else "#tib" '@ +tib-size+ '< 'if 'dup 'emit 'tib "#tib" '@ '+ 'c! 1 "#tib" '+! 'else 'drop 'then 'then + 'repeat 'drop) + (colon 'in-char '>in '@ "#tib" '@ '< 'if 'tib '>in '@ '+ 'c@ 'else 0 'then) + (colon 'more? '>in '@ "#tib" '@ '<) + (colon 'parse-name + 'begin 'more? 'if 'in-char 33 '< 'else 0 'then 'while 1 '>in '+! 'repeat + 'tib '>in '@ '+ 0 + 'begin 'in-char 32 '> 'while '1+ 1 '>in '+! 'repeat) + (colon 'parse '>r 'tib '>in '@ '+ 0 + 'begin 'more? 'if 'in-char 'r@ '<> 'else 0 'then 'while '1+ 1 '>in '+! 'repeat + 'r> 'drop 'more? 'if 1 '>in '+! 'then) + (colon 'find 'latest '@ + 'begin 'dup 'while + 'dup 2 '+ 'c@ 95 'and 2 'pick '= + 'if 'dup 3 '+ 3 'pick 3 'pick 's= + 'if 'nip 'nip 'dup 2 '+ 'c@ 128 'and 'if 1 'else -1 'then 'swap + 'dup 2 '+ 'c@ 31 'and '+ 3 '+ 'swap 'exit 'then 'then + '@ 'repeat) + (colon 'digit? 48 '- 'dup 10 'u<) + (colon 'number 'over 'c@ 45 '= 'dup '>r 'if '1- 'swap '1+ 'swap 'then + 'dup '0= 'if '2drop 'r> 'drop 0 'exit 'then + 0 '>r 'begin 'dup 'while 'over 'c@ 'digit? '0= 'if 'drop '2drop 'r> 'r> '2drop 0 'exit 'then + 'r> 10 '* '+ '>r '1- 'swap '1+ 'swap 'repeat + '2drop 'r> 'r> 'if 'negate 'then -1) + (colon 'undefined 'errlen '! 'erraddr '! -13 'throw) + (colon 'interpret + 'begin 'parse-name 'dup 'while + 'find '?dup + 'if -1 '= 'state '@ 'and 'if "," 'else 'execute 'then + 'else '2dup 'number 'if '>r '2drop 'r> 'state '@ 'if ''lit "," "," 'then 'else 'undefined 'then 'then + 'repeat '2drop) + (colon '.error 'dup -13 '= 'if 'drop 'space 'erraddr '@ 'errlen '@ 'type (dq " ?") + 'else (dq " error ") "." 'then) + (colon 'quit 'r0 'rp! 0 'state '! 0 'handler '! + 'begin 'refill ''interpret 'catch '?dup 'if '.error 's0 'sp! 0 'state '! 'else (dq " ok") 'then 'cr 'again) + ;; compiler + (colon 'header 'parse-name 'here 'latest '@ "," 'latest '! 'dup 'c\, 'here 'swap 'dup 'allot 'cmove) + (colon 'create 'header 'dovar ",") + (colon 'variable 'create 0 ",") + (colon 'constant 'header 'docon "," ",") + (colon 'flags! 'latest '@ 2 '+ 'dup 'c@ 'rot 'xor 'swap 'c!) ; toggle header flag bits + (colon "]" -1 'state '!) + (colon "[" :immediate 0 'state '!) + (colon ":" 'header 'docol "," 64 'flags! "]") + (colon ";" :immediate ''exit "," 64 'flags! "[") + (colon 'immediate 128 'flags!) + (colon "'" 'parse-name 'find '0= 'if 'undefined 'then) + (colon "[']" :immediate "'" ''lit "," ",") + (colon 'literal :immediate ''lit "," ",") + (colon 'if :immediate ''0branch "," 'here 0 ",") + (colon 'then :immediate 'here 'swap '!) + (colon 'else :immediate ''branch "," 'here 0 "," 'swap 'here 'swap '!) + (colon 'begin :immediate 'here) + (colon 'until :immediate ''0branch "," ",") + (colon 'again :immediate ''branch "," ",") + (colon 'while :immediate ''0branch "," 'here 0 "," 'swap) + (colon 'repeat :immediate ''branch "," "," 'here 'swap '!) + (colon 'recurse :immediate 'latest '@ 'dup 2 '+ 'c@ 31 'and '+ 3 '+ ",") + (colon "(" :immediate 41 'parse '2drop) + (colon "\\" :immediate "#tib" '@ '>in '!) + (colon "(s\")" 'r> 'count '2dup '+ '>r) + (colon ",str" 1 '>in '+! 34 'parse 'dup 'c\, 'here 'swap 'dup 'allot 'cmove) + (colon "s\"" :immediate 'state '@ 'if (xt "(s\")") "," ",str" 'else 1 '>in '+! 34 'parse 'then) + (colon ".\"" :immediate (xt "(s\")") "," ",str" ''type ",") + (colon 'char 'parse-name 'drop 'c@) + (colon "[char]" :immediate 'char ''lit "," ",") + (colon 'words 'latest '@ 'begin 'dup 'while 'dup 3 '+ 'over 2 '+ 'c@ 31 'and 'type 'space '@ 'repeat 'drop) + (colon 'cold (dq "Z80 Forth") 'cr 'quit) + (emit `(equ last-header ,*link*) 'dict-end) + (assemble (reverse *forms*))) + +(let ((out (second sb-ext:*posix-argv*))) + (when out + (let ((bytes (build))) + (with-open-file (s out :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) + (write-sequence #(#xFF 0 0) s) (write-sequence bytes s)) + (format t "kernel: ~d bytes~%" (length bytes))))) diff --git a/lisp.fs b/lisp.fs new file mode 100644 index 0000000..e4c2b9c --- /dev/null +++ b/lisp.fs @@ -0,0 +1,304 @@ +\ lisp.fs -- layer 4: a small Scheme written in Forth words, loaded through the Z80 Forth. +\ Values are 16-bit. A heap object is one 4-byte cell (car, cdr) plus a type byte: +\ 1 pair 2 symbol (car: counted name, cdr: global value) 3 closure ((params . body) . env) +\ 4 primitive (car: xt) 5 number (32-bit: car low, cdr high) 6 string (car: char list) +\ 7 vector (car: element list) 8 macro (car: transformer closure). Bit 7: GC mark. +\ Immediates: () = 0, #f = 2, #t = 4, unspecified = 6, unbound = 8. + +: tuck swap over ; +: -rot rot rot ; +: 2swap rot >r rot r> ; +: 0<> 0= 0= ; +: abs dup 0< if negate then ; +: dnegate invert swap invert swap 1 0 d+ ; +: d- dnegate d+ ; +: dabs dup 0< if dnegate then ; +: d= rot = >r = r> and ; +: d< rot 2dup = if 2drop u< else > nip nip then ; +: d> 2swap d< ; +: d<= d> 0= ; +: d>= d< 0= ; +: d* >r swap >r 2dup um* 2swap r> * swap r> * + + ; +: mu/mod >r 0 r@ um/mod r> swap >r um/mod r> ; + +0 constant nil +2 constant false +4 constant true +6 constant unspec +8 constant unbound +: bool if true else false then ; + +\ ---- heap and garbage collector (mark-sweep; stacks are scanned conservatively) +7000 constant #cells +create heap0 #cells 4 * 4 + allot +heap0 3 + -4 and constant heap +create types #cells allot +variable free +variable symlist +variable errobj +variable errmsg +variable errlen +variable display? +: cell# heap - 2/ 2/ ; +: type@ cell# types + c@ 127 and ; +: heap? dup heap - #cells 4 * u< over 3 and 0= and if cell# types + c@ 127 and 0<> else drop 0 then ; +: car @ ; +: cdr 2 + @ ; +: cadr cdr car ; +: cddr cdr cdr ; +: caddr cddr car ; +: set-cdr 2 + ! ; +: typ? over heap? if swap type@ = else 2drop 0 then ; +: pair? 1 typ? ; +: lerror errlen ! errmsg ! errobj ! -100 throw ; +: mark + begin dup heap? while + dup cell# types + dup c@ dup 128 and if 2drop drop exit then + 128 or swap c! + dup type@ dup 1 = over 3 = or swap 8 = or if dup car recurse cdr else + dup type@ 2 = if cdr else + dup type@ dup 6 = swap 7 = or if car else drop 0 then then then + repeat drop ; +: scan-data sp@ begin dup while dup @ mark 2 + repeat drop ; +: scan-return rp@ begin dup r0 u< while dup @ mark 2 + repeat drop ; +: sweep 0 free ! 0 + begin dup #cells < while + dup types + dup c@ dup 128 and + if 127 and swap c! else drop 0 swap c! dup 4 * heap + free @ over set-cdr free ! then + 1+ repeat drop ; +: gc symlist @ mark scan-data scan-return sweep ; +: alloc free @ 0= if gc free @ 0= if 0 s" out of memory" lerror then then + free @ dup cdr free ! tuck cell# types + c! ; +: mk2 alloc tuck set-cdr tuck ! ; +: cons 1 mk2 ; +: mknum 5 mk2 ; +: num@ dup car swap cdr ; +: num? 5 typ? ; +: n@ dup num? 0= if s" not a number" lerror then num@ ; +: >num dup 0< mknum ; +: snoc 0 cons over if tuck swap set-cdr else nip nip dup then ; +: len 0 swap begin dup pair? while swap 1+ swap cdr repeat drop ; +types #cells 0 fill +sweep + +\ ---- symbols +: sym-name car count ; +: name= sym-name rot over = if s= else 2drop drop 0 then ; +: mksym here >r dup c, here swap dup allot cmove r> unbound 2 mk2 dup symlist @ cons symlist ! ; +: intern symlist @ begin dup while >r 2dup r@ car name= if 2drop r> car exit then r> cdr repeat drop mksym ; +s" quote" intern constant 'quote +s" if" intern constant 'if +s" define" intern constant 'define +s" set!" intern constant 'set! +s" lambda" intern constant 'lambda +s" begin" intern constant 'begin +s" define-macro" intern constant 'define-macro + +\ ---- environments: a list of frames, each frame an alist; globals live in the symbol +: assq begin dup while 2dup car car = if nip car exit then cdr repeat nip ; +: lookup begin dup while 2dup car assq ?dup if nip nip cdr exit then cdr repeat + drop dup cdr dup unbound = if drop s" unbound variable" lerror then nip ; +: set-var begin dup while 2dup car assq ?dup if nip nip set-cdr exit then cdr repeat drop set-cdr ; +: define-var dup if >r swap cons r@ car cons r> ! else drop set-cdr then ; + +\ ---- evaluator; eval-step returns ( x' env' 0 ) for a tail call or ( v -1 ) when done +variable 'eval +: eval* 'eval @ execute ; +: evlis 0 0 2swap begin over while over car over eval* >r 2swap r> snoc 2swap swap cdr swap repeat 2drop drop ; +: bind over 0= if 2drop 0 exit then + over 2 typ? if cons 0 cons exit then + over car over car cons >r cdr swap cdr swap recurse r> swap cons ; +: eval-body begin over cdr while over car over eval* drop swap cdr swap repeat swap car swap ; +: closure-env over car car swap bind over cdr cons swap car cdr swap ; +: apply-proc over 4 typ? if swap car execute exit then + over 3 typ? if closure-env eval-body eval* exit then + drop s" not a procedure" lerror ; +: expand car swap 0 cons apply-proc ; +: replace dup pair? 0= if 0 cons 'begin swap cons then + 2dup car swap ! cdr swap set-cdr ; +: macro-of dup 2 typ? if cdr dup 8 typ? if exit then then drop 0 ; +: do-if >r cdr dup car r@ eval* false = if cddr dup if car else drop unspec then else cadr then r> ; +: define-form dup car dup pair? if dup car >r cdr swap cdr cons 'lambda swap cons r> swap exit then swap cadr ; +: do-define >r cdr define-form r@ eval* over r> define-var ; +: do-set >r cdr dup cadr r@ eval* swap car r> set-var unspec ; +: do-defmacro >r cdr dup cadr r> eval* 0 8 mk2 swap car tuck set-cdr ; +: eval-step + over heap? 0= if drop -1 exit then + over 2 typ? if lookup -1 exit then + over pair? 0= if drop -1 exit then + over car + dup 'quote = if 2drop cadr -1 exit then + dup 'if = if drop do-if 0 exit then + dup 'define = if drop do-define -1 exit then + dup 'set! = if drop do-set -1 exit then + dup 'lambda = if drop swap cdr swap 3 mk2 -1 exit then + dup 'begin = if drop swap cdr dup 0= if 2drop unspec -1 exit then swap eval-body 0 exit then + dup 'define-macro = if drop do-defmacro -1 exit then + dup macro-of ?dup if nip >r over r> expand >r over r> replace 0 exit then + drop over car over eval* >r swap cdr swap evlis r> swap + over 3 typ? if closure-env eval-body 0 exit then + apply-proc -1 ; +: eval begin eval-step until ; +' eval 'eval ! + +\ ---- printer +: ud. 10 mu/mod 2dup or if recurse else 2drop then 48 + emit ; +: .num dup 0< if 45 emit dnegate then ud. ; +: .string display? @ if car begin dup while dup car car emit cdr repeat drop exit then + 34 emit car begin dup while dup car car dup 34 = over 92 = or if 92 emit then emit cdr repeat drop 34 emit ; +: print + dup nil = if drop ." ()" exit then + dup false = if drop ." #f" exit then + dup true = if drop ." #t" exit then + dup unspec = if drop exit then + dup heap? 0= if drop ." #<?>" exit then + dup type@ + dup 5 = if drop num@ .num exit then + dup 2 = if drop sym-name type exit then + dup 6 = if drop .string exit then + dup 7 = if drop 35 emit car recurse exit then + dup 8 = if 2drop ." #<macro>" exit then + dup 1 = if drop 40 emit dup car recurse cdr + begin dup pair? while 32 emit dup car recurse cdr repeat + dup if ." . " recurse else drop then 41 emit exit then + 2drop ." #<procedure>" ; + +\ ---- reader +: adv 1 >in +! ; +: skip-ws begin more? if in-char dup 59 = if drop #tib @ >in ! 0 else 33 < then else 0 then while adv repeat ; +: delim? dup 33 < over 40 = or over 41 = or over 34 = or swap 59 = or ; +: token tib >in @ + 0 begin more? if in-char delim? 0= else 0 then while 1+ adv repeat ; +: snumber over c@ 45 = dup >r if 1- swap 1+ swap then dup 0= if 2drop r> drop 0 exit then + 0 0 2swap begin dup while over c@ 48 - dup 10 u< 0= if 2drop 2drop drop r> drop 0 exit then + >r 2swap 10 0 d* r> 0 d+ 2swap 1- swap 1+ swap repeat + 2drop r> if dnegate then mknum -1 ; +: read-atom token 2dup snumber if nip nip exit then intern ; +variable 'read +: read* 'read @ execute ; +: dot? in-char 46 = if >in @ 1+ #tib @ < if tib >in @ 1+ + c@ delim? else -1 then else 0 then ; +: read-tail 0 0 begin skip-ws more? 0= if 0 s" unbalanced (" lerror then in-char 41 <> while + dot? if adv read* swap set-cdr skip-ws adv exit then + read* snoc repeat adv drop ; +: read-hash adv in-char 40 = if adv read-tail 0 7 mk2 exit then + token drop c@ 116 = if true else false then ; +: read-string adv 0 0 begin more? if in-char 34 <> else 0 then while + in-char 92 = if adv in-char 110 = if 10 else in-char then else in-char then adv >num snoc repeat + adv drop 0 6 mk2 ; +: read skip-ws in-char + dup 40 = if drop adv read-tail exit then + dup 39 = if drop adv read* 0 cons 'quote swap cons exit then + dup 34 = if drop read-string exit then + dup 35 = if drop read-hash exit then + dup 41 = if drop adv 0 s" unexpected )" lerror then + drop read-atom ; +' read 'read ! + +\ ---- primitives: each takes the evaluated argument list and returns a value +: prim: parse-name intern >r 4 alloc tuck ! r> set-cdr ; +: pcar car dup pair? 0= if s" car: not a pair" lerror then car ; +: pcdr car dup pair? 0= if s" cdr: not a pair" lerror then cdr ; +: pcons dup car swap cadr cons ; +: pset-car dup cadr swap car ! unspec ; +: pset-cdr dup cadr swap car set-cdr unspec ; +: eqv 2dup = if 2drop -1 exit then over num? over num? and if num@ rot num@ d= exit then 2drop 0 ; +: equal 2dup eqv if 2drop -1 exit then + over pair? over pair? and if over car over car recurse if cdr swap cdr recurse exit then 2drop 0 exit then + over heap? over heap? and if over type@ over type@ = if over type@ dup 6 = swap 7 = or if car swap car recurse exit then then then + 2drop 0 ; +: peq dup car swap cadr = bool ; +: peqv dup car swap cadr eqv bool ; +: pequal dup car swap cadr equal bool ; +: pnot car false = bool ; +: pnull car 0= bool ; +: ppair car pair? bool ; +: psymbol car 2 typ? bool ; +: pproc car dup 3 typ? swap 4 typ? or bool ; +: pnumber car num? bool ; +: pstring car 6 typ? bool ; +: pvector? car 7 typ? bool ; +: pboolean car dup true = swap false = or bool ; +: p+ 0 0 rot begin dup while >r r@ car n@ d+ r> cdr repeat drop mknum ; +: p* 1 0 rot begin dup while >r r@ car n@ d* r> cdr repeat drop mknum ; +: p- dup cdr 0= if car n@ dnegate mknum exit then + dup car n@ rot cdr begin dup while >r r@ car n@ d- r> cdr repeat drop mknum ; +: chain >r begin dup cdr while dup car n@ 2 pick cadr n@ r@ execute 0= if drop r> drop false exit then cdr repeat + drop r> drop true ; +: p= ['] d= chain ; +: p< ['] d< chain ; +: p> ['] d> chain ; +: p<= ['] d<= chain ; +: p>= ['] d>= chain ; +: divargs dup car n@ rot cadr n@ over 0< <> if 2drop 0 s" divisor out of 16-bit range" lerror then + dup 0= if 0 s" division by zero" lerror then ; +: sdiv over >r dup >r abs >r dabs r> mu/mod r> r@ xor 0< if dnegate then rot r> 0< if negate then -rot ; +: pquotient divargs sdiv mknum nip ; +: premainder divargs sdiv 2drop >num ; +: pmodulo divargs dup >r sdiv 2drop dup if dup 0< r@ 0< <> if r@ + then then r> drop >num ; +: mklist 0 rot begin dup while >r over swap cons r> 1- repeat drop nip ; +: pmake-vector dup car n@ drop swap cdr dup if car else drop unspec then mklist 0 7 mk2 ; +: pvector 0 7 mk2 ; +: nth begin dup while swap cdr swap 1- repeat drop ; +: pvector-ref dup car car swap cadr n@ drop nth car ; +: pvector-set dup caddr swap dup car car swap cadr n@ drop nth ! unspec ; +: pvector-length car car len >num ; +: plist->vector car 0 7 mk2 ; +: pstring-length car car len >num ; +: pdisplay car -1 display? ! print 0 display? ! unspec ; +: pwrite car print unspec ; +: pnewline drop cr unspec ; +: spread dup cdr 0= if car exit then dup car swap cdr recurse cons ; +: papply dup car swap cdr spread apply-proc ; +: pforth drop -200 throw ; +: proom drop 0 free @ begin dup while swap 1+ swap cdr repeat drop >num ; +' pcar prim: car +' pcdr prim: cdr +' pcons prim: cons +' pset-car prim: set-car! +' pset-cdr prim: set-cdr! +' peq prim: eq? +' peqv prim: eqv? +' pequal prim: equal? +' pnot prim: not +' pnull prim: null? +' ppair prim: pair? +' psymbol prim: symbol? +' pproc prim: procedure? +' pnumber prim: number? +' pnumber prim: integer? +' pstring prim: string? +' pvector? prim: vector? +' pboolean prim: boolean? +' p+ prim: + +' p* prim: * +' p- prim: - +' p= prim: = +' p< prim: < +' p> prim: > +' p<= prim: <= +' p>= prim: >= +' pquotient prim: quotient +' premainder prim: remainder +' pmodulo prim: modulo +' pmake-vector prim: make-vector +' pvector prim: vector +' pvector-ref prim: vector-ref +' pvector-set prim: vector-set! +' pvector-length prim: vector-length +: pinner car car ; +' pinner prim: vector->list +' plist->vector prim: list->vector +' pinner prim: string->list +' pstring-length prim: string-length +' pdisplay prim: display +' pwrite prim: write +' pnewline prim: newline +' papply prim: apply +' pforth prim: forth +' proom prim: room +: plist ; +' plist prim: list + +\ ---- REPL: one or more expressions per line; (forth) returns to the Forth prompt +: .lerror dup -100 = if drop ." error: " errmsg @ errlen @ type space errobj @ print else ." error " . then ; +: eval-line begin skip-ws more? while read cr nil eval 0 display? ! print repeat ; +: lisp begin cr ." > " refill ['] eval-line catch ?dup if dup -200 = if drop exit then cr .lerror then again ; diff --git a/prelude.scm b/prelude.scm new file mode 100644 index 0000000..98cca2a --- /dev/null +++ b/prelude.scm @@ -0,0 +1,56 @@ +; prelude.scm -- the rest of the Z80 Scheme, written in Scheme; loaded one form per line. +; Derived syntax is define-macro over lists; each expansion replaces its call form in place. +(define (caar x) (car (car x))) +(define (cdar x) (cdr (car x))) +(define (cadr x) (car (cdr x))) +(define (cddr x) (cdr (cdr x))) +(define (caddr x) (car (cddr x))) +(define (cdddr x) (cdr (cddr x))) +(define (zero? n) (= n 0)) +(define (positive? n) (> n 0)) +(define (negative? n) (< n 0)) +(define (even? n) (= (remainder n 2) 0)) +(define (odd? n) (not (even? n))) +(define (abs n) (if (< n 0) (- n) n)) +(define (square x) (* x x)) +(define (max x . r) (if (null? r) x (apply max (if (> x (car r)) x (car r)) (cdr r)))) +(define (min x . r) (if (null? r) x (apply min (if (< x (car r)) x (car r)) (cdr r)))) +(define (gcd2 a b) (if (= b 0) a (gcd2 b (remainder a b)))) +(define (gcd . ns) (if (null? ns) 0 (gcd2 (abs (car ns)) (abs (apply gcd (cdr ns)))))) +(define (lcm2 a b) (if (= a 0) 0 (if (= b 0) 0 (quotient (* a b) (gcd2 a b))))) +(define (lcm . ns) (if (null? ns) 1 (lcm2 (abs (car ns)) (apply lcm (cdr ns))))) +(define (sqrt n) (define (lp i) (if (> (* i i) n) (- i 1) (lp (+ i 1)))) (lp 0)) +(define (floor x) x) +(define (symbol=? a b) (eq? a b)) +(define (list? l) (if (null? l) #t (if (pair? l) (list? (cdr l)) #f))) +(define (length l) (define (lp l n) (if (pair? l) (lp (cdr l) (+ n 1)) n)) (lp l 0)) +(define (reverse l) (define (lp l a) (if (null? l) a (lp (cdr l) (cons (car l) a)))) (lp l '())) +(define (append2 a b) (define (lp r b) (if (null? r) b (lp (cdr r) (cons (car r) b)))) (lp (reverse a) b)) +(define (append . ls) (if (null? ls) '() (if (null? (cdr ls)) (car ls) (append2 (car ls) (apply append (cdr ls)))))) +(define (list-tail l k) (if (zero? k) l (list-tail (cdr l) (- k 1)))) +(define (list-ref l k) (car (list-tail l k))) +(define (memq x l) (if (null? l) #f (if (eq? x (car l)) l (memq x (cdr l))))) +(define (memv x l) (if (null? l) #f (if (eqv? x (car l)) l (memv x (cdr l))))) +(define (member x l) (if (null? l) #f (if (equal? x (car l)) l (member x (cdr l))))) +(define (assq x l) (if (null? l) #f (if (eq? x (caar l)) (car l) (assq x (cdr l))))) +(define (assv x l) (if (null? l) #f (if (eqv? x (caar l)) (car l) (assv x (cdr l))))) +(define (assoc x l) (if (null? l) #f (if (equal? x (caar l)) (car l) (assoc x (cdr l))))) +(define (map1 f l) (if (null? l) '() (cons (f (car l)) (map1 f (cdr l))))) +(define (map f . ls) (if (null? (cdr ls)) (map1 f (car ls)) (if (null? (car ls)) '() (cons (apply f (map1 car ls)) (apply map f (map1 cdr ls)))))) +(define (for-each f l) (if (null? l) #t (begin (f (car l)) (for-each f (cdr l))))) +(define (list-copy l) (map1 (lambda (x) x) l)) +(define (make-list n x) (if (zero? n) '() (cons x (make-list (- n 1) x)))) +(define-macro when (lambda (f) (list 'if (cadr f) (cons 'begin (cddr f))))) +(define-macro unless (lambda (f) (list 'if (list 'not (cadr f)) (cons 'begin (cddr f))))) +(define (named-let f) (list (list 'lambda '() (list 'define (cadr f) (cons 'lambda (cons (map1 car (caddr f)) (cdddr f)))) (cons (cadr f) (map1 cadr (caddr f)))))) +(define-macro let (lambda (f) (if (symbol? (cadr f)) (named-let f) (cons (cons 'lambda (cons (map1 car (cadr f)) (cddr f))) (map1 cadr (cadr f)))))) +(define-macro let* (lambda (f) (if (null? (cadr f)) (cons 'let (cons '() (cddr f))) (list 'let (list (car (cadr f))) (cons 'let* (cons (cdr (cadr f)) (cddr f))))))) +(define (letrec-x f) (list (cons 'lambda (cons '() (append (map1 (lambda (b) (cons 'define b)) (cadr f)) (cddr f)))))) +(define-macro letrec letrec-x) +(define-macro letrec* letrec-x) +(define-macro and (lambda (f) (if (null? (cdr f)) #t (if (null? (cddr f)) (cadr f) (list 'if (cadr f) (cons 'and (cddr f)) #f))))) +(define-macro or (lambda (f) (if (null? (cdr f)) #f (if (null? (cddr f)) (cadr f) (list 'let (list (list '%t (cadr f))) (list 'if '%t '%t (cons 'or (cddr f)))))))) +(define (cond1 c r) (if (eq? (car c) 'else) (cons 'begin (cdr c)) (if (null? (cdr c)) (list 'or (car c) r) (if (eq? (cadr c) '=>) (list 'let (list (list '%c (car c))) (list 'if '%c (list (caddr c) '%c) r)) (list 'if (car c) (cons 'begin (cdr c)) r))))) +(define-macro cond (lambda (f) (if (null? (cdr f)) (list 'if #f #f) (cond1 (cadr f) (cons 'cond (cddr f)))))) +(define-macro case (lambda (f) (list 'let (list (list '%k (cadr f))) (cons 'cond (map1 (lambda (c) (if (eq? (car c) 'else) c (cons (list 'memv '%k (list 'quote (car c))) (cdr c)))) (cddr f)))))) +(define-macro do (lambda (f) (list 'let '%do (map1 (lambda (b) (list (car b) (cadr b))) (cadr f)) (list 'if (car (caddr f)) (cons 'begin (cdr (caddr f))) (append (cons 'begin (cdddr f)) (list (cons '%do (map1 (lambda (b) (if (null? (cddr b)) (car b) (caddr b))) (cadr f))))))))) diff --git a/test-asm.lisp b/test-asm.lisp new file mode 100644 index 0000000..e3c38c4 --- /dev/null +++ b/test-asm.lisp @@ -0,0 +1,52 @@ +;;; test-asm.lisp -- layer 2 tests: every instruction form the assembler knows, +;;; assembled by asm.lisp and by the z80pack reference assembler (z80asm); +;;; one instruction per check, bytes must match exactly. +;;; Run: sbcl --script test-asm.lisp (needs Z80ASM, default ~/src/z80pack/z80asm/z80asm) +(load (merge-pathnames "asm.lisp" *load-truename*)) +(in-package :z80) + +(defparameter *cases* + (let ((r8 '(b c d e h l (@ hl) a)) (out '())) + (flet ((add (f) (push f out))) + (dolist (x r8) (dolist (y r8) (unless (and (consp x) (consp y)) (add `(ld ,x ,y))))) + (dolist (x r8) (add `(ld ,x 66)) (add `(inc ,x)) (add `(dec ,x))) + (dolist (x '(b c d e h l a)) (add `(ld ,x (@ ix 5))) (add `(ld (@ ix -3) ,x))) + (dolist (op '(add adc sbc)) (dolist (x r8) (add `(,op a ,x))) (add `(,op a 7)) (add `(,op a (@ ix 2)))) + (dolist (op '(sub and xor or cp)) (dolist (x r8) (add `(,op ,x))) (add `(,op 200)) (add `(,op (@ ix 2)))) + (dolist (rr '(bc de hl sp)) (add `(ld ,rr 4660)) (add `(inc ,rr)) (add `(dec ,rr)) + (add `(add hl ,rr)) (add `(adc hl ,rr)) (add `(sbc hl ,rr)) (add `(ld ,rr (@ 4660))) (add `(ld (@ 4660) ,rr))) + (dolist (rr '(bc de ix sp)) (add `(add ix ,rr))) + (dolist (rr '(bc de hl af ix)) (add `(push ,rr)) (add `(pop ,rr))) + (dolist (cc '(nz z nc c po pe p m)) (add `(jp ,cc 4660)) (add `(call ,cc 4660)) (add `(ret ,cc))) + (dolist (cc '(nz z nc c)) (add `(jr ,cc 0))) + (dolist (op '(rlc rrc rl rr sla sra srl)) (dolist (x r8) (add `(,op ,x)))) + (dolist (op '(bit res set)) (dolist (n '(0 3 7)) (dolist (x r8) (add `(,op ,n ,x))))) + (dolist (p '(0 8 16 56)) (add `(rst ,p))) + (dolist (f '((ld a (@ bc)) (ld a (@ de)) (ld (@ bc) a) (ld (@ de) a) (ld a (@ 4660)) (ld (@ 4660) a) + (ld sp hl) (ld sp ix) (ld ix 4660) (ld ix (@ 4660)) (ld (@ 4660) ix) (ld (@ ix 4) 9) + (inc ix) (dec ix) (inc (@ ix 1)) (dec (@ ix 1)) (jp 4660) (jp (@ hl)) (jp (@ ix)) + (call 4660) (jr 0) (djnz 0) (ex de hl) (ex (@ sp) hl) (ex (@ sp) ix) (ex af af) + (in a (@ 40)) (out (@ 41) a) (nop) (rlca) (rrca) (rla) (rra) (cpl) (scf) (ccf) + (db 1 255 "ab") (dw 4660 1) (halt) (di) (ei) (ret) (exx) (neg) (ldir) (lddr) (cpir))) + (add f))) + (nreverse out))) + +(defun reference-bytes (form) + (let ((src "/tmp/z80t.asm") (bin "/tmp/z80t.bin")) + (with-open-file (s src :direction :output :if-exists :supersede) + (format s " ~a~%" (insn->text form))) + (sb-ext:run-program (or (sb-ext:posix-getenv "Z80ASM") + (concatenate 'string (or (sb-ext:posix-getenv "Z80PACK") + (concatenate 'string (sb-ext:posix-getenv "HOME") "/src/z80pack")) + "/z80asm/z80asm")) + (list "-fb" (concatenate 'string "-o" bin) src) :output nil :error nil) + (with-open-file (s bin :element-type '(unsigned-byte 8)) + (let ((v (make-array (file-length s) :element-type '(unsigned-byte 8)))) (read-sequence v s) v)))) + +(let ((pass 0) (fail 0)) + (dolist (f *cases*) + (let ((mine (ignore-errors (assemble (list f)))) (ref (reference-bytes f))) + (if (equalp mine ref) (incf pass) + (progn (incf fail) (format t "MISMATCH ~a: ours ~x ref ~x~%" (insn->text f) mine ref))))) + (format t "assembler: ~d passed, ~d failed, ~d total~%" pass fail (+ pass fail)) + (sb-ext:exit :code (if (zerop fail) 0 1))) diff --git a/test.sh b/test.sh new file mode 100755 index 0000000..8690c1a --- /dev/null +++ b/test.sh @@ -0,0 +1,18 @@ +#!/bin/sh +# test.sh -- run the three test layers: assembler, kernel words, Lisp conformance. +# Each kernel-level layer gets its own fresh emulator. PORT sets the first TCP port. +SRC=$(cd "$(dirname "$0")" && pwd) +CORE=${FORTHLISP_CORE:-$SRC/..}; [ -f "$CORE/r7rs-tests.scm" ] || CORE=$SRC/../forthlisp # core repo checkout +SBCL=${SBCL:-sbcl} +PORT=${PORT:-4470} +rc=0 +nice $SBCL --script "$SRC/test-asm.lisp" || rc=1 +nice $SBCL --script "$SRC/kernel.lisp" "$SRC/kernel.mos" +for t in test-forth test; do + P=$(PORT=$PORT "$SRC/emu.sh" "$SRC/kernel.mos") + if [ $t = test ]; then arg=$CORE/r7rs-tests.scm; else arg=; fi + PORT=$PORT $SBCL --script "$SRC/host.lisp" $t $arg || rc=1 + kill $P 2>/dev/null + PORT=$((PORT + 1)) +done +exit $rc diff --git a/z80-forth b/z80-forth new file mode 100755 index 0000000..5ee4ae2 --- /dev/null +++ b/z80-forth @@ -0,0 +1,14 @@ +#!/bin/sh +# z80-forth -- boot the Z80 Forth kernel in z80pack cpmsim and attach its serial console. +# PORT picks the TCP port of the emulated serial console (default 4455). Quit with ctrl-c. +set -e +SRC=$(cd "$(dirname "$0")" && pwd) +PORT=${PORT:-4455} +IMG=$SRC/kernel.mos +[ -x "${Z80PACK:-$HOME/src/z80pack}/cpmsim/cpmsim" ] || "$SRC/build-emu.sh" >&2 +[ "$IMG" -nt "$SRC/kernel.lisp" ] && [ "$IMG" -nt "$SRC/asm.lisp" ] || "${SBCL:-sbcl}" --script "$SRC/kernel.lisp" "$IMG" >/dev/null +EPID=$(PORT=$PORT "$SRC/emu.sh" "$IMG") +trap 'kill $EPID 2>/dev/null; ${STTY:-stty} sane 2>/dev/null' EXIT HUP INT TERM +sleep 0.5 # let cpmsim open its listening socket +${STTY:-stty} -echo -icanon 2>/dev/null || true # the kernel echoes; no tty when piped +${NC:-nc} 127.0.0.1 $PORT \ No newline at end of file diff --git a/z80-lisp b/z80-lisp new file mode 100755 index 0000000..c054ca3 --- /dev/null +++ b/z80-lisp @@ -0,0 +1,16 @@ +#!/bin/sh +# z80-lisp -- boot the Z80 Forth, load the Scheme (lisp.fs + prelude.scm) through it, attach its REPL. +# PORT picks the TCP port of the emulated serial console (default 4455). Quit with ctrl-c. +set -e +SRC=$(cd "$(dirname "$0")" && pwd) +PORT=${PORT:-4455} +IMG=$SRC/kernel.mos +[ -x "${Z80PACK:-$HOME/src/z80pack}/cpmsim/cpmsim" ] || "$SRC/build-emu.sh" >&2 +[ "$IMG" -nt "$SRC/kernel.lisp" ] && [ "$IMG" -nt "$SRC/asm.lisp" ] || "${SBCL:-sbcl}" --script "$SRC/kernel.lisp" "$IMG" >/dev/null +EPID=$(PORT=$PORT "$SRC/emu.sh" "$IMG") +trap 'kill $EPID 2>/dev/null; ${STTY:-stty} sane 2>/dev/null' EXIT HUP INT TERM +sleep 0.5 # let cpmsim open its listening socket +PORT=$PORT "${SBCL:-sbcl}" --script "$SRC/host.lisp" load +printf 'Z80 Scheme ready: type an expression, (forth) returns to Forth, ctrl-c quits\n> ' +${STTY:-stty} -echo -icanon 2>/dev/null || true # the kernel echoes; no tty when piped +${NC:-nc} 127.0.0.1 $PORT \ No newline at end of file