ez.el

   1 ;;; ez.el --- Emacs Z-machine
   2
   3 ;; Copyright (C) 2021,2022,2023 Tim Vaughan
   4
   5 ;; Author: Tim Vaughan <plugd@thelambdalab.xyz>
   6 ;; Created: 13 Oct 2021
   7 ;; Version: 1.0
   8 ;; Keywords: game
   9 ;; Homepage: http://thelambdalab.xyz/ez
  10 ;; Package-Requires: ((emacs "26"))
  11
  12 ;; This file is not part of GNU Emacs.
  13
  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.
  18
  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.
  23
  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/>.
  26
  27 ;;; Commentary:
  28
  29 ;; There are many Z-machine interpreters, but this one is mine.
  30 ;; It only capable of interpreting the subset of Z-code necessary
  31 ;; to run the first Zork game in z3 format.
  32 ;;
  33 ;; It is based entirely on the description of the Z-machine contained
  34 ;; Marnix Klooster's wonderful document, "The Z-machine And How to Emulate It."
  35
  36 ;;; Code:
  37
  38 ;; Utility functions
  39
  40 (defun ez-decode-signed-bits (n nbits)
  41   (if (= 0 (lsh n (- 1 nbits)))
  42       n
  43     (- n (lsh 1 nbits))))
  44
  45 (defun ez-decode-signed-byte (b)
  46   (ez-decode-signed-bits b 8))
  47
  48 (defun ez-decode-signed-word (w)
  49   (ez-decode-signed-bits w 16))
  50
  51 (defun ez-decode-signed-operand (operand operand-type)
  52   (if (eq operand-type 'b)
  53       (ez-decode-signed-byte operand)
  54     (ez-decode-signed-word operand)))
  55
  56 (defun binformat (n &optional s)
  57   (unless s
  58     (setq s ""))
  59   (let ((d (/ n 2))
  60         (new-s (concat (number-to-string (mod n 2)) s)))
  61     (if (= d 0)
  62         new-s
  63       (binformat d new-s))))
  64
  65 (defun ez-list-to-string-hex (l)
  66   (concat "("
  67           (when l
  68             (concat
  69              (format "%x" (car l))
  70              (apply 'concat (mapcar (lambda (n) (format " %x" n)) (cdr l)))))
  71           ")"))
  72
  73 ;; Memory
  74
  75 (defvar ez-memory nil
  76   "Memory of z-machine.")
  77
  78 (defvar ez-version nil)
  79
  80 (defvar ez-start-pc nil)
  81 (defvar ez-himem-base nil)
  82 (defvar ez-dict-base nil)
  83 (defvar ez-objtab-addr nil)
  84 (defvar ez-abbrevtab-addr nil)
  85 (defvar ez-globalvartab-addr nil)
  86
  87 (defvar ez-dict-entries nil
  88   "Parsed dictionary")
  89
  90 (defvar ez-dict-separators nil
  91   "Parsed dictionary")
  92
  93 (defun ez-mem-ref-byte (addr)
  94   (aref ez-memory addr))
  95
  96 (defun ez-mem-set-byte (addr val)
  97   (aset ez-memory addr val))
  98
  99 (defun ez-mem-set-bytes (addr vals)
 100   (dotimes (i (length vals))
 101     (ez-mem-set-byte (+ addr i) (elt vals i))))
 102
 103 (defun ez-mem-ref-word (addr)
 104   (+ (* 256 (aref ez-memory addr))
 105      (aref ez-memory (+ addr 1))))
 106
 107 (defun ez-mem-set-word (addr val)
 108   (let ((byte-high (/ val 256))
 109         (byte-low (mod val 256)))
 110     (aset ez-memory addr byte-high)
 111     (aset ez-memory (+ addr 1) byte-low)))
 112
 113 (defun ez-mem-ref-string (addr1 addr2)
 114   (substring ez-memory addr1 addr2))
 115
 116 (defun ez-parse-header ()
 117   (setq ez-version (ez-mem-ref-byte #x0))
 118   (setq ez-himem-addr (ez-mem-ref-word #x4))
 119   (setq ez-start-pc (ez-mem-ref-word #x6))
 120   (setq ez-dict-base (ez-mem-ref-word #x8))
 121   (setq ez-objtab-addr (ez-mem-ref-word #xA))
 122   (setq ez-globalvartab-addr (ez-mem-ref-word #xC))
 123   (setq ez-abbrevtab-addr (ez-mem-ref-word #x18)))
 124
 125 (defun ez-load-file (filename)
 126   "Load story file into memory."
 127   (with-temp-buffer
 128     (insert-file-contents-literally filename)
 129     (setq ez-memory (encode-coding-string (buffer-string) 'raw-text)))
 130   'done)
 131
 132 ;; Global variables
 133
 134 (defun ez-get-global-var (gvar)
 135   (if (> gvar 239)
 136       (error "Invalid global variable %d" gvar))
 137   (let ((val
 138          (ez-mem-ref-word (+ (* 2 gvar) ez-globalvartab-addr))))
 139     (ez-debug-message "\tRetrieved %x from global variable %x" val gvar)
 140     val))
 141
 142 (defun ez-set-global-var (gvar val)
 143   (ez-mem-set-word (+ (* 2 gvar) ez-globalvartab-addr) val)
 144   (ez-debug-message "\tSet global variabl %x to %x" gvar val))
 145
 146 ;; Object tree
 147
 148 (defvar ez-property-defaults nil)
 149
 150 (defun ez-load-property-defaults ()
 151   (setq ez-property-defaults (make-vector 31 0))
 152   (dotimes (i 31)
 153     (aset ez-property-defaults i (aref ez-memory (+ ez-objtab-addr (* 2 i))))))
 154
 155 (defun ez-get-obj-addr (obj)
 156   (+ ez-objtab-addr (* 2 31) (* 9 (- obj 1))))
 157
 158 (defun ez-get-obj-parent (obj)
 159   (let ((addr (ez-get-obj-addr obj)))
 160     (ez-mem-ref-byte (+ addr 4))))
 161
 162 (defun ez-set-obj-parent (obj new-parent)
 163   (let ((addr (ez-get-obj-addr obj)))
 164     (ez-mem-set-byte (+ addr 4) new-parent)))
 165
 166 (defun ez-get-obj-sibling (obj)
 167   (let ((addr (ez-get-obj-addr obj)))
 168     (ez-mem-ref-byte (+ addr 5))))
 169
 170 (defun ez-set-obj-sibling (obj new-sibling)
 171   (let ((addr (ez-get-obj-addr obj)))
 172     (ez-mem-set-byte (+ addr 5) new-sibling)))
 173
 174 (defun ez-get-obj-child (obj)
 175   (let ((addr (ez-get-obj-addr obj)))
 176     (ez-mem-ref-byte (+ addr 6))))
 177
 178 (defun ez-set-obj-child (obj new-child)
 179   (let ((addr (ez-get-obj-addr obj)))
 180     (ez-mem-set-byte (+ addr 6) new-child)))
 181
 182 (defun ez-get-obj-plist-addr (obj)
 183   (let ((addr (ez-get-obj-addr obj)))
 184     (ez-mem-ref-word (+ addr 7))))
 185
 186 (defun ez-get-obj-name (obj)
 187   (let ((plist-addr (ez-get-obj-plist-addr obj)))
 188     (if (> (ez-mem-ref-byte plist-addr) 0)
 189         (ez-get-zstring (+ 1 (ez-get-obj-plist-addr obj)))
 190       nil)))
 191
 192 (defun ez-get-prop-default (prop)
 193   (ez-mem-ref-word (+ ez-objtab-addr (* 2 (+ 1 prop)))))
 194
 195 (defun ez-get-prop-len (prop-size-byte)
 196   (lsh prop-size-byte -5))
 197
 198 (defun ez-get-prop-num (prop-size-byte)
 199   (logand #b00011111 prop-size-byte))
 200
 201 (defun ez-get-obj-prop-addr (obj prop)
 202   (let* ((plist-addr (ez-get-obj-plist-addr obj))
 203          (prop-addr (+ plist-addr 1 (* 2 (ez-mem-ref-byte plist-addr))))
 204          (size-byte (ez-mem-ref-byte prop-addr)))
 205     (while (not (or (= size-byte 0)
 206                     (= prop (ez-get-prop-num size-byte))))
 207       (setq prop-addr (+ prop-addr (ez-get-prop-len size-byte) 2)
 208             size-byte (ez-mem-ref-byte prop-addr)))
 209     prop-addr))
 210
 211 (defun ez-get-obj-prop (obj prop)
 212   (let* ((prop-addr (ez-get-obj-prop-addr obj prop))
 213          (size-byte (ez-mem-ref-byte prop-addr)))
 214     (if (= size-byte 0)
 215         (ez-get-prop-default prop)
 216       (let ((prop-len (ez-get-prop-len size-byte))
 217             (data-addr (+ prop-addr 1)))
 218         (cond
 219          ((= prop-len 0)
 220           (ez-mem-ref-byte data-addr))
 221          ((>= prop-len 1)
 222           (ez-mem-ref-word data-addr)))))))
 223
 224 (defun ez-set-obj-prop (obj prop value)
 225   (let* ((prop-addr (ez-get-obj-prop-addr obj prop))
 226          (size-byte (ez-mem-ref-byte prop-addr)))
 227     (cond
 228      ((= size-byte 0)
 229       (error "Tried to set non-existant property"))
 230      ((= (ez-get-prop-len size-byte) 1)
 231       (ez-mem-set-byte (+ prop-addr 1) value))
 232      (t
 233       (ez-mem-set-word (+ prop-addr 1) value)))))
 234
 235 (defun ez-get-obj-attr (obj attr)
 236   (let* ((byte-num (/ attr 8))
 237          (bit-num (mod attr 8))
 238          (bit-mask (lsh 1 (- 7 bit-num))))
 239     (if (> (logand bit-mask (ez-mem-ref-byte (+ (ez-get-obj-addr obj) byte-num))) 0)
 240         1
 241       0)))
 242
 243 (defun ez-set-obj-attr (obj attr val)
 244   (let* ((byte-num (/ attr 8))
 245          (bit-num (mod attr 8))
 246          (bit-mask (lsh 1 (- 7 bit-num)))
 247          (byte-addr (+ (ez-get-obj-addr obj) byte-num))
 248          (byte (ez-mem-ref-byte byte-addr))
 249          (current-set (> (logand bit-mask byte) 0)))
 250     (if (or (and current-set (= val 0))
 251             (and (not current-set) (> val 0)))
 252         (ez-mem-set-byte byte-addr (logxor byte bit-mask)))))
 253
 254
 255 (defun ez-remove-obj (obj)
 256   (let ((parent (ez-get-obj-parent obj))
 257         (sibling (ez-get-obj-sibling obj)))
 258     (unless (= parent 0)
 259       (let ((child (ez-get-obj-child parent)))
 260         (if (= child obj)
 261             (ez-set-obj-child parent sibling)
 262           (while (not (= obj (ez-get-obj-sibling child)))
 263             (setq child (ez-get-obj-sibling child)))
 264           (ez-set-obj-sibling child (ez-get-obj-sibling obj))))
 265       (ez-set-obj-parent obj 0))
 266     (ez-set-obj-sibling obj 0)))
 267
 268 (defun ez-insert-obj (obj new-parent)
 269   (ez-remove-obj obj)
 270   (unless (= new-parent 0)
 271     (ez-set-obj-sibling obj (ez-get-obj-child new-parent))
 272     (ez-set-obj-child new-parent obj)))
 273
 274 ;; Z-strings
 275
 276 (defvar ez-zstring-alphabets
 277   ;                1    1    2    2    3
 278   ;      0    5    0    5    0    5    0
 279   (list "      abcdefghijklmnopqrstuvwxyz"
 280         "      ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 281         "       \n0123456789.,!?_#'\"/\\-:()")
 282   "Alphabets used by V3")
 283
 284 (defun ez-parse-zstring-word (word)
 285   (list (lsh word -15)
 286         (logand (lsh word -10) #b11111)
 287         (logand (lsh word -5) #b11111)
 288         (logand word #b11111)))
 289
 290 (defun ez-get-zstring-chars-and-length (base-addr)
 291   (let ((addr base-addr)
 292         (chars nil)
 293         (not-done t)
 294         (word-count 0))
 295     (while not-done
 296       (let ((components (ez-parse-zstring-word (ez-mem-ref-word addr))))
 297         (setq chars (append chars (cdr components)))
 298         (setq addr (+ addr 2))
 299         (setq word-count (+ word-count 1))
 300         (when (= (car components) 1)
 301           (setq not-done nil))))
 302     (cons word-count chars)))
 303
 304 (defun ez-get-zstring-and-length (base-addr)
 305   (let* ((word-count-and-chars (ez-get-zstring-chars-and-length base-addr))
 306          (word-count (car word-count-and-chars))
 307          (chars (cdr word-count-and-chars))
 308          (cur 0)
 309          (lock 0)
 310          (s ""))
 311     (while (> (length chars) 0)
 312       (let ((char (pop chars)))
 313         (cond
 314          ((memq char '(1 2 3)) ;Abbreviation
 315           (let* ((abbrev-char char)
 316                  (abbrev-addr
 317                   (* 2 (ez-mem-ref-word (+ ez-abbrevtab-addr
 318                                            (* 2 (+ (* (- abbrev-char 1) 32) (pop chars))))))))
 319             (setq s (concat s (cdr (ez-get-zstring-and-length abbrev-addr))))))
 320          ((= char 4)
 321           (setq cur (mod (+ cur 1) 3)))
 322          ((= char 5)
 323           (setq cur (mod (+ 3 (- cur 1)) 3)))
 324          ((and (= cur 2) (= char 6))
 325           (setq s (concat s (char-to-string (+ (lsh (pop chars) 5) (pop chars)))))
 326           (setq cur lock))
 327          (t
 328           (setq s (concat s (substring (elt ez-zstring-alphabets cur)
 329                                        char (+ char 1))))
 330           (setq cur lock)))))
 331     (cons word-count s)))
 332
 333 (defun ez-get-zstring (base-addr)
 334   (cdr (ez-get-zstring-and-length base-addr)))
 335
 336 (defun ez-encode (string)
 337   "Encodes a string as a 2-word 5-padded Z-string.
 338 Used for matching input with dictionary entries when tokenizing."
 339   (let ((chars
 340          (mapcan
 341           (lambda (c)
 342             (cond
 343              ((seq-contains-p (elt ez-zstring-alphabets 0) c)
 344               (list (seq-position (elt ez-zstring-alphabets 0) c)))
 345              ((seq-contains-p (elt ez-zstring-alphabets 1) c)
 346               (list 4 (seq-position (elt ez-zstring-alphabets 1) c)))
 347              ((seq-contains-p (elt ez-zstring-alphabets 2) c)
 348               (list 5 (seq-position (elt ez-zstring-alphabets 2) c)))
 349              (t
 350               (list 5 6 (lsh c -5) (logand c #b11111)))))
 351           string)))
 352     (if (< (length chars) 6)
 353         (append chars (make-list (- 6 (length chars)) 5))
 354       (take 6 chars))))
 355
 356 ;; Dictionary
 357
 358 (defun ez-parse-dictionary-header ()
 359   (let* ((nseps (ez-mem-ref-byte ez-dict-base))
 360          (separators
 361           (mapcar (lambda (i) (ez-mem-ref-byte (+ ez-dict-base i)))
 362                   (number-sequence 1 nseps)))
 363          (bytes-per-entry (ez-mem-ref-byte (+ ez-dict-base 1 nseps)))
 364          (nentries (ez-mem-ref-word (+ ez-dict-base 2 nseps)))
 365          (entries-base (+ ez-dict-base nseps 4))
 366          (entries nil))
 367     ;; (dotimes (i nentries)
 368     ;;   (let ((this-base (+ entries-base (* bytes-per-entry i))))
 369     ;;     (setq entries (cons (cons (ez-get-zstring this-base)
 370     ;;                               this-base)
 371     ;;                         entries))))
 372     ;; (setq ez-dict-entries (reverse entries))
 373     (setq ez-dict-separators separators)))
 374
 375 (defun ez-is-separator (char)
 376   (let* ((nseps (ez-mem-ref-byte ez-dict-base)))
 377     (while (and (> nseps 0)
 378                 (not (= (ez-mem-ref-byte (+ ez-dict-base nseps))
 379                         char)))
 380       (setq nseps (- nseps 1)))
 381     (> nseps 0)))
 382
 383 (defun ez-lookup-dictionary (text)
 384   (let ((encoded-text (ez-encode text))
 385         (nseps (ez-mem-ref-byte ez-dict-base))
 386         (bytes-per-entry (ez-mem-ref-byte (+ ez-dict-base 1 nseps)))
 387         (nentries (ez-mem-ref-word (+ ez-dict-base 2 nseps)))
 388         (entries-seen 0)
 389         (this-entry (+ ez-dict-base nseps 4)))
 390
 391     (while (and (< entries-seen nentries)
 392                 (not (equal
 393                       (ez-mem-ref-bytes this-entry 4)
 394                       encoded-text)))
 395       (setq entries-seen (+ entries-seen 1))
 396       (setq this-entry (+ this-entry bytes-per-entry)))
 397
 398     (if (< entries-seen nentries)
 399         this-entry
 400       0)))
 401
 402 ;; Call stack
 403
 404 (defvar ez-call-stack nil)
 405
 406 (defun ez-make-call-stack-frame (pc &optional call-method)
 407   (list pc
 408         nil
 409         (make-vector 15 0)
 410         call-method))
 411
 412 (defun ez-add-call-stack-frame (pc &optional call-method)
 413   (push (ez-make-call-stack-frame pc call-method) ez-call-stack))
 414
 415 (defun ez-pop-call-stack-frame ()
 416   (pop ez-call-stack))
 417
 418 (defun ez-routine-stack ()
 419   (elt (car ez-call-stack) 1))
 420
 421 (defun ez-routine-stack-push (val)
 422   (let ((frame (car ez-call-stack)))
 423     (ez-debug-message "\tPushed %x to stack" val)
 424     (setf (elt frame 1) (cons val (elt frame 1)))))
 425
 426 (defun ez-routine-stack-pop ()
 427   (let* ((frame (car ez-call-stack))
 428          (rs-head (car (elt frame 1))))
 429     (setf (elt frame 1) (cdr (elt frame 1)))
 430     (ez-debug-message "\tPopped %x from stack" rs-head)
 431     rs-head))
 432
 433 (defun ez-get-local-var (lvar)
 434   (let* ((frame (car ez-call-stack))
 435          (val (aref (elt frame 2) (- lvar 1))))
 436     (ez-debug-message "\tRetrieved value %x from local variable %x" val lvar)
 437     val))
 438
 439 (defun ez-set-local-var (lvar val)
 440   (let ((frame (car ez-call-stack)))
 441     (ez-debug-message "\tSet local variable %x to %x" lvar val)
 442     (aset (elt frame 2) (- lvar 1) val)))
 443
 444 (defun ez-get-pc ()
 445   (caar ez-call-stack))
 446
 447 (defun ez-set-pc (new-pc)
 448   (setf (car (car ez-call-stack)) new-pc))
 449
 450 (defun ez-increment-pc (inc)
 451   (ez-set-pc (+ (ez-get-pc) inc)))
 452
 453 (defun ez-read-pc-byte-and-inc ()
 454   (let ((res (ez-mem-ref-byte (ez-get-pc))))
 455     (ez-increment-pc 1)
 456     res))
 457
 458 (defun ez-read-pc-word-and-inc ()
 459   (let ((res (ez-mem-ref-word (ez-get-pc))))
 460     (ez-increment-pc 2)
 461     res))
 462
 463 ;; Instruction execution
 464
 465 (defun ez-get-var (var)
 466   (cond
 467    ((= var 0)
 468     (ez-routine-stack-pop))
 469    ((< var 16)
 470     (ez-get-local-var var))
 471    (t
 472     (ez-get-global-var (- var 16)))))
 473
 474 (defun ez-set-var (var val)
 475   (cond
 476    ((= var 0)
 477     (ez-routine-stack-push val))
 478    ((< var 16)
 479     (ez-set-local-var var val))
 480    (t
 481     (ez-set-global-var (- var 16) val))))
 482
 483 (defun ez-read-pc-var-and-inc ()
 484   (ez-get-var (ez-read-pc-byte-and-inc)))
 485
 486 (defun ez-execute-instr ()
 487   (let ((instr-pc (ez-get-pc))
 488         (opbyte (ez-read-pc-byte-and-inc))
 489         (optype) (opcode) (operands))
 490     (cond
 491      ((<= #x0 opbyte #x1f)
 492       (setq optype '2op
 493             opcode opbyte
 494             operands (list (ez-read-pc-byte-and-inc)
 495                            (ez-read-pc-byte-and-inc))
 496             operand-types '(b b)))
 497      ((<= #x20 opbyte #x3F)
 498       (setq optype '2op
 499             opcode (- opbyte #x20)
 500             operands (list (ez-read-pc-byte-and-inc)
 501                            (ez-read-pc-var-and-inc))
 502             operand-types '(b w)))
 503      ((<= #x40 opbyte #x5F)
 504       (setq optype '2op
 505             opcode (- opbyte #x40)
 506             operands (list (ez-read-pc-var-and-inc)
 507                            (ez-read-pc-byte-and-inc))
 508             operand-types '(w b)))
 509      ((<= #x60 opbyte #x7F)
 510       (setq optype '2op
 511             opcode (- opbyte #x60)
 512             operands (list (ez-read-pc-var-and-inc)
 513                            (ez-read-pc-var-and-inc))
 514             operand-types '(w w)))
 515      ((<= #x80 opbyte #x8F)
 516       (setq optype '1op
 517             opcode (- opbyte #x80)
 518             operands (list (ez-read-pc-word-and-inc))
 519             operand-types '(w)))
 520      ((<= #x90 opbyte #x9F)
 521       (setq optype '1op
 522             opcode (- opbyte #x90)
 523             operands (list (ez-read-pc-byte-and-inc))
 524             operand-types '(b)))
 525      ((<= #xA0 opbyte #xAF)
 526       (setq optype '1op
 527             opcode (- opbyte #xa0)
 528             operands (list (ez-read-pc-var-and-inc))
 529             operand-types '(w)))
 530      ((<= #xB0 opbyte #xBF)
 531       (setq optype '0op
 532             opcode (- opbyte #xb0)
 533             operands '()
 534             operand-types '()))
 535      ((<= #xC0 opbyte #xDF)
 536       (setq optype '2op
 537             opcode (- opbyte #xc0))
 538       (let ((operands-and-types (ez-read-var-operands-and-inc)))
 539         (setq operands (car operands-and-types)
 540               operand-types (cdr operands-and-types))))
 541      ((<= #xE0 opbyte #xFF)
 542       (setq optype 'var
 543             opcode (- opbyte #xe0))
 544       (let ((operands-and-types (ez-read-var-operands-and-inc)))
 545         (setq operands (car operands-and-types)
 546               operand-types (cdr operands-and-types)))))
 547     (let ((table-row (assoc (list optype opcode) ez-op-table)))
 548       (unless table-row
 549         (error "Unsupported op PC:%x Optype:%s Opcode:%x Operands:%s Operand-types:%s"
 550                instr-pc optype opcode (ez-list-to-string-hex operands) operand-types))
 551       (let ((mnemonic (elt table-row 1)))
 552         (ez-debug-message "PC:%x Optype:%s Opcode:%x Mnemonic:%s Operands:%s Operand-types:%s"
 553                  instr-pc optype opcode mnemonic
 554                  (ez-list-to-string-hex operands) operand-types))
 555       (funcall (elt table-row 2) operands operand-types))))
 556
 557 (defun ez-read-var-operands-and-inc ()
 558   (let* ((type-byte (ez-read-pc-byte-and-inc))
 559          (types (let ((type1 (lsh type-byte -6)))
 560                   (if (= type1 #b11)
 561                       nil
 562                     (cons type1
 563                           (let ((type2 (mod (lsh type-byte -4) 4)))
 564                             (if (= type2 #b11)
 565                                 nil
 566                               (cons type2
 567                                     (let ((type3 (mod (lsh type-byte -2) 4)))
 568                                       (if (= type3 #b11)
 569                                           nil
 570                                         (cons type3
 571                                               (let ((type4 (mod type-byte 4)))
 572                                                 (if (= type4 #b11)
 573                                                     nil
 574                                                   (list type4))))))))))))))
 575     (cons
 576      (mapcar
 577       (lambda (type)
 578         (cond
 579          ((= type 0) (ez-read-pc-word-and-inc))
 580          ((= type 1) (ez-read-pc-byte-and-inc))
 581          ((= type 2) (ez-read-pc-var-and-inc))))
 582       types)
 583      (mapcar
 584       (lambda (type)
 585         (if (= type 1)
 586             'b
 587           'w))
 588       types))))
 589
 590 ;; Branches
 591
 592 (defun ez-do-branch (branch)
 593   (let* ((branch-byte (ez-read-pc-byte-and-inc))
 594          (invert (= 0 (logand branch-byte #b10000000)))
 595          (single-byte (> (logand branch-byte #b01000000) 0))
 596          (offset
 597           (if single-byte
 598               (logand branch-byte #b00111111)
 599             (let ((pos (= (logand branch-byte #b00100000) 0))
 600                   (val (+ (* 256 (logand branch-byte #b00011111))
 601                           (ez-read-pc-byte-and-inc))))
 602               (if pos
 603                   val
 604                 (- val 8192))))))
 605     (if (or (and branch (not invert))
 606             (and (not branch) invert))
 607         (cond
 608          ((= offset 0)
 609           (ez-op-rfalse))
 610          ((= offset 1)
 611           (ez-op-rtrue))
 612          (t
 613           (ez-set-pc (+ (ez-get-pc) offset -2)))))))
 614
 615 ;; Operations
 616
 617 (defvar ez-op-table
 618   '(((0op #x00) rtrue ez-op-rtrue)
 619     ((0op #x01) rfalse ez-op-rfalse)
 620     ((1op #x00) jz ez-op-jz)
 621     ((1op #x05) inc ez-op-inc)
 622     ((1op #x06) dec ez-op-dec)
 623     ((1op #x0B) ret ez-op-ret)
 624     ((0op #x08) ret_pulled ez-op-ret-pulled)
 625     ((1op #x0C) jump ez-op-jump)
 626     ((2op #x05) inc_jg ez-op-inc-jg)
 627     ((2op #x04) dec_jg ez-op-dec-jg)
 628     ((2op #x0D) store ez-op-store)
 629     ((1op #x0E) load ez-op-load)
 630     ((var #x01) storew ez-op-storew)
 631     ((2op #x0F) loadw ez-op-loadw)
 632     ((var #x02) storeb ez-op-storeb)
 633     ((2op #x10) loadb ez-op-loadb)
 634     ((2op #x01) je ez-op-je)
 635     ((2op #x02) jl ez-op-jl)
 636     ((2op #x03) jg ez-op-jg)
 637     ((2op #x06) jin ez-op-jin)
 638     ((2op #x07) test ez-op-test)
 639     ((2op #x08) or ez-op-or)
 640     ((2op #x09) and ez-op-and)
 641     ((2op #x14) add ez-op-add)
 642     ((2op #x15) sub ez-op-sub)
 643     ((2op #x16) mul ez-op-mul)
 644     ((2op #x17) div ez-op-div)
 645     ((2op #x18) mod ez-op-mod)
 646     ((var #x00) call_fv ez-op-callfv)
 647     ((1op #x01) get_sibling ez-op-get-sibling)
 648     ((1op #x02) get_child ez-op-get-child)
 649     ((1op #x03) get_parent ez-op-get-parent)
 650     ((2op #x0A) test_attr ez-op-test-attr)
 651     ((2op #x0B) set_attr ez-op-set-attr)
 652     ((2op #x0C) clear_attr ez-op-clear-attr)
 653     ((1op #x09) remove_obj ez-op-remove-obj)
 654     ((2op #x0E) insert_obj ez-op-insert-obj)
 655     ((var #x03) put_prop ez-op-put-prop)
 656     ((2op #x11) get_prop ez-op-get-prop)
 657     ((0op #x02) print ez-op-print)
 658     ((0op #x0B) new_line ez-op-new-line)
 659     ((var #x06) print_num ez-op-print-num)
 660     ((var #x05) print_char ez-op-print-char)
 661     ((1op #x0A) print_obj ez-op-print-obj)
 662     ((var #x04) read ez-op-read)))
 663
 664 (defun ez-op-ret (operands &optional operand-types)
 665   (let ((retval (car operands)))
 666     (ez-debug-message "\tReturning value %x" retval)
 667     (ez-pop-call-stack-frame)
 668     (ez-set-var (ez-read-pc-byte-and-inc) retval))
 669   'run)
 670
 671 (defun ez-op-ret-pulled (operands operand-types)
 672   (let ((retval (ez-routine-stack-pop)))
 673     (ez-debug-message "\tReturning value %x" retval)
 674     (ez-op-ret (list retval)))
 675   'run)
 676
 677 (defun ez-op-rtrue (&optional operands operand-types)
 678   (ez-op-ret (list 1))
 679   'run)
 680
 681 (defun ez-op-rfalse (&optional operands operand-types)
 682   (ez-op-ret (list 0))
 683   'run)
 684
 685 (defun ez-op-jz (operands operand-types)
 686   (ez-do-branch (= (car operands) 0))
 687   'run)
 688
 689 (defun ez-op-je (operands operand-types)
 690   (ez-do-branch (memq (car operands) (cdr operands)))
 691   'run)
 692
 693 (defun ez-op-jg (operands operand-types)
 694   (let ((s1 (ez-decode-signed-operand (car operands) (car operand-types)))
 695         (s2 (ez-decode-signed-operand (cadr operands) (cadr operand-types))))
 696     (ez-do-branch (> s1 s2)))
 697   'run)
 698
 699 (defun ez-op-jl (operands operand-types)
 700   (let ((s1 (ez-decode-signed-operand (car operands) (car operand-types)))
 701         (s2 (ez-decode-signed-operand (cadr operands) (cadr operand-types))))
 702     (ez-do-branch (< s1 s2)))
 703   'run)
 704
 705 (defun ez-op-inc-jg (operands operand-types)
 706   (let ((var (car operands)))
 707     (ez-op-inc (list var))
 708     (ez-op-jg (cons (ez-get-var var) (cdr operands)) (cons 'w (cdr operand-types))))
 709   'run)
 710
 711 (defun ez-op-dec-jl (operands operand-types)
 712   (let ((var (car operands)))
 713     (ez-op-dec (list var))
 714     (ez-op-jl (cons (ez-get-var var) (cdr operands)) (cons 'w (cdr operand-types))))
 715   'run)
 716
 717 (defun ez-op-jin (operands operand-types)
 718   (let ((obj (car operands))
 719         (n (cadr operands)))
 720     (ez-do-branch (or (= n 0)
 721                       (= n (ez-get-obj-parent obj)))))
 722   'run)
 723
 724 (defun ez-op-test (operands operand-types)
 725   (let ((a (car operands))
 726         (b (cadr operands)))
 727     (ez-do-branch (= (logand a b) b)))
 728   'run)
 729
 730 (defun ez-op-jump (operands operand-types)
 731   (let ((offset (if (eq (car operand-types) 'b)
 732                     (ez-decode-signed-byte (car operands))
 733                   (ez-decode-signed-word (car operands)))))
 734     (ez-set-pc (+ (ez-get-pc) offset -2)))
 735   'run)
 736
 737 (defun ez-op-inc (operands &optional operand-types)
 738   (let ((var (car operands)))
 739     (ez-set-var var (mod (+ 1 (ez-get-var var)) #x10000)))
 740   'run)
 741
 742 (defun ez-op-dec (operands &optional operand-types)
 743   (let ((var (car operands)))
 744     (ez-set-var var (mod (+ (ez-get-var var) 1) #x10000)))
 745   'run)
 746
 747 (defun ez-op-store (operands operand-types)
 748   (let ((var (car operands))
 749         (a (cadr operands)))
 750     (ez-set-var var a))
 751   'run)
 752
 753 (defun ez-op-load (operands operand-types)
 754   (let ((var (car operands)))
 755     (ez-set-var (ez-read-pc-byte-and-inc) (ez-get-var var)))
 756   'run)
 757
 758 (defun ez-op-storew (operands operand-types)
 759   (let ((baddr (car operands))
 760         (n (cadr operands))
 761         (a (caddr operands)))
 762     (ez-mem-set-word (+ baddr (* 2 n)) a))
 763   'run)
 764
 765 (defun ez-op-loadw (operands operand-types)
 766   (let ((baddr (car operands))
 767         (n (cadr operands)))
 768     (ez-set-var (ez-read-pc-byte-and-inc) (ez-mem-ref-word (+ baddr (* 2 n)))))
 769   'run)
 770
 771 (defun ez-op-storeb (operands operand-types)
 772   (let ((baddr (car operands))
 773         (n (cadr operands))
 774         (a (caddr operands)))
 775     (ez-mem-set-byte (+ baddr n) a))
 776   'run)
 777
 778 (defun ez-op-loadb (operands operand-types)
 779   (let ((baddr (car operands))
 780         (n (cadr operands)))
 781     (ez-set-var (ez-read-pc-byte-and-inc) (ez-mem-ref-byte (+ baddr n))))
 782   'run)
 783
 784 (defun ez-op-and (operands operand-types)
 785   (let ((a (car operands))
 786         (b (cadr operands)))
 787     (ez-set-var (ez-read-pc-byte-and-inc) (logand a b)))
 788   'run)
 789
 790 (defun ez-op-or (operands operand-types)
 791   (let ((a (car operands))
 792         (b (cadr operands)))
 793     (ez-set-var (ez-read-pc-byte-and-inc) (logior a b)))
 794   'run)
 795
 796 (defun ez-op-add (operands operand-types)
 797   (let ((a (car operands))
 798         (b (cadr operands)))
 799     (ez-set-var (ez-read-pc-byte-and-inc) (mod (+ a b) #x10000)))
 800   'run)
 801
 802 (defun ez-op-sub (operands operand-types)
 803   (let ((a (car operands))
 804         (b (cadr operands)))
 805     (ez-set-var (ez-read-pc-byte-and-inc) (mod (+ (- a b) #x10000) #x10000)))
 806   'run)
 807
 808 (defun ez-op-mul (a b)
 809   (let ((a (car operands))
 810         (b (cadr operands)))
 811     (ez-set-var (ez-read-pc-byte-and-inc) (mod (* a b) #x10000)))
 812   'run)
 813
 814 (defun ez-op-div (a b)
 815   (error "Not implemented"))
 816
 817 (defun ez-op-mod (a b)
 818   (error "Not implemented"))
 819
 820 (defun ez-op-callfv (operands operand-types)
 821   (let* ((raddr (car operands))
 822          (call-operands (cdr operands))
 823          (r (* 2 raddr))
 824          (L (ez-mem-ref-byte r))
 825          (n (length call-operands))
 826          (new-pc (+ r 1 (* L 2))))
 827     (if (= raddr 0)
 828         (ez-set-var (ez-read-pc-byte-and-inc) 0) ; Simply return 0
 829       (ez-add-call-stack-frame new-pc)
 830       (dotimes (i L)
 831         (if (< i n)
 832             (ez-set-local-var (+ i 1) (elt call-operands i))
 833           (ez-set-local-var (+ i 1) (ez-mem-ref-word (+ r 1 (* 2 i))))))))
 834   'run)
 835
 836 (defun ez-op-test-attr (operands operand-types)
 837   (let ((obj (car operands))
 838         (attr (cadr operands)))
 839     (ez-do-branch (= 1 (ez-get-obj-attr obj attr)))
 840     'run))
 841
 842 (defun ez-op-set-attr (operands operand-types)
 843   (let ((obj (car operands))
 844         (attr (cadr operands)))
 845     (ez-set-obj-attr obj attr 1))
 846   'run)
 847
 848 (defun ez-op-clear-attr (operands operand-types)
 849   (let ((obj (car operands))
 850         (attr (cadr operands)))
 851     (ez-set-obj-attr obj attr 0))
 852   'run)
 853
 854 (defun ez-op-get-sibling (operands operand-types)
 855   (let ((sib (ez-get-obj-sibling (car operands))))
 856     (ez-set-var (ez-read-pc-byte-and-inc) sib)
 857     (ez-do-branch (> sib 0)))
 858   'run)
 859
 860 (defun ez-op-get-child (operands operand-types)
 861   (let ((child (ez-get-obj-child (car operands))))
 862     (ez-set-var (ez-read-pc-byte-and-inc) child)
 863     (ez-do-branch (> child 0)))
 864   'run)
 865
 866 (defun ez-op-get-parent (operands operand-types)
 867   (let ((parent (ez-get-obj-parent (car operands))))
 868     (ez-set-var (ez-read-pc-byte-and-inc) parent))
 869   'run)
 870
 871 (defun ez-op-remove-obj (operands operand-types)
 872   (let ((obj (car operands)))
 873     (ez-remove-obj obj))
 874   'run)
 875
 876 (defun ez-op-insert-obj (operands operand-types)
 877   (let ((obj1 (car operands))
 878         (obj2 (cadr operands)))
 879     (ez-insert-obj obj1 obj2))
 880   'run)
 881
 882 (defun ez-op-put-prop (operands operand-types)
 883   (let* ((obj (car operands))
 884          (prop (cadr operands))
 885          (a (caddr operands)))
 886     (ez-set-obj-prop obj prop a))
 887   'run)
 888
 889 (defun ez-op-get-prop (operands operand-types)
 890   (let* ((obj (car operands))
 891          (prop (cadr operands)))
 892     (ez-set-var (ez-read-pc-byte-and-inc)
 893                 (ez-get-obj-prop obj prop)))
 894   'run)
 895
 896 (defun ez-op-print (operands operand-types)
 897   (let* ((word-count-and-string (ez-get-zstring-and-length (ez-get-pc)))
 898          (word-count (car word-count-and-string))
 899          (string (cdr word-count-and-string)))
 900     (ez-print string)
 901     (ez-increment-pc (* 2 word-count)))
 902   'run)
 903
 904 (defun ez-op-new-line (operands operand-types)
 905   (ez-print "\n")
 906   'run)
 907
 908 (defun ez-op-print-num (operands operand-types)
 909   (let ((s (ez-decode-signed-operand (car operands) (car operand-types))))
 910     (ez-print (number-to-string s)))
 911   'run)
 912
 913 (defun ez-op-print-char (operands operand-types)
 914   (let ((c (car operands)))
 915     (ez-print (string c)))
 916   'run)
 917
 918 (defun ez-op-print-obj (operands operand-types)
 919   (let ((obj (car operands)))
 920     (ez-print (ez-get-obj-name obj)))
 921   'run)
 922
 923 (defvar ez--next-read-args nil)
 924 (defun ez-op-read (operands operand-types)
 925   (let ((baddr1 (car operands))
 926         (baddr2 (cadr operands)))
 927     (setq ez--next-read-args (list baddr1 baddr2)))
 928   'wait-for-input)
 929
 930 (defun ez-op-read2 (input-string)
 931   (let* ((baddr1 (car ez--next-read-args))
 932          (baddr2 (cadr ez--next-read-args)))
 933
 934     (dotimes (i (length input-string))
 935       (let ((char (elt input-string i)))
 936         (ez-mem-set-byte (+ baddr1 1 i) char)))
 937     (ez-mem-set-byte (+ baddr1 1 (length input-string)) 0)
 938
 939     (ez--tokenize baddr1 baddr2)))
 940
 941 (defun ez--tokenize (tb-baddr pb-baddr)
 942
 943   (let ((unfinished t)
 944         (token-start 0)
 945         (token-end 0)
 946         (token-count 0))
 947
 948     (while unfinished
 949       (let ((next-char (ez-mem-ref-byte (+ tb-baddr 1 token-end))))
 950         (cond
 951          ((eq char ?\s)
 952           ;; Add token
 953           (setq token-end (- token-end 1))
 954           (let* ((text (ez-mem-ref-string (+ tb-baddr 1 token-start)
 955                                          (+ tb-baddr 1 token-end)))
 956                  (dict-entry (ez-lookup-dictionary text)))
 957             (setq token-count (+ token-count 1))
 958             (ez-mem-set-word (+ pb-baddr 2 (* token-count 4))
 959                              dict-entry)
 960             (ez-mem-set-bytes (+ pb-baddr 2 (* token-count 4) 2)
 961                               (length text)
 962                               token-start))
 963           (setq token-start (+ token-end 1))
 964           (setq token-end token-start))
 965
 966          ((ez-is-separator char)
 967           ;; Add token and separator token
 968           )
 969          ((eq char 0)
 970           (setq unfinished nil))
 971          (setq token-end (+ token-end 1)))
 972       ))))
 973
 974 ;; Execution loop
 975
 976 (defun ez-load-and-run (filename)
 977   (ez-load-file filename)
 978   (ez-parse-header)
 979   (ez-parse-dictionary)
 980   (setq ez-call-stack (list (ez-make-call-stack-frame ez-start-pc)))
 981
 982   (ez-run))
 983
 984 (defvar ez-machine-state nil
 985   "Identifies the current executation state of the Z-machine.")
 986
 987 (defun ez-run ()
 988   (setq ez-machine-state 'run)
 989   (while (eq ez-machine-state 'run)
 990     (setq ez-machine-state (ez-execute-instr))))
 991
 992 ;;; Buffer and I/O
 993 ;;
 994
 995 (defvar ez-input-marker nil
 996   "Marker for input position in buffer.")
 997
 998 (defun ez-setup-buffer ()
 999   (with-current-buffer (get-buffer-create "*ez*")
1000     (ez-mode)
1001     (let ((inhibit-read-only t))
1002       (erase-buffer))
1003     (setq-local scroll-conservatively 1)
1004     (if (markerp ez-input-marker)
1005         (set-marker ez-input-marker (point-max))
1006       (setq ez-input-marker (point-max-marker)))
1007     (goto-char (point-max))))
1008
1009
1010 (defun ez-print (string)
1011   (with-current-buffer "*ez*"
1012     (save-excursion
1013       (goto-char ez-input-marker)
1014       (insert-before-markers string))))
1015
1016 (defun ez-enter ()
1017   (interactive)
1018   (if (not (eq ez-machine-state 'wait-for-input))
1019       (error "Z-machine not ready for input."))
1020   (let ((input-string
1021          (downcase
1022           (with-current-buffer "*ez*"
1023             (buffer-substring ez-input-marker (point-max))))))
1024     (delete-region ez-input-marker (point-max))
1025     (ez-print (concat input-string "\n"))
1026     (ez-debug-message "\tReceived string \"%s\"" input-string)
1027     (ez-op-read2 input-string)
1028     (ez-run)))
1029
1030 ;; Debugging info
1031
1032 (defun ez-setup-debug-buffer ()
1033   (with-current-buffer (get-buffer-create "*ez-debug-trace*")
1034     (setq-local buffer-read-only t)
1035     (let ((inhibit-read-only t))
1036       (erase-buffer)
1037       (insert "--- Trace Start ---\n\n"))))
1038
1039 (defun ez-debug-message (&rest strings)
1040   (with-current-buffer (get-buffer-create "*ez-debug-trace*")
1041     (save-excursion
1042       (goto-char (point-max))
1043       (let ((inhibit-read-only t))
1044         (insert (apply #'format-message strings) "\n")))))
1045
1046 (defun ez-debug-memory ()
1047   (interactive)
1048   (with-current-buffer (get-buffer-create "*ez-debug-memory*")
1049     (setq-local buffer-read-only t)
1050     (let ((inhibit-read-only t)
1051           (old-point (point)))
1052       (if (eq major-mode 'hexl-mode)
1053           (hexl-mode-exit))
1054       (erase-buffer)
1055       (insert ez-memory)
1056       (setq-local buffer-undo-list nil)
1057       (hexl-mode)
1058       (goto-char old-point))))
1059
1060 ;; Mode
1061
1062 (defvar ez-mode-map
1063   (let ((map (make-sparse-keymap)))
1064     (define-key map (kbd "RET") 'ez-enter)
1065     map))
1066
1067 (define-derived-mode ez-mode text-mode "ez"
1068   "Major mode for EZ.")
1069
1070 (when (fboundp 'evil-set-initial-state)
1071   (evil-set-initial-state 'ez-mode 'insert))
1072
1073 (defun ez (zfile)
1074   (interactive "fEnter name of z3 story file: ")
1075   (if (get-buffer "*ez*")
1076       (switch-to-buffer "*ez*")
1077     (switch-to-buffer "*ez*")
1078     (ez-setup-buffer)
1079     (ez-load-and-run zfile))
1080   "Started EZ.")
1081
1082 (defun ez-debug ()
1083   (interactive)
1084   (ez-setup-buffer)
1085   (ez-setup-debug-buffer)
1086   (ez-load-and-run "zork1.z3"))
1087
1088 ;;; ez.el ends here