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