X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=ez.git;a=blobdiff_plain;f=ez.el;h=af348a982f49420db40b407bda96f4819116140c;hp=ac409803eb15dccf3104958cc93abf2c4595df1b;hb=6a8f22a5f03a455c5cc4a6af1bfcbf117c9084ee;hpb=737aeafc9a89357b63b50c21d9f60def16cb7388 diff --git a/ez.el b/ez.el index ac40980..af348a9 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 "")) @@ -50,6 +55,14 @@ new-s (binformat d new-s)))) +(defun ez-list-to-string-hex (l) + (concat "(" + (when l + (concat + (format "%x" (car l)) + (apply 'concat (mapcar (lambda (n) (format " %x" n)) (cdr l))))) + ")")) + ;; Memory (defvar ez-memory nil @@ -59,7 +72,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 +112,16 @@ ;; Global variables (defun ez-get-global-var (gvar) - (ez-mem-ref-word (+ (* 2 gvar) ez-globalvartab-addr))) + (if (> gvar 239) + (error "Invalid global variable %d" gvar)) + (let ((val + (ez-mem-ref-word (+ (* 2 gvar) ez-globalvartab-addr)))) + (message "\tRetrieved %x from global variable %x" val gvar) + val)) (defun ez-set-global-var (gvar val) - (ez-mem-set-word (+ (* 2 gvar) ez-globalvartab-addr) val)) + (ez-mem-set-word (+ (* 2 gvar) ez-globalvartab-addr) val) + (message "\tSet global variabl %x to %x" gvar val)) ;; Object tree @@ -113,46 +132,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))))) @@ -196,6 +212,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 +267,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 +307,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 @@ -272,20 +334,25 @@ (defun ez-routine-stack-push (val) (let ((frame (car ez-call-stack))) + (message "\tPushed %x to stack" val) (setf (elt frame 1) (cons val (elt frame 1))))) (defun ez-routine-stack-pop () (let* ((frame (car ez-call-stack)) (rs-head (car (elt frame 1)))) (setf (elt frame 1) (cdr (elt frame 1))) + (message "\tPopped %x from stack" rs-head) rs-head)) (defun ez-get-local-var (lvar) - (let ((frame (car ez-call-stack))) - (aref (elt frame 2) (- lvar 1)))) + (let* ((frame (car ez-call-stack)) + (val (aref (elt frame 2) (- lvar 1)))) + (message "\tRetrieved value %x from local variable %x" val lvar) + val)) (defun ez-set-local-var (lvar val) (let ((frame (car ez-call-stack))) + (message "\tSet local variable %x to %x" lvar val) (aset (elt frame 2) (- lvar 1) val))) (defun ez-get-pc () @@ -333,9 +400,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 +443,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 %x" 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)) @@ -390,10 +461,11 @@ (let ((table-row (assoc (list optype opcode) ez-op-table))) (unless table-row (error "Unsupported op PC:%x Optype:%s Opcode:%x Operands:%s Operand-types:%s" - instr-pc optype opcode operands operand-types)) + instr-pc optype opcode (ez-list-to-string-hex 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 + (ez-list-to-string-hex operands) operand-types)) (funcall (elt table-row 2) operands operand-types)))) (defun ez-read-var-operands-and-inc () @@ -402,19 +474,18 @@ (if (= type1 #b11) nil (cons type1 - (let ((type2 (lsh (logand #b110000 type-byte) -4))) + (let ((type2 (mod (lsh type-byte -4) 4))) (if (= type2 #b11) nil (cons type2 - (let ((type3 (lsh (logand #b1100 type-byte) -2))) + (let ((type3 (mod (lsh type-byte -2) 4))) (if (= type3 #b11) nil (cons type3 - (let ((type4 (logand #b11))) + (let ((type4 (mod type-byte 4))) (if (= type4 #b11) nil - (list type4))))))))))))) - (operands nil)) + (list type4)))))))))))))) (cons (mapcar (lambda (type) @@ -461,13 +532,24 @@ '(((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) + ((0op #x08) ret_pulled ez-op-ret-pulled) ((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 #x03) jg ez-op-jg) + ((2op #x06) jin ez-op-jin) + ((2op #x07) test ez-op-test) ((2op #x08) or ez-op-or) ((2op #x09) and ez-op-and) ((2op #x14) add ez-op-add) @@ -475,19 +557,36 @@ ((2op #x16) mul ez-op-mul) ((2op #x17) div ez-op-div) ((2op #x18) mod ez-op-mod) - ((var #x00) call_fv ez-op-callf) + ((var #x00) call_fv ez-op-callfv) ((1op #x01) get_sibling ez-op-get-sibling) ((1op #x02) get_child ez-op-get-child) ((1op #x03) get_parent ez-op-get-parent) ((2op #x0A) test_attr ez-op-test-attr) - ((var #x03) put_prop ez-op-put-prop))) + ((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))) + (message "\tReturning value %x" retval) (ez-pop-call-stack-frame) (ez-set-var (ez-read-pc-byte-and-inc) retval)) t) +(defun ez-op-ret-pulled (operands operand-types) + (let ((retval (ez-routine-stack-pop))) + (message "\tReturning value %x" retval) + (ez-op-ret (list retval))) + t) + (defun ez-op-rtrue (&optional operands operand-types) (ez-op-ret (list 1)) t) @@ -504,6 +603,43 @@ (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-test (operands operand-types) + (let ((a (car operands)) + (b (cadr operands))) + (ez-do-branch (= (logand a b) b))) + t) + (defun ez-op-jump (operands operand-types) (let ((offset (if (eq (car operand-types) 'b) (ez-decode-signed-byte (car operands)) @@ -511,6 +647,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))) @@ -535,6 +681,19 @@ (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))) @@ -571,18 +730,20 @@ (defun ez-op-mod (a b) (error "Not implemented")) -(defun ez-op-callf (operands operand-types) +(defun ez-op-callfv (operands operand-types) (let* ((raddr (car operands)) (call-operands (cdr operands)) (r (* 2 raddr)) (L (ez-mem-ref-byte r)) (n (length call-operands)) (new-pc (+ r 1 (* L 2)))) - (ez-add-call-stack-frame new-pc) - (dotimes (i L) - (if (< i n) - (ez-set-local-var (+ i 1) (elt call-operands i)) - (ez-set-local-var (+ i 1) (ez-mem-ref-word (+ r 1 (* 2 i))))))) + (if (= raddr 0) + (ez-set-var (ez-read-pc-byte-and-inc) 0) ; Simply return 0 + (ez-add-call-stack-frame new-pc) + (dotimes (i L) + (if (< i n) + (ez-set-local-var (+ i 1) (elt call-operands i)) + (ez-set-local-var (+ i 1) (ez-mem-ref-word (+ r 1 (* 2 i)))))))) t) (defun ez-op-test-attr (operands operand-types) @@ -591,32 +752,88 @@ (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)) - t)) + (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)) - t)) + (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)) - t)) + (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) - t)) + (ez-set-obj-prop obj prop a)) + t) -;; Main +(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) + +(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) @@ -625,13 +842,58 @@ (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 +;; + +(defvar ez-input-marker nil + "Marker for input 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-input-marker) + (set-marker ez-input-marker (point-max)) + (setq ez-input-marker (point-max-marker))) + (goto-char (point-max)))) + + +(defun ez-print (string) + (with-current-buffer "*ez*" + (save-excursion + (goto-char ez-input-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