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 (defvar ez-property-defaults nil)
110 (defun ez-load-property-defaults ()
111 (setq ez-property-defaults (make-vector 31 0))
113 (aset ez-property-defaults i (aref ez-memory (+ ez-objtab-addr (* 2 i))))))
115 (defun ez-get-obj-addr (obj-id)
116 (+ ez-objtab-addr (* 2 31) (* 9 (- obj-id 1))))
118 (defun ez-get-obj-parent (obj-id)
119 (let ((addr (ez-get-obj-addr obj-id)))
120 (ez-mem-ref-byte (+ addr 4))))
122 (defun ez-get-obj-sibling (obj-id)
123 (let ((addr (ez-get-obj-addr obj-id)))
124 (ez-mem-ref-byte (+ addr 5))))
126 (defun ez-get-obj-child (obj-id)
127 (let ((addr (ez-get-obj-addr obj-id)))
128 (ez-mem-ref-byte (+ addr 6))))
130 (defun ez-get-obj-plist-addr (obj-id)
131 (let ((addr (ez-get-obj-addr obj-id)))
132 (ez-mem-ref-word (+ addr 7))))
134 (defun ez-get-obj-name (obj-id)
135 (let ((plist-addr (ez-get-obj-plist-addr obj-id)))
136 (if (> (ez-mem-ref-byte plist-addr) 0)
137 (ez-get-zstring (+ 1 (ez-get-obj-plist-addr obj-id)))
140 (defun ez-get-obj (obj-id)
141 (let ((addr (+ ez-objtab-addr
143 (* 9 (- obj-id 1)))))
146 (ez-mem-ref-byte (+ addr 4))
147 (ez-mem-ref-byte (+ addr 5))
148 (ez-mem-ref-byte (+ addr 6))
149 (ez-mem-ref-word (+ addr 7))
150 (let ((plist-addr (ez-mem-ref-word (+ addr 7))))
151 (if (> (ez-mem-ref-byte plist-addr) 0)
152 (ez-get-zstring (+ 1 plist-addr))
158 (defvar ez-zstring-alphabets
161 (list " abcdefghijklmnopqrstuvwxyz"
162 " ABCDEFGHIJKLMNOPQRSTUVWXYZ"
163 " \n0123456789.,!?_#'\"/\\-:()")
164 "Alphabets used by V3")
166 (defun ez-parse-zstring-word (word)
168 (logand (lsh word -10) #b11111)
169 (logand (lsh word -5) #b11111)
170 (logand word #b11111)))
172 (defun ez-get-zstring-chars (base-addr)
173 (let ((addr base-addr)
177 (let ((components (ez-parse-zstring-word (ez-mem-ref-word addr))))
178 (setq chars (append chars (cdr components)))
179 (setq addr (+ addr 2))
180 (when (= (car components) 1)
181 (setq not-done nil))))
184 (defun ez-get-zstring (base-addr)
185 (let ((chars (ez-get-zstring-chars base-addr))
194 (* 2 (ez-mem-ref-word (+ ez-abbrevtab-addr
195 (* 2 (+ (* (- abbrev-char 1) 32) char)))))))
196 (setq s (concat s (ez-get-zstring abbrev-addr))))
197 (setq abbrev-char nil))
198 ((memq char '(1 2 3)) ;Abbreviation
199 (setq abbrev-char char))
201 (setq cur (mod (+ cur 1) 3)))
203 (setq cur (mod (+ 3 (- cur 1)) 3)))
205 (setq s (concat s (substring (elt ez-zstring-alphabets cur)
213 (defvar ez-call-stack nil)
215 (defun ez-make-call-stack-frame (pc &optional call-method)
221 (defun ez-add-call-stack-frame (pc &optional call-method)
222 (push (ez-make-call-stack-frame pc call-method) ez-call-stack))
224 (defun ez-pop-call-stack-frame ()
227 (defun ez-routine-stack ()
228 (elt (car ez-call-stack) 1))
230 (defun ez-routine-stack-push (val)
231 (let ((frame (car ez-call-stack)))
232 (setf (elt frame 1) (cons val (elt frame 1)))))
234 (defun ez-routine-stack-pop ()
235 (let* ((frame (car ez-call-stack))
236 (rs-head (car (elt frame 1))))
237 (setf (elt frame 1) (cdr (elt frame 1)))
240 (defun ez-get-local-var (lvar)
241 (let ((frame (car ez-call-stack)))
242 (aref (elt frame 2) (- lvar 1))))
244 (defun ez-set-local-var (lvar val)
245 (let ((frame (car ez-call-stack)))
246 (aset (elt frame 2) (- lvar 1) val)))
249 (caar ez-call-stack))
251 (defun ez-set-pc (new-pc)
252 (setf (car (car ez-call-stack)) new-pc))
254 (defun ez-increment-pc (inc)
255 (ez-set-pc (+ (ez-get-pc) inc)))
257 (defun ez-read-pc-byte-and-inc ()
258 (let ((res (ez-mem-ref-byte (ez-get-pc))))
262 (defun ez-read-pc-word-and-inc ()
263 (let ((res (ez-mem-ref-word (ez-get-pc))))
267 ;; Instruction execution
269 (defun ez-get-var (var)
272 (ez-routine-stack-pop))
274 (ez-get-local-var var))
276 (ez-get-global-var (- var 16)))))
278 (defun ez-set-var (var val)
281 (ez-routine-stack-push val))
283 (ez-set-local-var var val))
285 (ez-set-global-var (- var 16) val))))
287 (defun ez-read-pc-var-and-inc ()
288 (ez-get-var (ez-read-pc-byte-and-inc)))
290 (defun ez-execute-instr ()
291 (let ((instr-pc (ez-get-pc))
292 (opbyte (ez-read-pc-byte-and-inc))
297 ((<= #x0 opbyte #x1f)
300 operands (list (ez-read-pc-byte-and-inc)
301 (ez-read-pc-byte-and-inc))
302 operand-types '(b b)))
303 ((<= #x20 opbyte #x3F)
305 opcode (- opbyte #x20)
306 operands (list (ez-read-pc-byte-and-inc)
307 (ez-read-pc-var-and-inc))
308 operand-types '(b w)))
309 ((<= #x40 opbyte #x5F)
311 opcode (- opbyte #x40)
312 operands (list (ez-read-pc-var-and-inc)
313 (ez-read-pc-byte-and-inc))
314 operand-types '(w b)))
315 ((<= #x60 opbyte #x7F)
317 opcode (- opbyte #x60)
318 operands (list (ez-read-pc-var-and-inc)
319 (ez-read-pc-var-and-inc))
320 operand-types '(w w)))
321 ((<= #x80 opbyte #x8F)
323 opcode (- opbyte #x80)
324 operands (list (ez-read-pc-word-and-inc))
326 ((<= #x90 opbyte #x9F)
328 opcode (- opbyte #x90)
329 operands (list (ez-read-pc-byte-and-inc))
331 ((<= #xA0 opbyte #xAF)
333 opcode (- opbyte #xa0)
334 operands (list (ez-read-pc-var-and-inc))
336 ((<= #xB0 opbyte #xBF)
338 opcode (- opbyte #xb0)))
339 ((<= #xC0 opbyte #xDF)
340 (error "Unsupported op" opbyte))
341 ((<= #xE0 opbyte #xFF)
343 opcode (- opbyte #xe0))
344 (let ((operands-and-types (ez-read-var-operands-and-inc)))
345 (setq operands (car operands-and-types)
346 operand-types (cdr operands-and-types)))))
347 (let ((table-row (assoc (list optype opcode) ez-op-table)))
349 (error "Unsupported op" instr-pc optype opcode operands operand-types))
350 (let ((mnemonic (elt table-row 1)))
351 (message "PC:%x Optype:%s Opcode:%x Mnemonic:%s Operands:%s"
352 instr-pc optype opcode mnemonic operands))
353 (funcall (elt table-row 2) operands operand-types))))
355 (defun ez-read-var-operands-and-inc ()
356 (let* ((type-byte (ez-read-pc-byte-and-inc))
357 (bleh (message (binformat type-byte)))
358 (types (let ((type1 (lsh type-byte -6)))
362 (let ((type2 (lsh (logand #b110000 type-byte) -4)))
366 (let ((type3 (lsh (logand #b1100 type-byte) -2)))
370 (let ((type4 (logand #b11)))
373 (list type4)))))))))))))
379 ((= type 0) (ez-read-pc-word-and-inc))
380 ((= type 1) (ez-read-pc-byte-and-inc))
381 ((= type 2) (ez-read-pc-var-and-inc))))
392 (defun ez-do-branch (branch)
393 (let* ((branch-byte (ez-read-pc-byte-and-inc))
394 (invert (= 0 (logand branch-byte #b10000000)))
395 (single-byte (= 1 (logand branch-byte #b01000000)))
398 (logand branch-byte #b00111111)
399 (let ((pos (= (logand branch-byte #b00100000) 0))
400 (val (+ (* 256 (logand branch-byte #b00011111))
401 (ez-read-pc-byte-and-inc))))
411 (ez-set-pc (+ (ez-get-pc) offset -2))))))
416 '(((0op #x00) rtrue ez-op-rtrue)
417 ((0op #x01) rfalse ez-op-rfalse)
418 ((1op #x00) jz ez-op-jz)
419 ((1op #x0B) ret ez-op-ret)
420 ((1op #x0C) jump ez-op-jump)
421 ((2op #x0D) store ez-op-store)
422 ((1op #x0E) load ez-op-load)
423 ((var #x01) storew ez-op-storew)
424 ((2op #x01) je ez-op-je)
425 ((2op #x08) or ez-op-or)
426 ((2op #x09) and ez-op-and)
427 ((2op #x14) add ez-op-add)
428 ((2op #x15) sub ez-op-sub)
429 ((2op #x16) mul ez-op-mul)
430 ((2op #x17) div ez-op-div)
431 ((2op #x18) mod ez-op-mod)
432 ((var #x00) call_fv ez-op-callf)))
434 (defun ez-op-ret (operands &optional operand-types)
435 (let ((retval (car operands)))
436 (ez-pop-call-stack-frame)
437 (ez-set-var (ez-read-pc-byte-and-inc) retval))
440 (defun ez-op-rtrue (&optional operands operand-types)
441 (ez-op-ret (list 1)))
443 (defun ez-op-rfalse (&optional operands operand-types)
444 (ez-op-ret (list 0)))
446 (defun ez-op-jz (operands operand-types)
447 (ez-do-branch (= (car operands) 0))
450 (defun ez-op-je (operands operand-types)
451 (ez-do-branch (memq (car operands) (cdr operands)))
454 (defun ez-op-jump (operands operand-types)
455 (let ((offset (if (eq (car operand-types) 'b)
456 (ez-decode-signed-byte (car operands))
457 (ez-decode-signed-word (car operands)))))
458 (ez-set-pc (+ (ez-get-pc) offset -2)))
461 (defun ez-op-store (operands operand-types)
462 (let ((var (car operands))
467 (defun ez-op-load (operands operand-types)
468 (let ((var (car operands)))
469 (ez-set-var (ez-read-pc-byte-and-inc) (ez-get-var var)))
472 (defun ez-op-storew (operands operand-types)
473 (let ((baddr (car operands))
475 (a (caddr operands)))
476 (ez-mem-set-word (+ baddr (* 2 n)) a))
479 (defun ez-op-and (operands operand-types)
480 (let ((a (car operands))
482 (ez-set-var (ez-read-pc-byte-and-inc) (logand a b)))
485 (defun ez-op-or (operands operand-types)
486 (let ((a (car operands))
488 (ez-set-var (ez-read-pc-byte-and-inc) (logior a b)))
491 (defun ez-op-add (operands operand-types)
492 (let ((a (car operands))
494 (ez-set-var (ez-read-pc-byte-and-inc) (mod (+ a b) #x10000)))
497 (defun ez-op-sub (operands operand-types)
498 (let ((a (car operands))
500 (ez-set-var (ez-read-pc-byte-and-inc) (mod (+ (- a b) #x10000) #x10000)))
503 (defun ez-op-mul (a b)
504 (let ((a (car operands))
506 (ez-set-var (ez-read-pc-byte-and-inc) (mod (* a b) #x10000)))
509 (defun ez-op-div (a b)
510 (error "Not implemented"))
512 (defun ez-op-mod (a b)
513 (error "Not implemented"))
515 (defun ez-op-callf (operands operand-types)
516 (let* ((raddr (car operands))
517 (call-operands (cdr operands))
519 (L (ez-mem-ref-byte r))
520 (n (length call-operands))
521 (new-pc (+ r 1 (* L 2))))
522 (ez-add-call-stack-frame new-pc)
525 (ez-set-local-var (+ i 1) (elt call-operands i))
526 (ez-set-local-var (+ i 1) (ez-mem-ref-word (+ r 1 (* 2 i)))))))
531 (defun ez-run (filename)
532 (ez-load-file filename)
534 (setq ez-call-stack (list (ez-make-call-stack-frame ez-start-pc)))
536 (while (ez-execute-inst)))
540 (ez-load-file "zork1.z3")
542 (setq ez-call-stack (list (ez-make-call-stack-frame ez-start-pc)))
545 (while (ez-execute-instr))
556 ((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))
558 ((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))