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