1 ;;; ez.el --- Emacs Z-machine
3 ;; Copyright (C) 2021 Tim Vaughan
5 ;; Author: Tim Vaughan <timv@ughan.xyz>
6 ;; Created: 13 Oct 2021
9 ;; Homepage: http://thelambdalab.xyz/ez
10 ;; Package-Requires: ((emacs "26"))
12 ;; This file is not part of GNU Emacs.
14 ;; This program is free software: you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation, either version 3 of the License, or
17 ;; (at your option) any later version.
19 ;; This program is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with this file. If not, see <http://www.gnu.org/licenses/>.
33 (defun ez-decode-signed-bits (n nbits)
34 (if (= 0 (lsh n (- 1 nbits)))
38 (defun ez-decode-signed-byte (b)
39 (ez-decode-signed-bits b 8))
41 (defun ez-decode-signed-word (w)
42 (ez-decode-signed-bits w 16))
44 (defun binformat (n &optional s)
48 (new-s (concat (number-to-string (mod n 2)) s)))
51 (binformat d new-s))))
56 "Memory of z-machine.")
58 (defvar ez-version nil)
60 (defvar ez-start-pc nil)
61 (defvar ez-himem-base nil)
62 (defvar ez-dict-addr nil)
63 (defvar ez-objtab-addr nil)
64 (defvar ez-abbrevtab-addr nil)
65 (defvar ez-globalvartab-addr nil)
67 (defun ez-mem-ref-byte (addr)
68 (aref ez-memory addr))
70 (defun ez-mem-set-byte (addr val)
71 (aset ez-memory addr val))
73 (defun ez-mem-ref-word (addr)
74 (+ (* 256 (aref ez-memory addr))
75 (aref ez-memory (+ addr 1))))
77 (defun ez-mem-set-word (addr val)
78 (let ((byte-high (/ val 256))
79 (byte-low (mod val 256)))
80 (aset ez-memory addr byte-high)
81 (aset ez-memory (+ addr 1) byte-low)))
83 (defun ez-parse-header ()
84 (setq ez-version (ez-mem-ref-byte #x0))
85 (setq ez-himem-addr (ez-mem-ref-word #x4))
86 (setq ez-start-pc (ez-mem-ref-word #x6))
87 (setq ez-dict-base (ez-mem-ref-word #x8))
88 (setq ez-objtab-addr (ez-mem-ref-word #xA))
89 (setq ez-globalvartab-addr (ez-mem-ref-word #xC))
90 (setq ez-abbrevtab-addr (ez-mem-ref-word #x18)))
92 (defun ez-load-file (filename)
93 "Load story file into memory."
95 (insert-file-contents-literally filename)
96 (setq ez-memory (encode-coding-string (buffer-string) 'raw-text))))
100 (defun ez-get-global-var (gvar)
101 (ez-mem-ref-word (+ (* 2 gvar) (ez-mem-ref-word ez-globalvartab-addr))))
103 (defun ez-set-global-var (gvar val)
104 (ez-mem-set-word (+ (* 2 gvar) (ez-mem-ref-word ez-globalvartab-addr)) val))
108 (defun ez-make-obj (&optional name attribs props parent first-child next-sibling)
109 (list name attribs props parent first-child next-sibling))
111 (defun ez-obj-name (obj) (elt obj 0))
112 (defun ez-obj-attribs (obj) (elt obj 1))
113 (defun ez-obj-props (obj) (elt obj 2))
114 (defun ez-obj-parent (obj) (elt obj 3))
115 (defun ez-obj-first-child (obj) (elt obj 4))
116 (defun ez-obj-next-sibling (obj) (elt obj 5))
118 (defvar ez-property-defaults nil)
120 (defun ez-load-property-defaults ()
121 (setq ez-property-defaults (make-vector 31 0))
123 (aset ez-property-defaults i (aref ez-memory (+ ez-objtab-addr (* 2 i))))))
125 (defun ez-get-obj (obj-id)
126 (let ((addr (+ ez-objtab-addr
128 (* 9 (- obj-id 1)))))
131 (ez-mem-ref-byte (+ addr 4))
132 (ez-mem-ref-byte (+ addr 5))
133 (ez-mem-ref-byte (+ addr 6))
134 (ez-mem-ref-word (+ addr 7))
135 (let ((plist-addr (ez-mem-ref-word (+ addr 7))))
136 (if (> (ez-mem-ref-byte plist-addr) 0)
137 (ez-get-zstring (+ 1 plist-addr))
143 (defvar ez-zstring-alphabets
146 (list " abcdefghijklmnopqrstuvwxyz"
147 " ABCDEFGHIJKLMNOPQRSTUVWXYZ"
148 " \n0123456789.,!?_#'\"/\\-:()")
149 "Alphabets used by V3")
151 (defun ez-parse-zstring-word (word)
153 (logand (lsh word -10) #b11111)
154 (logand (lsh word -5) #b11111)
155 (logand word #b11111)))
157 (defun ez-get-zstring-chars (base-addr)
158 (let ((addr base-addr)
162 (let ((components (ez-parse-zstring-word (ez-mem-ref-word addr))))
163 (setq chars (append chars (cdr components)))
164 (setq addr (+ addr 2))
165 (when (= (car components) 1)
166 (setq not-done nil))))
169 (defun ez-get-zstring (base-addr)
170 (let ((chars (ez-get-zstring-chars base-addr))
179 (* 2 (ez-mem-ref-word (+ ez-abbrevtab-addr
180 (* 2 (+ (* (- abbrev-char 1) 32) char)))))))
181 (setq s (concat s (ez-get-zstring abbrev-addr))))
182 (setq abbrev-char nil))
183 ((memq char '(1 2 3)) ;Abbreviation
184 (setq abbrev-char char))
186 (setq cur (mod (+ cur 1) 2)))
188 (setq cur (mod (+ 2 (- cur 1)) 2)))
190 (setq s (concat s (substring (elt ez-zstring-alphabets cur)
198 (defvar ez-call-stack nil)
200 (defun ez-make-call-stack-frame (pc &optional call-method)
206 (defun ez-add-call-stack-frame (pc &optional call-method)
207 (push (ez-make-call-stack-frame pc call-method) ez-call-stack))
209 (defun ez-pop-call-stack-frame ()
212 (defun ez-routine-stack ()
213 (elt (car ez-call-stack) 1))
215 (defun ez-routine-stack-push (val)
216 (let ((frame (car ez-call-stack)))
217 (setf (elt frame 1) (cons val (elt frame 1)))))
219 (defun ez-routine-stack-pop ()
220 (let* ((frame (car ez-call-stack))
221 (rs-head (car (elt frame 1))))
222 (setf (elt frame 1) (cdr (elt frame 1)))
225 (defun ez-get-local-var (lvar)
226 (let ((frame (car ez-call-stack)))
227 (aref (elt frame 2) (- lvar 1))))
229 (defun ez-set-local-var (lvar val)
230 (let ((frame (car ez-call-stack)))
231 (aset (elt frame 2) (- lvar 1) val)))
234 (caar ez-call-stack))
236 (defun ez-set-pc (new-pc)
237 (setf (car (car ez-call-stack)) new-pc))
239 (defun ez-increment-pc (inc)
240 (ez-set-pc (+ (ez-get-pc) inc)))
242 (defun ez-read-pc-byte-and-inc ()
243 (let ((res (ez-mem-ref-byte (ez-get-pc))))
247 (defun ez-read-pc-word-and-inc ()
248 (let ((res (ez-mem-ref-word (ez-get-pc))))
252 ;; Instruction execution
254 (defun ez-get-var (var)
257 (ez-routine-stack-pop))
259 (ez-get-local-var var))
261 (ez-get-global-var (- var 16)))))
263 (defun ez-set-var (var val)
266 (ez-routine-stack-push val))
268 (ez-set-local-var var val))
270 (ez-set-global-var (- var 16) val))))
272 (defun ez-read-pc-var-and-inc ()
273 (ez-get-var (ez-read-pc-byte-and-inc)))
275 (defun ez-execute-instr ()
276 (let ((instr-pc (ez-get-pc))
277 (opbyte (ez-read-pc-byte-and-inc))
282 ((<= #x0 opbyte #x1f)
285 operands (list (ez-read-pc-byte-and-inc)
286 (ez-read-pc-byte-and-inc))
287 operand-types '(b b)))
288 ((<= #x20 opbyte #x3F)
290 opcode (- opbyte #x20)
291 operands (list (ez-read-pc-byte-and-inc)
292 (ez-read-pc-var-and-inc))
293 operand-types '(b w)))
294 ((<= #x40 opbyte #x5F)
296 opcode (- opbyte #x40)
297 operands (list (ez-read-pc-var-and-inc)
298 (ez-read-pc-byte-and-inc))
299 operand-types '(w b)))
300 ((<= #x60 opbyte #x7F)
302 opcode (- opbyte #x60)
303 operands (list (ez-read-pc-var-and-inc)
304 (ez-read-pc-var-and-inc))
305 operand-types '(w w)))
306 ((<= #x80 opbyte #x8F)
308 opcode (- opbyte #x80)
309 operands (list (ez-read-pc-word-and-inc))
311 ((<= #x90 opbyte #x9F)
313 opcode (- opbyte #x90)
314 operands (list (ez-read-pc-byte-and-inc))
316 ((<= #xA0 opbyte #xAF)
318 opcode (- opbyte #xa0)
319 operands (list (ez-read-pc-var-and-inc))
321 ((<= #xB0 opbyte #xBF)
323 opcode (- opbyte #xb0)))
324 ((<= #xC0 opbyte #xDF)
325 (error "Unsupported op" opbyte))
326 ((<= #xE0 opbyte #xFF)
328 opcode (- opbyte #xe0))
329 (let ((operands-and-types (ez-read-var-operands-and-inc)))
330 (setq operands (car operands-and-types)
331 operand-types (cdr operands-and-types)))))
332 (let ((table-row (assoc (list optype opcode) ez-op-table)))
334 (error "Unsupported op" optype opcode))
335 (let ((mnemonic (elt table-row 1)))
336 (message "PC:%x Optype:%s Opcode:%x Mnemonic:%s Operands:%s"
337 instr-pc optype opcode mnemonic operands))
338 (funcall (elt table-row 2) operands operand-types))))
340 (defun ez-read-var-operands-and-inc ()
341 (let* ((type-byte (ez-read-pc-byte-and-inc))
342 (bleh (message (binformat type-byte)))
343 (types (let ((type1 (lsh type-byte -6)))
347 (let ((type2 (lsh (logand #b110000 type-byte) -4)))
351 (let ((type3 (lsh (logand #b1100 type-byte) -2)))
355 (let ((type4 (logand #b11)))
358 (list type4)))))))))))))
364 ((= type 0) (ez-read-pc-word-and-inc))
365 ((= type 1) (ez-read-pc-byte-and-inc))
366 ((= type 2) (ez-read-pc-var-and-inc))))
377 (defun ez-do-branch (branch)
378 (let* ((branch-byte (ez-read-pc-byte-and-inc))
379 (invert (= 0 (logand branch-byte #b10000000)))
380 (single-byte (= 1 (logand branch-byte #b01000000)))
383 (logand branch-byte #b00111111)
384 (let ((pos (= (logand branch-byte #b00100000) 0))
385 (val (+ (* 256 (logand branch-byte #b00011111))
386 (ez-read-pc-byte-and-inc))))
396 (ez-set-pc (+ (ez-get-pc) offset -2))))))
401 '(((0op #x00) rtrue ez-op-rtrue)
402 ((0op #x01) rfalse ez-op-rfalse)
403 ((1op #x00) jz ez-op-jz)
404 ((1op #x0B) ret ez-op-ret)
405 ((1op #x0C) jump ez-op-jump)
406 ((2op #x0D) store ez-op-store)
407 ((1op #x0E) load ez-op-load)
408 ((var #x01) storew ez-op-storew)
409 ((2op #x01) je ez-op-je)
410 ((2op #x08) or ez-op-or)
411 ((2op #x09) and ez-op-and)
412 ((2op #x14) add ez-op-add)
413 ((2op #x15) sub ez-op-sub)
414 ((2op #x16) mul ez-op-mul)
415 ((2op #x17) div ez-op-div)
416 ((2op #x18) mod ez-op-mod)
417 ((var #x00) call_fv ez-op-callf)))
419 (defun ez-op-ret (operands &optional operand-types)
420 (let ((retval (car operands)))
421 (ez-pop-call-stack-frame)
422 (ez-set-var (ez-read-pc-byte-and-inc) retval))
425 (defun ez-op-rtrue (&optional operands operand-types)
426 (ez-op-ret (list 1)))
428 (defun ez-op-rfalse (&optional operands operand-types)
429 (ez-op-ret (list 0)))
431 (defun ez-op-jz (operands operand-types)
432 (ez-do-branch (= (car operands) 0))
435 (defun ez-op-je (operands operand-types)
436 (ez-do-branch (memq (car operands) (cdr operands)))
439 (defun ez-op-jump (operands operand-types)
440 (let ((offset (if (eq (car operand-types) 'b)
441 (ez-decode-signed-byte (car operands))
442 (ez-decode-signed-word (car operands)))))
443 (ez-set-pc (+ (ez-get-pc) offset -2)))
446 (defun ez-op-store (operands operand-types)
447 (let ((var (car operands))
452 (defun ez-op-load (operands operand-types)
453 (let ((var (car operands)))
454 (ez-set-var (ez-read-pc-byte-and-inc) (ez-get-var var)))
457 (defun ez-op-storew (operands operand-types)
458 (let ((baddr (car operands))
460 (a (caddr operands)))
461 (ez-mem-set-word (+ baddr (* 2 n)) a))
464 (defun ez-op-and (operands operand-types)
465 (let ((a (car operands))
467 (ez-set-var (ez-read-pc-byte-and-inc) (logand a b)))
470 (defun ez-op-or (operands operand-types)
471 (let ((a (car operands))
473 (ez-set-var (ez-read-pc-byte-and-inc) (logior a b)))
476 (defun ez-op-add (operands operand-types)
477 (let ((a (car operands))
479 (ez-set-var (ez-read-pc-byte-and-inc) (mod (+ a b) #x10000)))
482 (defun ez-op-sub (operands operand-types)
483 (let ((a (car operands))
485 (ez-set-var (ez-read-pc-byte-and-inc) (mod (+ (- a b) #x10000) #x10000)))
488 (defun ez-op-mul (a b)
489 (let ((a (car operands))
491 (ez-set-var (ez-read-pc-byte-and-inc) (mod (* a b) #x10000)))
494 (defun ez-op-div (a b)
495 (error "Not implemented"))
497 (defun ez-op-mod (a b)
498 (error "Not implemented"))
500 (defun ez-op-callf (operands operand-types)
501 (let* ((raddr (car operands))
502 (call-operands (cdr operands))
504 (L (ez-mem-ref-byte r))
505 (n (length call-operands))
506 (new-pc (+ r 1 (* L 2))))
507 (ez-add-call-stack-frame new-pc)
510 (ez-set-local-var (+ i 1) (elt call-operands i))
511 (ez-set-local-var (+ i 1) (ez-mem-ref-word (+ r 1 (* 2 i)))))))
516 (defun ez-run (filename)
517 (ez-load-file filename)
519 (setq ez-call-stack (list (ez-make-call-stack-frame ez-start-pc)))
521 (while (ez-execute-inst)))
525 (ez-load-file "zork1.z3")
527 (setq ez-call-stack (list (ez-make-call-stack-frame ez-start-pc)))
535 ((28281 nil [33807 0 180 47872 0 0 0 0 0 0 0 0 ...] nil) (22022 nil [33807 65535 0 0 0 0 0 0 0 0 0 0 ...] nil) (20715 nil [0 0 0 0 0 0 0 0 0 0 0 0 ...] nil))
537 ((22049 nil [33807 0 180 47872 0 0 0 0 0 0 0 0 ...] nil) (22022 nil [33807 65535 0 0 0 0 0 0 0 0 0 0 ...] nil) (20715 nil [0 0 0 0 0 0 0 0 0 0 0 0 ...] nil))