X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=ez.git;a=blobdiff_plain;f=ez.el;h=1fb0f655e9fcfc0bc9fc99d1c1bc85f25600c4e6;hp=67e9caf2ad4c1ff7340c4d0e90c92ebcae5b0ac6;hb=8ed7e627cfe9175458a7bae4cbf8bbb35cfc00b4;hpb=285e58cc15f4ad51c54bdf482867af2f8c0b5ead diff --git a/ez.el b/ez.el index 67e9caf..1fb0f65 100644 --- a/ez.el +++ b/ez.el @@ -41,6 +41,11 @@ (defun ez-decode-signed-word (w) (ez-decode-signed-bits w 16)) +(defun ez-decode-signed-operand (operand operand-type) + (if (eq operand-type 'b) + (ez-decode-signed-byte operand) + (ez-decode-signed-word operand))) + (defun binformat (n &optional s) (unless s (setq s "")) @@ -59,7 +64,7 @@ (defvar ez-start-pc nil) (defvar ez-himem-base nil) -(defvar ez-dict-addr nil) +(defvar ez-dict-base nil) (defvar ez-objtab-addr nil) (defvar ez-abbrevtab-addr nil) (defvar ez-globalvartab-addr nil) @@ -99,10 +104,12 @@ ;; Global variables (defun ez-get-global-var (gvar) - (ez-mem-ref-word (+ (* 2 gvar) (ez-mem-ref-word ez-globalvartab-addr)))) + (if (> gvar 239) + (error "Invalid global variable %d" gvar)) + (ez-mem-ref-word (+ (* 2 gvar) ez-globalvartab-addr))) (defun ez-set-global-var (gvar val) - (ez-mem-set-word (+ (* 2 gvar) (ez-mem-ref-word ez-globalvartab-addr)) val)) + (ez-mem-set-word (+ (* 2 gvar) ez-globalvartab-addr) val)) ;; Object tree @@ -113,46 +120,43 @@ (dotimes (i 31) (aset ez-property-defaults i (aref ez-memory (+ ez-objtab-addr (* 2 i)))))) -(defun ez-get-obj-addr (obj-id) - (+ ez-objtab-addr (* 2 31) (* 9 (- obj-id 1)))) +(defun ez-get-obj-addr (obj) + (+ ez-objtab-addr (* 2 31) (* 9 (- obj 1)))) -(defun ez-get-obj-parent (obj-id) - (let ((addr (ez-get-obj-addr obj-id))) +(defun ez-get-obj-parent (obj) + (let ((addr (ez-get-obj-addr obj))) (ez-mem-ref-byte (+ addr 4)))) -(defun ez-get-obj-sibling (obj-id) - (let ((addr (ez-get-obj-addr obj-id))) +(defun ez-set-obj-parent (obj new-parent) + (let ((addr (ez-get-obj-addr obj))) + (ez-mem-set-byte (+ addr 4) new-parent))) + +(defun ez-get-obj-sibling (obj) + (let ((addr (ez-get-obj-addr obj))) (ez-mem-ref-byte (+ addr 5)))) -(defun ez-get-obj-child (obj-id) - (let ((addr (ez-get-obj-addr obj-id))) +(defun ez-set-obj-sibling (obj new-sibling) + (let ((addr (ez-get-obj-addr obj))) + (ez-mem-set-byte (+ addr 5) new-sibling))) + +(defun ez-get-obj-child (obj) + (let ((addr (ez-get-obj-addr obj))) (ez-mem-ref-byte (+ addr 6)))) -(defun ez-get-obj-plist-addr (obj-id) - (let ((addr (ez-get-obj-addr obj-id))) +(defun ez-set-obj-child (obj new-child) + (let ((addr (ez-get-obj-addr obj))) + (ez-mem-set-byte (+ addr 6) new-child))) + +(defun ez-get-obj-plist-addr (obj) + (let ((addr (ez-get-obj-addr obj))) (ez-mem-ref-word (+ addr 7)))) -(defun ez-get-obj-name (obj-id) - (let ((plist-addr (ez-get-obj-plist-addr obj-id))) +(defun ez-get-obj-name (obj) + (let ((plist-addr (ez-get-obj-plist-addr obj))) (if (> (ez-mem-ref-byte plist-addr) 0) - (ez-get-zstring (+ 1 (ez-get-obj-plist-addr obj-id))) + (ez-get-zstring (+ 1 (ez-get-obj-plist-addr obj))) nil))) -(defun ez-get-obj (obj-id) - (let ((addr (+ ez-objtab-addr - (* 2 31) - (* 9 (- obj-id 1))))) - (list - obj-id - (ez-mem-ref-byte (+ addr 4)) - (ez-mem-ref-byte (+ addr 5)) - (ez-mem-ref-byte (+ addr 6)) - (ez-mem-ref-word (+ addr 7)) - (let ((plist-addr (ez-mem-ref-word (+ addr 7)))) - (if (> (ez-mem-ref-byte plist-addr) 0) - (ez-get-zstring (+ 1 plist-addr)) - nil))))) - (defun ez-get-prop-default (prop) (ez-mem-ref-word (+ ez-objtab-addr (* 2 (+ 1 prop))))) @@ -175,7 +179,7 @@ (defun ez-get-obj-prop (obj prop) (let* ((prop-addr (ez-get-obj-prop-addr obj prop)) (size-byte (ez-mem-ref-byte prop-addr))) - (if (= prop-addr 0) + (if (= size-byte 0) (ez-get-prop-default prop) (let ((prop-len (ez-get-prop-len size-byte)) (data-addr (+ prop-addr 1))) @@ -196,6 +200,45 @@ (t (ez-mem-set-word (+ prop-addr 1) value))))) +(defun ez-get-obj-attr (obj attr) + (let* ((byte-num (/ attr 8)) + (bit-num (mod attr 8)) + (bit-mask (lsh 1 (- 7 bit-num)))) + (if (> (logand bit-mask (ez-mem-ref-byte (+ (ez-get-obj-addr obj) byte-num))) 0) + 1 + 0))) + +(defun ez-set-obj-attr (obj attr val) + (let* ((byte-num (/ attr 8)) + (bit-num (mod attr 8)) + (bit-mask (lsh 1 (- 7 bit-num))) + (byte-addr (+ (ez-get-obj-addr obj) byte-num)) + (byte (ez-mem-ref-byte byte-addr)) + (current-set (> (logand bit-mask byte) 0))) + (if (or (and current-set (= val 0)) + (and (not current-set) (> val 0))) + (ez-mem-set-byte byte-addr (logxor byte bit-mask))))) + + +(defun ez-remove-obj (obj) + (let ((parent (ez-get-obj-parent obj)) + (sibling (ez-get-obj-sibling obj))) + (unless (= parent 0) + (let ((child (ez-get-obj-child parent))) + (if (= child obj) + (ez-set-obj-child parent sibling) + (while (not (= obj (ez-get-obj-sibling child))) + (setq child (ez-get-obj-sibling child))) + (ez-set-obj-sibling child (ez-get-obj-sibling obj)))) + (ez-set-obj-parent obj 0)) + (ez-set-obj-sibling obj 0))) + +(defun ez-insert-obj (obj new-parent) + (ez-remove-obj obj) + (unless (= new-parent 0) + (ez-set-obj-sibling obj (ez-get-obj-child new-parent)) + (ez-set-obj-child new-parent obj))) + ;; Z-strings (defvar ez-zstring-alphabets @@ -212,31 +255,35 @@ (logand (lsh word -5) #b11111) (logand word #b11111))) -(defun ez-get-zstring-chars (base-addr) +(defun ez-get-zstring-chars-and-length (base-addr) (let ((addr base-addr) (chars nil) - (not-done t)) + (not-done t) + (word-count 0)) (while not-done (let ((components (ez-parse-zstring-word (ez-mem-ref-word addr)))) (setq chars (append chars (cdr components))) (setq addr (+ addr 2)) + (setq word-count (+ word-count 1)) (when (= (car components) 1) (setq not-done nil)))) - chars)) - -(defun ez-get-zstring (base-addr) - (let ((chars (ez-get-zstring-chars base-addr)) - (cur 0) - (lock 0) - (abbrev-char nil) - (s "")) + (cons word-count chars))) + +(defun ez-get-zstring-and-length (base-addr) + (let* ((word-count-and-chars (ez-get-zstring-chars-and-length base-addr)) + (word-count (car word-count-and-chars)) + (chars (cdr word-count-and-chars)) + (cur 0) + (lock 0) + (abbrev-char nil) + (s "")) (dolist (char chars) (cond (abbrev-char (let ((abbrev-addr (* 2 (ez-mem-ref-word (+ ez-abbrevtab-addr (* 2 (+ (* (- abbrev-char 1) 32) char))))))) - (setq s (concat s (ez-get-zstring abbrev-addr)))) + (setq s (concat s (cdr (ez-get-zstring-and-length abbrev-addr))))) (setq abbrev-char nil)) ((memq char '(1 2 3)) ;Abbreviation (setq abbrev-char char)) @@ -248,7 +295,10 @@ (setq s (concat s (substring (elt ez-zstring-alphabets cur) char (+ char 1)))) (setq cur lock)))) - s)) + (cons word-count s))) + +(defun ez-get-zstring (base-addr) + (cdr (ez-get-zstring-and-length base-addr))) ;; Call stack @@ -333,9 +383,7 @@ (defun ez-execute-instr () (let ((instr-pc (ez-get-pc)) (opbyte (ez-read-pc-byte-and-inc)) - (optype) - (opcode nil) - (operands)) + (optype) (opcode) (operands)) (cond ((<= #x0 opbyte #x1f) (setq optype '2op @@ -378,9 +426,15 @@ operand-types '(w))) ((<= #xB0 opbyte #xBF) (setq optype '0op - opcode (- opbyte #xb0))) + opcode (- opbyte #xb0) + operands '() + operand-types '())) ((<= #xC0 opbyte #xDF) - (error "Unsupported op" opbyte)) + (setq optype '2op + opcode (- opbyte #xc0)) + (let ((operands-and-types (ez-read-var-operands-and-inc))) + (setq operands (car operands-and-types) + operand-types (cdr operands-and-types)))) ((<= #xE0 opbyte #xFF) (setq optype 'var opcode (- opbyte #xe0)) @@ -389,10 +443,11 @@ operand-types (cdr operands-and-types))))) (let ((table-row (assoc (list optype opcode) ez-op-table))) (unless table-row - (error "Unsupported op" instr-pc optype opcode operands operand-types)) + (error "Unsupported op PC:%x Optype:%s Opcode:%x Operands:%s Operand-types:%s" + instr-pc optype opcode operands operand-types)) (let ((mnemonic (elt table-row 1))) - (message "PC:%x Optype:%s Opcode:%x Mnemonic:%s Operands:%s" - instr-pc optype opcode mnemonic operands)) + (message "PC:%x Optype:%s Opcode:%x Mnemonic:%s Operands:%s Operand-types:%s" + instr-pc optype opcode mnemonic operands operand-types)) (funcall (elt table-row 2) operands operand-types)))) (defun ez-read-var-operands-and-inc () @@ -412,8 +467,7 @@ (let ((type4 (logand #b11))) (if (= type4 #b11) nil - (list type4))))))))))))) - (operands nil)) + (list type4)))))))))))))) (cons (mapcar (lambda (type) @@ -434,7 +488,7 @@ (defun ez-do-branch (branch) (let* ((branch-byte (ez-read-pc-byte-and-inc)) (invert (= 0 (logand branch-byte #b10000000))) - (single-byte (= 1 (logand branch-byte #b01000000))) + (single-byte (> (logand branch-byte #b01000000) 0)) (offset (if single-byte (logand branch-byte #b00111111) @@ -444,13 +498,15 @@ (if pos val (- val 8192)))))) - (cond - ((= offset 0) - (ez-op-rfalse)) - ((= offset 1) - (ez-op-rtrue)) - (t - (ez-set-pc (+ (ez-get-pc) offset -2)))))) + (if (or (and branch (not invert)) + (and (not branch) invert)) + (cond + ((= offset 0) + (ez-op-rfalse)) + ((= offset 1) + (ez-op-rtrue)) + (t + (ez-set-pc (+ (ez-get-pc) offset -2))))))) ;; Operations @@ -458,12 +514,21 @@ '(((0op #x00) rtrue ez-op-rtrue) ((0op #x01) rfalse ez-op-rfalse) ((1op #x00) jz ez-op-jz) + ((1op #x05) inc ez-op-inc) + ((1op #x06) dec ez-op-dec) ((1op #x0B) ret ez-op-ret) ((1op #x0C) jump ez-op-jump) + ((2op #x05) inc_jg ez-op-inc-jg) + ((2op #x04) dec_jg ez-op-dec-jg) ((2op #x0D) store ez-op-store) ((1op #x0E) load ez-op-load) ((var #x01) storew ez-op-storew) + ((2op #x0F) loadw ez-op-loadw) + ((var #x02) storeb ez-op-storeb) + ((2op #x10) loadb ez-op-loadb) ((2op #x01) je ez-op-je) + ((2op #x02) jl ez-op-jl) + ((2op #x06) jin ez-op-jin) ((2op #x08) or ez-op-or) ((2op #x09) and ez-op-and) ((2op #x14) add ez-op-add) @@ -475,7 +540,18 @@ ((1op #x01) get_sibling ez-op-get-sibling) ((1op #x02) get_child ez-op-get-child) ((1op #x03) get_parent ez-op-get-parent) - ((var #x03) put_prop ez-op-put-prop))) + ((2op #x0A) test_attr ez-op-test-attr) + ((2op #x0B) set_attr ez-op-set-attr) + ((2op #x0C) clear_attr ez-op-clear-attr) + ((1op #x09) remove_obj ez-op-remove-obj) + ((2op #x0E) insert_obj ez-op-insert-obj) + ((var #x03) put_prop ez-op-put-prop) + ((2op #x11) get_prop ez-op-get-prop) + ((0op #x02) print ez-op-print) + ((0op #x0B) new_line ez-op-new-line) + ((var #x06) print_num ez-op-print-num) + ((var #x05) print_char ez-op-print-char) + ((1op #x0A) print_obj ez-op-print-obj))) (defun ez-op-ret (operands &optional operand-types) (let ((retval (car operands))) @@ -484,10 +560,12 @@ t) (defun ez-op-rtrue (&optional operands operand-types) - (ez-op-ret (list 1))) + (ez-op-ret (list 1)) + t) (defun ez-op-rfalse (&optional operands operand-types) - (ez-op-ret (list 0))) + (ez-op-ret (list 0)) + t) (defun ez-op-jz (operands operand-types) (ez-do-branch (= (car operands) 0)) @@ -497,6 +575,37 @@ (ez-do-branch (memq (car operands) (cdr operands))) t) +(defun ez-op-jg (operands operand-types) + (let ((s1 (ez-decode-signed-operand (car operands) (car operand-types))) + (s2 (ez-decode-signed-operand (cadr operands) (cadr operand-types)))) + (ez-do-branch (> s1 s2))) + t) + +(defun ez-op-jl (operands operand-types) + (let ((s1 (ez-decode-signed-operand (car operands) (car operand-types))) + (s2 (ez-decode-signed-operand (cadr operands) (cadr operand-types)))) + (ez-do-branch (< s1 s2))) + t) + +(defun ez-op-inc-jg (operands operand-types) + (let ((var (car operands))) + (ez-op-inc (list var)) + (ez-op-jg (cons (ez-get-var var) (cdr operands)) (cons 'w (cdr operand-types)))) + t) + +(defun ez-op-dec-jl (operands operand-types) + (let ((var (car operands))) + (ez-op-dec (list var)) + (ez-op-jl (cons (ez-get-var var) (cdr operands)) (cons 'w (cdr operand-types)))) + t) + +(defun ez-op-jin (operands operand-types) + (let ((obj (car operands)) + (n (cadr operands))) + (ez-do-branch (or (= n 0) + (= n (ez-get-obj-parent obj))))) + t) + (defun ez-op-jump (operands operand-types) (let ((offset (if (eq (car operand-types) 'b) (ez-decode-signed-byte (car operands)) @@ -504,6 +613,16 @@ (ez-set-pc (+ (ez-get-pc) offset -2))) t) +(defun ez-op-inc (operands &optional operand-types) + (let ((var (car operands))) + (ez-set-var var (mod (+ 1 (ez-get-var var)) #x10000))) + t) + +(defun ez-op-dec (operands &optional operand-types) + (let ((var (car operands))) + (ez-set-var var (mod (+ (ez-get-var var) 1) #x10000))) + t) + (defun ez-op-store (operands operand-types) (let ((var (car operands)) (a (cadr operands))) @@ -522,6 +641,25 @@ (ez-mem-set-word (+ baddr (* 2 n)) a)) t) +(defun ez-op-loadw (operands operand-types) + (let ((baddr (car operands)) + (n (cadr operands))) + (ez-set-var (ez-read-pc-byte-and-inc) (ez-mem-ref-word (+ baddr (* 2 n))))) + t) + +(defun ez-op-storeb (operands operand-types) + (let ((baddr (car operands)) + (n (cadr operands)) + (a (caddr operands))) + (ez-mem-set-byte (+ baddr n) a)) + t) + +(defun ez-op-loadb (operands operand-types) + (let ((baddr (car operands)) + (n (cadr operands))) + (ez-set-var (ez-read-pc-byte-and-inc) (ez-mem-ref-byte (+ baddr n)))) + t) + (defun ez-op-and (operands operand-types) (let ((a (car operands)) (b (cadr operands))) @@ -572,28 +710,94 @@ (ez-set-local-var (+ i 1) (ez-mem-ref-word (+ r 1 (* 2 i))))))) t) +(defun ez-op-test-attr (operands operand-types) + (let ((obj (car operands)) + (attr (cadr operands))) + (ez-do-branch (= 1 (ez-get-obj-attr obj attr))) + t)) + +(defun ez-op-set-attr (operands operand-types) + (let ((obj (car operands)) + (attr (cadr operands))) + (ez-set-obj-attr obj attr 1)) + t) + +(defun ez-op-clear-attr (operands operand-types) + (let ((obj (car operands)) + (attr (cadr operands))) + (ez-set-obj-attr obj attr 0)) + t) + (defun ez-op-get-sibling (operands operand-types) (let ((sib (ez-get-obj-sibling (car operands)))) (ez-set-var (ez-read-pc-byte-and-inc) sib) - (ez-do-branch (> sib 0)))) + (ez-do-branch (> sib 0))) + t) (defun ez-op-get-child (operands operand-types) (let ((child (ez-get-obj-child (car operands)))) (ez-set-var (ez-read-pc-byte-and-inc) child) - (ez-do-branch (> child 0)))) + (ez-do-branch (> child 0))) + t) (defun ez-op-get-parent (operands operand-types) (let ((parent (ez-get-obj-parent (car operands)))) - (ez-set-var (ez-read-pc-byte-and-inc) parent) - (ez-do-branch (> parent 0)))) + (ez-set-var (ez-read-pc-byte-and-inc) parent)) + t) + +(defun ez-op-remove-obj (operands operand-types) + (let ((obj (car operands))) + (ez-remove-obj obj)) + t) + +(defun ez-op-insert-obj (operands operand-types) + (let ((obj1 (car operands)) + (obj2 (cadr operands))) + (ez-insert-obj obj1 obj2)) + t) (defun ez-op-put-prop (operands operand-types) (let* ((obj (car operands)) (prop (cadr operands)) (a (caddr operands))) - (ez-set-obj-prop obj prop a))) + (ez-set-obj-prop obj prop a)) + t) + +(defun ez-op-get-prop (operands operand-types) + (let* ((obj (car operands)) + (prop (cadr operands))) + (ez-set-var (ez-read-pc-byte-and-inc) + (ez-get-obj-prop obj prop))) + t) + +(defun ez-op-print (operands operand-types) + (let* ((word-count-and-string (ez-get-zstring-and-length (ez-get-pc))) + (word-count (car word-count-and-string)) + (string (cdr word-count-and-string))) + (ez-print string) + (ez-increment-pc (* 2 word-count))) + t) -;; Main +(defun ez-op-new-line (operands operand-types) + (ez-print "\n") + t) + +(defun ez-op-print-num (operands operand-types) + (let ((s (ez-decode-signed-operand (car operands) (car operand-types)))) + (ez-print (number-to-string s))) + t) + +(defun ez-op-print-char (operands operand-types) + (let ((c (car operands))) + (ez-print (string c))) + t) + +(defun ez-op-print-obj (operands operand-types) + (let ((obj (car operands))) + (ez-print (ez-get-obj-name obj))) + t) + +;; Execution loop (defun ez-run (filename) (ez-load-file filename) @@ -602,13 +806,86 @@ (while (ez-execute-instr))) -;; Scratch - -;; (ez-load-file "zork1.z3") -;; (ez-parse-header) -;; (setq ez-call-stack (list (ez-make-call-stack-frame ez-start-pc))) -;; (while (ez-execute-instr)) -(ez-run "zork1.z3") +;;; Buffer and I/O +;; + +(defun ez-render-prompt () + (with-current-buffer "*ez*" + (let ((update-point (= ez-input-marker (point))) + (update-window-points (mapcar (lambda (w) + (list (= (window-point w) ez-input-marker) + w)) + (get-buffer-window-list nil nil t)))) + (save-excursion + (set-marker-insertion-type ez-prompt-marker nil) + (set-marker-insertion-type ez-input-marker t) + (let ((inhibit-read-only t)) + (delete-region ez-prompt-marker ez-input-marker) + (goto-char ez-prompt-marker) + (insert + ">" + (propertize " " ; Need this to be separate to mark it as rear-nonsticky + 'read-only t + 'rear-nonsticky t))) + (set-marker-insertion-type ez-input-marker nil)) + (goto-char ez-input-marker)))) + +(defvar ez-prompt-marker nil + "Marker for prompt position in buffer.") + +(defvar ez-input-marker nil + "Marker for prompt position in buffer.") + +(defun ez-setup-buffer () + (with-current-buffer (get-buffer-create "*ez*") + (let ((inhibit-read-only t)) + (delete-region (point-min) (point-max))) + (setq-local scroll-conservatively 1) + (if (markerp ez-prompt-marker) + (set-marker ez-prompt-marker (point-max)) + (setq ez-prompt-marker (point-max-marker))) + (if (markerp ez-input-marker) + (set-marker ez-input-marker (point-max)) + (setq ez-input-marker (point-max-marker))) + (goto-char (point-max)) + (ez-render-prompt))) + + +(defun ez-print (string) + (with-current-buffer "*ez*" + (save-excursion + (goto-char ez-prompt-marker) + (insert-before-markers string)))) + +;; Mode + +(defvar ez-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'ez-enter) + map)) + +(define-derived-mode ez-mode text-mode "ez" + "Major mode for EZ.") + +(when (fboundp 'evil-set-initial-state) + (evil-set-initial-state 'ez-mode 'insert)) + +(defun ez (zfile) + (interactive "fEnter name of z3 story file: ") + (if (get-buffer "*ez*") + (switch-to-buffer "*ez*") + (switch-to-buffer "*ez*") + (ez-mode) + (ez-setup-buffer) + (ez-run zfile)) + "Started EZ.") + +(defun ez-debug () + (interactive) + (switch-to-buffer "*ez*") + (ez-mode) + (ez-setup-buffer) + (ez-run "zork1.z3")) ;;; ez.el ends here