Initial commit

README.md

@@ -1,2 +1,5 @@
-# lzm
-Lisp Z-Machine
+# Lisp Z-Machine
+
+This is a simple Z-Machine implementation, built as a learning exercise.
+It currently supports only v3 story files. 
+

cpu.lisp

@@ -0,0 +1,45 @@
+(in-package #:lzm)
+
+(defvar *stack*)
+(defvar *frame*)
+(defvar *pc*)
+(defvar *break*)
+
+(defun fetch-u8 ()  
+  (prog1 (read-u8 *pc*)
+    (incf *pc*)))
+
+(defun fetch-u16 ()
+  (prog1 (read-u16 *pc*)
+    (incf *pc* 2)))
+
+(defun stack-push (value)
+  (vector-push-extend value *stack*))
+
+(defun stack-pop ()
+  (vector-pop *stack*))
+
+(defun stack-top ()
+  (aref *stack* (1- (length *stack*))))
+
+(defun ret (val)
+  (setf (fill-pointer *stack*) *frame*
+        *frame* (stack-pop)
+        *pc* (stack-pop))
+  (write-var (stack-pop) val))
+
+(defun branch (condition)
+  (setf condition (not (not condition)))
+  (let* ((b (fetch-u8))
+         (offset (ldb (byte 6 0) b)))
+    (unless (logbitp 6 b)
+      (let ((b2 (fetch-u8)))
+        (setf offset (logior (ash offset 8) b2))))
+    (when (logbitp 13 offset)
+      ;; Handle negative branch
+      (decf offset #x4000))
+    (when (eql condition (logbitp 7 b))
+      (case offset
+        (0 (ret 0))
+        (1 (ret 1))
+        (otherwise (incf *pc* (-  offset 2)))))))

decode.lisp

@@ -0,0 +1,57 @@
+(in-package #:lzm)
+
+(defconstant +operand-type-word+ 0)
+(defconstant +operand-type-byte+ 1)
+(defconstant +operand-type-var+  2)
+(defconstant +operand-type-none+ 3)
+
+(defun read-operand (operand-type)
+  (ecase operand-type
+    (#.+operand-type-word+ (fetch-u16))
+    (#.+operand-type-byte+ (fetch-u8))
+    (#.+operand-type-var+ (read-var (fetch-u8)))))
+
+(defun decode-operand-types (b)
+  (loop for pos from 6 downto 0 by 2
+        for type = (ldb (byte 2 pos) b)
+        until (= type +operand-type-none+)
+        collect type))
+
+(defun opcode-type (b)
+  (cond
+    ((and (= b #xbe) (>= *version* 5)) :opcode-type-ext)
+    ((not (logbitp 7 b)) :opcode-type-long)
+    ((logbitp 6 b) :opcode-type-var)
+    (t :opcode-type-short)))
+
+(defun decode-instruction ()
+  (let ((b (fetch-u8)))
+    (ecase (opcode-type b)
+      (:opcode-type-ext nil)
+      (:opcode-type-long
+       (list :2op
+             (logand b #b11111)
+             (if (logbitp 6 b) +operand-type-var+ +operand-type-byte+)
+             (if (logbitp 5 b) +operand-type-var+ +operand-type-byte+)))
+      (:opcode-type-var
+       (list* (if (logbitp 5 b) :var :2op)
+              (logand b #b11111)
+              (decode-operand-types (fetch-u8))))
+      (:opcode-type-short
+       (let ((opcode (ldb (byte 4 0) b))
+             (operand-type (ldb (byte 2 4) b)))
+         (if (= operand-type +operand-type-none+)
+             (list :0op opcode)
+             (list :1op opcode operand-type)))))))
+
+(defun next-instruction ()
+  (let ((pc *pc*))
+    (destructuring-bind (arity opcode &rest optypes) (decode-instruction)
+      (let ((operands (mapcar #'read-operand optypes)))
+        (if-let (handler (find-handler arity opcode))
+          (progn
+        ;;    (format t "PC $~x: ~a ~a ~%" pc handler operands)
+            (apply handler operands))
+          (progn
+            (format t "No handler for ~a $~x at PC $~x" arity opcode pc)
+            (setf *break* t)))))))

header.lisp

@@ -0,0 +1,30 @@
+(in-package #:lzm)
+
+(defvar *version*)
+(defvar *high-memory-offset*)
+(defvar *initial-pc*)
+(defvar *dictionary-offset*)
+(defvar *object-table-offset*)
+(defvar *global-table-offset*)
+(defvar *static-memory-offset*)
+(defvar *abbrev-table-offset*)
+
+(defun read-header ()
+  (setf *version*              (read-u8 #x00)
+        *high-memory-offset*   (read-u16 #x04)
+        *initial-pc*           (read-u16 #x06)
+        *dictionary-offset*    (read-u16 #x08)
+        *object-table-offset*  (read-u16 #x0a)
+        *global-table-offset*  (read-u16 #x0c)
+        *static-memory-offset* (read-u16 #x0e)
+        *abbrev-table-offset*  (read-u16 #x18)))
+
+(defun print-header ()
+  (format t "Version:              ~d~%"     *version*)
+  (format t "High memory offset:   ~4,'0x~%" *high-memory-offset*)
+  (format t "Initial PC:           ~4,'0x~%" *initial-pc*)
+  (format t "Dictionary offset:    ~4,'0x~%" *dictionary-offset*)
+  (format t "Object table offset:  ~4,'0x~%" *object-table-offset*)
+  (format t "Global table offset:  ~4,'0x~%" *global-table-offset*)
+  (format t "Static memory offset: ~4,'0x~%" *static-memory-offset*)
+  (format t "Abbrev table offset:  ~4,'0x~%" *abbrev-table-offset*))

lzm.asd

@@ -0,0 +1,16 @@
+(defsystem :lzm
+  :author "Nick Maher"
+  :description "Lisp Z-Machine"
+  :depends-on (:alexandria)
+  :components ((:file "packages")
+               (:file "mem")
+               (:file "header")
+               (:file "text")
+               (:file "var")
+               (:file "obj")
+               (:file "cpu")
+               (:file "rand")
+               (:file "tok")
+               (:file "op")
+               (:file "decode")
+               (:file "main")))

main.lisp

@@ -0,0 +1,39 @@
+(in-package #:lzm)
+
+(defun read-data (filename)
+  (with-open-file (f filename :element-type '(unsigned-byte 8))
+    (let ((data (make-array (file-length f)
+                            :element-type '(unsigned-byte 8))))
+      (read-sequence data f)
+      data)))
+
+(defun init (filename)
+  (setf *memory* (read-data filename))
+  (read-header)
+  ;; TODO: Validate header
+  (init-dictionary)
+  (setf *pc* *initial-pc*)
+  (setf *frame* 0)
+  (setf *break* nil)
+  (setf *rand-seed* nil)
+  (setf *stack* (make-array 0 :fill-pointer 0
+                              :adjustable t
+                              :element-type '(unsigned-byte 32))))
+
+(defun run (filename)
+  (init filename)
+  (loop until *break* do
+    ;;    (format t "PC: $~x~%" *pc*)
+    (next-instruction)))
+
+(defun run-hitch () (run "/Users/nickm/infocom/hitchhiker-r60-s861002.z3"))
+(defun run-zork () (run "/Users/nickm/infocom/zork1-r88-s840726.z3"))
+(defun run-czech () (run "/Users/nickm/infocom/czech_0_8/czech.z3"))
+
+(defun log-czech ()
+  (with-open-file (*standard-output* "czech.log"
+                                     :direction :output
+                                     :if-does-not-exist :create
+                                     :if-exists :overwrite)
+    (run-czech)))
+

mem.lisp

@@ -0,0 +1,29 @@
+(in-package #:lzm)
+
+(defvar *memory*)
+
+(defun read-u8 (addr)
+  (aref *memory* addr))
+
+(defun read-u16 (addr)
+  (logior (ash (read-u8 addr) 8) (read-u8 (1+ addr))))
+
+(defun read-word-addr (addr)
+  (* 2 (read-u16 addr)))
+
+(defun write-u8 (addr value)
+  (assert (< addr *static-memory-offset*))
+  (setf (aref *memory* addr) value))
+
+(defun write-u16 (addr value)
+  (assert (< (1+ addr) *static-memory-offset*))
+  (setf (aref *memory* addr) (ash value -8)
+        (aref *memory* (1+ addr)) (logand value #xff)))
+
+(defun u16->s16 (n)
+  (if (logbitp 15 n)
+      (- n #x10000)
+      n))
+
+(defun s16->u16 (n)
+  (logand #xffff n))

obj.lisp

@@ -0,0 +1,128 @@
+(in-package #:lzm)
+
+(defun obj-property-default (property)
+  (read-u16 (+ *object-table-offset* (* (1- property) 2))))
+
+(defun obj-address (obj)
+  (assert (plusp obj))
+  (+ *object-table-offset* 62 (* (1- obj) 9)))
+
+(defun obj-attr-address (obj attr)
+  (multiple-value-bind (byte bit) (floor attr 8)
+    (values (+ (obj-address obj) byte)
+            (- 7 bit))))
+
+(defun obj-attr (obj attr)
+  (multiple-value-bind (addr bit) (obj-attr-address obj attr)
+    (logbitp bit (read-u8 addr))))
+
+(defun (setf obj-attr) (val obj attr)
+  (multiple-value-bind (addr bit) (obj-attr-address obj attr)
+    (write-u8 addr (dpb (if val 1 0)
+                        (byte 1 bit)
+                        (read-u8 addr)))))
+
+(defun obj-parent (obj)
+  (read-u8 (+ (obj-address obj) 4)))
+
+(defun (setf obj-parent) (val obj)
+  (write-u8 (+ (obj-address obj) 4) val))
+
+(defun obj-sibling (obj)
+  (read-u8 (+ (obj-address obj) 5)))
+
+(defun (setf obj-sibling) (val obj)
+  (write-u8 (+ (obj-address obj) 5) val))
+
+(defun obj-child (obj)
+  (read-u8 (+ (obj-address obj) 6)))
+
+(defun (setf obj-child) (val obj)
+  (write-u8 (+ (obj-address obj) 6) val))
+
+(defun obj-prev-sibling (obj)
+  (let ((parent (obj-parent obj)))
+    (if (zerop parent)
+        0
+        (loop for s = (obj-child parent) then (obj-sibling s)
+              and prev = 0 then s
+              finally (return 0)
+              when (= s obj) do (return prev)))))
+
+(defun obj-name-addr (obj)
+  (read-u16 (+ (obj-address obj) 7)))
+
+(defun obj-name-byte-len (obj)
+  (* 2 (read-u8 (obj-name-addr obj))))
+
+(defun obj-name (obj)
+  (decode-text (+ 1 (obj-name-addr obj))))
+
+(defun obj-properties-addr (obj)
+  (+ (obj-name-addr obj) (obj-name-byte-len obj) 1))
+
+;; Return a list of (prop, addr, size) tuples
+(defun obj-property-list (obj)
+  (loop with addr = (obj-properties-addr obj)
+        for size-byte = (read-u8 addr)
+        for prop = (logand size-byte #b11111)
+        for size = (1+ (ash size-byte -5))
+        until (zerop prop)
+        collect (list prop (1+ addr) size)
+        do (incf addr (1+ size))))
+
+(defun obj-first-prop (obj)
+  (caar (obj-property-list obj)))
+
+(defun obj-next-prop (obj prop)
+  (let ((plist (obj-property-list obj)))
+    (when-let (i (position prop plist :key #'first))
+      (first (nth (1+ i) plist)))))
+
+(defun obj-prop-addr (obj prop)
+  (when-let (p (find prop (obj-property-list obj) :key #'first))
+    (second p)))
+
+(defun obj-prop-len (prop-addr)
+  (if (zerop prop-addr)
+      0
+      (let ((b (read-u8 (1- prop-addr))))
+        (1+ (ash b -5)))))
+
+(defun obj-prop (obj prop)
+  (if-let (p (find prop (obj-property-list obj) :key #'first))
+    (destructuring-bind (prop addr size) p
+      (declare (ignore prop))
+      (ecase size
+        (1 (read-u8 addr))
+        (2 (read-u16 addr))
+        (t (error "invalid property size"))))
+    (obj-property-default prop)))
+
+(defun (setf obj-prop) (val obj prop)
+  (let ((p (find prop (obj-property-list obj) :key #'first)))
+    (unless p (error "put to invalid property"))
+    (destructuring-bind (prop addr size) p
+      (declare (ignore prop))
+      (ecase size
+        (1 (write-u8 addr val))
+        (2 (write-u16 addr val))
+        (t (error "invalid property size"))))))
+
+(defun obj-remove (obj)
+  (let ((parent (obj-parent obj))
+        (sibling (obj-sibling obj))
+        (prev-sibling (obj-prev-sibling obj)))
+    (when (plusp parent)
+      (if (zerop prev-sibling)
+          (setf (obj-child parent) sibling)
+          (setf (obj-sibling prev-sibling) sibling))
+      (setf (obj-sibling obj) 0)
+      (setf (obj-parent obj) 0))))
+
+(defun obj-insert (obj dst)
+  (obj-remove obj)
+ ;; (format t "Moving ~a to ~a~%" (obj-name obj) (obj-name dst))
+  (setf (obj-sibling obj) (obj-child dst))
+  (setf (obj-child dst) obj)
+  (setf (obj-parent obj) dst))