forthlisp-z80/kernel.lisp - Recently Written

kernel.lisp (14810 bytes)
1 ;;; kernel.lisp -- layer 3: the Forth kernel, as data for asm.lisp.
2 ;;; Indirect-threaded. BC = IP, SP = data stack, IX = return stack, HL/DE/A scratch.
3 ;;; Header: link(2) | flags+len(1) | name | CFA(2) | body.  Flags: #x80 immediate, #x40 hidden.
4 ;;; Run: sbcl --script kernel.lisp OUT.mos   writes the image with a Mostek header (load at 0).
5 (load (merge-pathnames "asm.lisp" *load-truename*))
6 (in-package :z80)
7 
8 ;;; Memory map (64 KiB): image + dictionary 0000-E7FF, TIB E800-EBFF,
9 ;;; return stack EC00-F7FF (IX starts at F800), data stack F800-FFFF (SP starts at 0000).
10 (defconstant +tib+ #xE800)
11 (defconstant +tib-size+ 1023)
12 (defconstant +r0+ #xF800)
13 (defconstant +console-status+ 40)  ; z80pack cpmsim: TCP console 1 status (bit0 rx, bit1 tx)
14 (defconstant +console-data+ 41)
15 
16 (defvar *forms* '())
17 (defvar *link* 0)
18 (defvar *current* nil)
19 (defun emit (&rest forms) (dolist (f forms) (push f *forms*)))
20 (defun wlabel (name) (intern (format nil "W:~a" name) :z80))
21 (defun name-of (x) (if (stringp x) x (string-downcase (symbol-name x))))
22 
23 (defun header (name &optional immediate)
24   (let ((hdr (gensym "HDR")))
25     (setf *current* name)
26     (emit hdr `(dw ,*link*) `(db ,(+ (length name) (if immediate #x80 0))) `(db ,name) (wlabel name))
27     (setf *link* hdr)))
28 
29 (defun code (name &rest asm)
30   "A primitive: CFA points at the code that follows it."
31   (let ((body (gensym "CODE")))
32     (header (name-of name))
33     (emit `(dw ,body) body)
34     (apply #'emit asm)
35     (emit '(jp next))))
36 
37 (defun compile-tokens (tokens)
38   "Thread TOKENS, resolving control words at build time like a Forth compiler would."
39   (let ((cs '()))
40     (dolist (tk tokens)
41       (let ((s (and (symbolp tk) (symbol-name tk))))
42         (flet ((label () (let ((l (gensym "L"))) (emit l) l))
43                (fwd (op) (let ((l (gensym "F"))) (emit `(dw ,(wlabel op) ,l)) l)))
44           (cond ((integerp tk) (emit `(dw ,(wlabel "lit") ,(logand tk #xFFFF))))
45                 ((equal s "IF") (push (fwd "0branch") cs))
46                 ((equal s "ELSE") (let ((f (fwd "branch"))) (emit (pop cs)) (push f cs)))
47                 ((equal s "THEN") (emit (pop cs)))
48                 ((equal s "BEGIN") (push (label) cs))
49                 ((equal s "WHILE") (let ((f (fwd "0branch"))) (push f (cdr cs))))
50                 ((equal s "REPEAT") (emit `(dw ,(wlabel "branch") ,(pop cs))) (emit (pop cs)))
51                 ((equal s "UNTIL") (emit `(dw ,(wlabel "0branch") ,(pop cs))))
52                 ((equal s "AGAIN") (emit `(dw ,(wlabel "branch") ,(pop cs))))
53                 ((equal s "RECURSE") (emit `(dw ,(wlabel *current*))))
54                 ((and (consp tk) (eq (car tk) 'quote)) (emit `(dw ,(wlabel "lit") ,(wlabel (name-of (cadr tk))))))
55                 ((and (consp tk) (symbolp (car tk)) (equal (symbol-name (car tk)) "ADDR")) (emit `(dw ,(wlabel "lit") ,(cadr tk))))
56                 ((and (consp tk) (member (car tk) '("s\"" ".\"") :test #'equal))
57                  (emit `(dw ,(wlabel "(s\")")) `(db ,(length (cadr tk))) `(db ,(cadr tk)))
58                  (when (equal (car tk) ".\"") (emit `(dw ,(wlabel "type")))))
59                 (t (emit `(dw ,(wlabel (name-of tk)))))))))
60     (when cs (error "unbalanced control flow in ~a" *current*))))
61 
62 (defun xt (name) (list 'quote name))
63 (defun dq (s) (list ".\"" s))
64 (defun colon (name &rest tokens)
65   (let ((imm (eq (car tokens) :immediate)))
66     (header (name-of name) imm)
67     (emit '(dw docol))
68     (compile-tokens (if imm (cdr tokens) tokens))
69     (emit `(dw ,(wlabel "exit")))))
70 
71 (defun var (name &optional (init 0))
72   (header (name-of name)) (emit '(dw dovar) `(dw ,init)))
73 (defun const (name value)
74   (header (name-of name)) (emit '(dw docon) `(dw ,value)))
75 
76 (defun flag-code (test)
77   "Push -1 when the condition jump TEST (e.g. z, c) is taken, else 0."
78   (let ((l (gensym)))
79     `((ld hl 0) (jr ,(if (eq test 'z) 'nz 'nc) ,l) (dec hl) ,l (push hl))))
80 
81 (defun build ()
82   (setf *forms* '() *link* 0)
83   ;; boot and inner interpreter
84   (emit '(jp start)
85         'next '(ld a (@ bc)) '(ld l a) '(inc bc) '(ld a (@ bc)) '(ld h a) '(inc bc)
86         '(ld e (@ hl)) '(inc hl) '(ld d (@ hl)) '(inc hl) '(ex de hl) '(jp (@ hl))
87         'docol '(dec ix) '(ld (@ ix 0) b) '(dec ix) '(ld (@ ix 0) c) '(ld b d) '(ld c e) '(jp next)
88         'dovar '(push de) '(jp next)
89         'docon '(ex de hl) '(ld e (@ hl)) '(inc hl) '(ld d (@ hl)) '(push de) '(jp next)
90         'ipsave '(dw 0)
91         'start `(ld sp 0) `(ld ix ,+r0+) '(ld bc cold) '(jp next)
92         'cold `(dw ,(wlabel "cold")))
93   ;; primitives
94   (code 'exit '(ld c (@ ix 0)) '(inc ix) '(ld b (@ ix 0)) '(inc ix))
95   (code 'lit '(ld a (@ bc)) '(ld l a) '(inc bc) '(ld a (@ bc)) '(ld h a) '(inc bc) '(push hl))
96   (code 'branch 'branch '(ld a (@ bc)) '(ld l a) '(inc bc) '(ld a (@ bc)) '(ld b a) '(ld c l))
97   (code '0branch '(pop hl) '(ld a h) '(or l) '(jr z branch) '(inc bc) '(inc bc))
98   (header "execute") (emit '(dw execute) 'execute '(pop hl) '(ld e (@ hl)) '(inc hl) '(ld d (@ hl)) '(inc hl) '(ex de hl) '(jp (@ hl)))
99   (code 'dup '(pop hl) '(push hl) '(push hl))
100   (code 'drop '(pop hl))
101   (code 'swap '(pop hl) '(ex (@ sp) hl) '(push hl))
102   (code 'over '(pop hl) '(pop de) '(push de) '(push hl) '(push de))
103   (code 'rot '(pop de) '(pop hl) '(ex (@ sp) hl) '(push de) '(push hl))
104   (code 'nip '(pop hl) '(pop de) '(push hl))
105   (code '>r '(pop hl) '(dec ix) '(ld (@ ix 0) h) '(dec ix) '(ld (@ ix 0) l))
106   (code 'r> '(ld l (@ ix 0)) '(inc ix) '(ld h (@ ix 0)) '(inc ix) '(push hl))
107   (code 'r@ '(ld l (@ ix 0)) '(ld h (@ ix 1)) '(push hl))
108   (code 'sp@ '(ld hl 0) '(add hl sp) '(push hl))
109   (code 'sp! '(pop hl) '(ld sp hl))
110   (code 'rp@ '(push ix))
111   (code 'rp! '(pop ix))
112   (code 'pick '(pop hl) '(add hl hl) '(add hl sp) '(ld e (@ hl)) '(inc hl) '(ld d (@ hl)) '(push de))
113   (code '@ '(pop hl) '(ld e (@ hl)) '(inc hl) '(ld d (@ hl)) '(push de))
114   (code '! '(pop hl) '(pop de) '(ld (@ hl) e) '(inc hl) '(ld (@ hl) d))
115   (code 'c@ '(pop hl) '(ld l (@ hl)) '(ld h 0) '(push hl))
116   (code 'c! '(pop hl) '(pop de) '(ld (@ hl) e))
117   (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))
118   (code '+ '(pop hl) '(pop de) '(add hl de) '(push hl))
119   (code '- '(pop de) '(pop hl) '(or a) '(sbc hl de) '(push hl))
120   (dolist (op '(and or xor))
121     (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)))
122   (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)))
123   (code 'invert '(pop hl) '(ld a l) '(cpl) '(ld l a) '(ld a h) '(cpl) '(ld h a) '(push hl))
124   (code 'negate '(pop de) '(ld hl 0) '(or a) '(sbc hl de) '(push hl))
125   (code '2* '(pop hl) '(add hl hl) '(push hl))
126   (code '2/ '(pop hl) '(sra h) '(rr l) '(push hl))
127   (code 'u2/ '(pop hl) '(srl h) '(rr l) '(push hl))
128   (code '1+ '(pop hl) '(inc hl) '(push hl))
129   (code '1- '(pop hl) '(dec hl) '(push hl))
130   (apply #'code '= '(pop hl) '(pop de) '(or a) '(sbc hl de) (flag-code 'z))
131   (apply #'code '0= '(pop hl) '(ld a h) '(or l) (flag-code 'z))
132   (apply #'code '0< '(pop hl) '(add hl hl) (flag-code 'c))
133   (apply #'code 'u< '(pop de) '(pop hl) '(or a) '(sbc hl de) (flag-code 'c))
134   (let ((same (gensym)) (done (gensym)))
135     (apply #'code '< '(pop de) '(pop hl) '(ld a h) '(xor d) `(jp p ,same) '(ld a h) '(rla) `(jr ,done)
136            same '(or a) '(sbc hl de) done (flag-code 'c)))
137   (let ((l (gensym)) (s (gensym)))
138     (code 'um* '(ld (@ ipsave) bc) '(pop bc) '(pop de) '(ld hl 0) '(ld a 16)
139           l '(add hl hl) '(rl e) '(rl d) `(jr nc ,s) '(add hl bc) `(jr nc ,s) '(inc de)
140           s '(dec a) `(jr nz ,l) '(push hl) '(push de) '(ld bc (@ ipsave))))
141   (let ((l (gensym)) (big (gensym)) (set (gensym)) (nx (gensym)))
142     (code 'um/mod '(ld (@ ipsave) bc) '(pop bc) '(pop hl) '(pop de) '(ld a 16)
143           l '(sla e) '(rl d) '(adc hl hl) `(jr c ,big) '(or a) '(sbc hl bc) `(jr nc ,set) '(add hl bc) `(jr ,nx)
144           big '(or a) '(sbc hl bc) set '(inc e) nx '(dec a) `(jr nz ,l) '(push hl) '(push de) '(ld bc (@ ipsave))))
145   (let ((l (gensym)))
146     (code 'key l `(in a (@ ,+console-status+)) '(and 1) `(jr z ,l) `(in a (@ ,+console-data+)) '(ld l a) '(ld h 0) '(push hl)))
147   (let ((l (gensym)))
148     (code 'emit '(pop hl) l `(in a (@ ,+console-status+)) '(and 2) `(jr z ,l) '(ld a l) `(out (@ ,+console-data+) a)))
149   (apply #'code 'key? `(in a (@ ,+console-status+)) '(and 1) '(xor 1) (flag-code 'z))
150   (let ((s (gensym)))
151     (code 'cmove '(ld (@ ipsave) bc) '(pop bc) '(pop de) '(pop hl) '(ld a b) '(or c) `(jr z ,s) '(ldir) s '(ld bc (@ ipsave))))
152   (let ((l (gensym)) (d (gensym)))
153     (code 'fill '(ld (@ ipsave) bc) '(pop de) '(pop bc) '(pop hl) l '(ld a b) '(or c) `(jr z ,d)
154           '(ld (@ hl) e) '(inc hl) '(dec bc) `(jr ,l) d '(ld bc (@ ipsave))))
155   (let ((l (gensym)) (eq (gensym)) (ne (gensym)) (out (gensym)))
156     (code 's= '(ld (@ ipsave) bc) '(pop bc) '(pop de) '(pop hl) l '(ld a b) '(or c) `(jr z ,eq)
157           '(ld a (@ de)) '(cp (@ hl)) `(jr nz ,ne) '(inc hl) '(inc de) '(dec bc) `(jr ,l)
158           eq '(ld hl -1) `(jr ,out) ne '(ld hl 0) out '(push hl) '(ld bc (@ ipsave))))
159   (code 'bye '(halt))
160   ;; variables and constants
161   (var 'state) (var '>in) (var "#tib") (var 'handler) (var 'erraddr) (var 'errlen) (var 'lastc)
162   (var 'dp 'dict-end)
163   (var 'latest 'last-header)
164   (const 'tib +tib+) (const 'r0 +r0+) (const 's0 0) (const 'bl 32)
165   (const 'docol 'docol) (const 'dovar 'dovar) (const 'docon 'docon)
166   ;; high-level words
167   (colon '2drop 'drop 'drop)
168   (colon '2dup 'over 'over)
169   (colon '?dup 'dup 'if 'dup 'then)
170   (colon '<> '= '0=)
171   (colon '> 'swap '<)
172   (colon '* 'um* 'drop)
173   (colon 'here 'dp '@)
174   (colon 'allot 'dp '+!)
175   (colon "," 'here '! 2 'allot)
176   (colon 'c\, 'here 'c! 1 'allot)
177   (colon 'count 'dup '1+ 'swap 'c@)
178   (colon 'type 'begin 'dup 'while 'swap 'dup 'c@ 'emit '1+ 'swap '1- 'repeat '2drop)
179   (colon 'cr 13 'emit 10 'emit)
180   (colon 'space 32 'emit)
181   (colon "(u.)" 0 10 'um/mod '?dup 'if 'recurse 'then 48 '+ 'emit)
182   (colon 'u. "(u.)" 'space)
183   (colon "." 'dup '0< 'if 45 'emit 'negate 'then 'u.)
184   (colon 'depth 'sp@ 'negate '2/)
185   (colon 'catch 'sp@ '>r 'handler '@ '>r 'rp@ 'handler '! 'execute 'r> 'handler '! 'r> 'drop 0)
186   (colon 'throw '?dup 'if 'handler '@ 'rp! 'r> 'handler '! 'r> 'swap '>r 'sp! 'drop 'r> 'then)
187   ;; line input: echo, backspace, CR/LF/CRLF all end a line
188   (colon 'eol? 'dup 13 '= 'over 10 '= 'or)
189   (colon 'refill 0 "#tib" '! 0 '>in '!
190          'begin 'key 'dup 10 '= 'lastc '@ 13 '= 'and 'if 'drop 0 'lastc '! 'key 'then 'dup 'lastc '!
191                 'eol? '0= 'while
192                 'dup 8 '= 'over 127 '= 'or
193                 'if 'drop "#tib" '@ 'if -1 "#tib" '+! 8 'emit 'space 8 'emit 'then
194                 'else "#tib" '@ +tib-size+ '< 'if 'dup 'emit 'tib "#tib" '@ '+ 'c! 1 "#tib" '+! 'else 'drop 'then 'then
195          'repeat 'drop)
196   (colon 'in-char '>in '@ "#tib" '@ '< 'if 'tib '>in '@ '+ 'c@ 'else 0 'then)
197   (colon 'more? '>in '@ "#tib" '@ '<)
198   (colon 'parse-name
199          'begin 'more? 'if 'in-char 33 '< 'else 0 'then 'while 1 '>in '+! 'repeat
200          'tib '>in '@ '+ 0
201          'begin 'in-char 32 '> 'while '1+ 1 '>in '+! 'repeat)
202   (colon 'parse '>r 'tib '>in '@ '+ 0
203          'begin 'more? 'if 'in-char 'r@ '<> 'else 0 'then 'while '1+ 1 '>in '+! 'repeat
204          'r> 'drop 'more? 'if 1 '>in '+! 'then)
205   (colon 'find 'latest '@
206          'begin 'dup 'while
207            'dup 2 '+ 'c@ 95 'and 2 'pick '=
208            'if 'dup 3 '+ 3 'pick 3 'pick 's=
209              'if 'nip 'nip 'dup 2 '+ 'c@ 128 'and 'if 1 'else -1 'then 'swap
210                  'dup 2 '+ 'c@ 31 'and '+ 3 '+ 'swap 'exit 'then 'then
211            '@ 'repeat)
212   (colon 'digit? 48 '- 'dup 10 'u<)
213   (colon 'number 'over 'c@ 45 '= 'dup '>r 'if '1- 'swap '1+ 'swap 'then
214          'dup '0= 'if '2drop 'r> 'drop 0 'exit 'then
215          0 '>r 'begin 'dup 'while 'over 'c@ 'digit? '0= 'if 'drop '2drop 'r> 'r> '2drop 0 'exit 'then
216                    'r> 10 '* '+ '>r '1- 'swap '1+ 'swap 'repeat
217          '2drop 'r> 'r> 'if 'negate 'then -1)
218   (colon 'undefined 'errlen '! 'erraddr '! -13 'throw)
219   (colon 'interpret
220          'begin 'parse-name 'dup 'while
221            'find '?dup
222            'if -1 '= 'state '@ 'and 'if "," 'else 'execute 'then
223            'else '2dup 'number 'if '>r '2drop 'r> 'state '@ 'if ''lit "," "," 'then 'else 'undefined 'then 'then
224          'repeat '2drop)
225   (colon '.error 'dup -13 '= 'if 'drop 'space 'erraddr '@ 'errlen '@ 'type (dq " ?")
226          'else (dq " error ") "." 'then)
227   (colon 'quit 'r0 'rp! 0 'state '! 0 'handler '!
228          'begin 'refill ''interpret 'catch '?dup 'if '.error 's0 'sp! 0 'state '! 'else (dq " ok") 'then 'cr 'again)
229   ;; compiler
230   (colon 'header 'parse-name 'here 'latest '@ "," 'latest '! 'dup 'c\, 'here 'swap 'dup 'allot 'cmove)
231   (colon 'create 'header 'dovar ",")
232   (colon 'variable 'create 0 ",")
233   (colon 'constant 'header 'docon "," ",")
234   (colon 'flags! 'latest '@ 2 '+ 'dup 'c@ 'rot 'xor 'swap 'c!)  ; toggle header flag bits
235   (colon "]" -1 'state '!)
236   (colon "[" :immediate 0 'state '!)
237   (colon ":" 'header 'docol "," 64 'flags! "]")
238   (colon ";" :immediate ''exit "," 64 'flags! "[")
239   (colon 'immediate 128 'flags!)
240   (colon "'" 'parse-name 'find '0= 'if 'undefined 'then)
241   (colon "[']" :immediate "'" ''lit "," ",")
242   (colon 'literal :immediate ''lit "," ",")
243   (colon 'if :immediate ''0branch "," 'here 0 ",")
244   (colon 'then :immediate 'here 'swap '!)
245   (colon 'else :immediate ''branch "," 'here 0 "," 'swap 'here 'swap '!)
246   (colon 'begin :immediate 'here)
247   (colon 'until :immediate ''0branch "," ",")
248   (colon 'again :immediate ''branch "," ",")
249   (colon 'while :immediate ''0branch "," 'here 0 "," 'swap)
250   (colon 'repeat :immediate ''branch "," "," 'here 'swap '!)
251   (colon 'recurse :immediate 'latest '@ 'dup 2 '+ 'c@ 31 'and '+ 3 '+ ",")
252   (colon "(" :immediate 41 'parse '2drop)
253   (colon "\\" :immediate "#tib" '@ '>in '!)
254   (colon "(s\")" 'r> 'count '2dup '+ '>r)
255   (colon ",str" 1 '>in '+! 34 'parse 'dup 'c\, 'here 'swap 'dup 'allot 'cmove)
256   (colon "s\"" :immediate 'state '@ 'if (xt "(s\")") "," ",str" 'else 1 '>in '+! 34 'parse 'then)
257   (colon ".\"" :immediate (xt "(s\")") "," ",str" ''type ",")
258   (colon 'char 'parse-name 'drop 'c@)
259   (colon "[char]" :immediate 'char ''lit "," ",")
260   (colon 'words 'latest '@ 'begin 'dup 'while 'dup 3 '+ 'over 2 '+ 'c@ 31 'and 'type 'space '@ 'repeat 'drop)
261   (colon 'cold (dq "Z80 Forth") 'cr 'quit)
262   (emit `(equ last-header ,*link*) 'dict-end)
263   (assemble (reverse *forms*)))
264 
265 (let ((out (second sb-ext:*posix-argv*)))
266   (when out
267     (let ((bytes (build)))
268       (with-open-file (s out :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede)
269         (write-sequence #(#xFF 0 0) s) (write-sequence bytes s))
270       (format t "kernel: ~d bytes~%" (length bytes)))))