home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 3 / goldfish_volume_3.bin / files / util / edit / jade / lisp / disassembler.jl < prev    next >
Encoding:
Text File  |  1994-10-06  |  4.9 KB  |  133 lines
  1. ;;;; disassembler.jl -- Disassembles compiled Lisp functions
  2. ;;;  Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. ;; need this for the opcode constants
  21. (require 'compiler)
  22. (provide 'disassembler)
  23.  
  24. ;; Lookup table of strings naming instructions
  25. (defvar dis-opcode-vector
  26.  [ nil nil nil nil nil nil nil nil     ; 0x00
  27.    "call" nil nil nil nil nil nil nil
  28.    "push" nil nil nil nil nil nil nil     ; 0x10
  29.    "vrefc" nil nil nil nil nil nil nil
  30.    "vsetc" nil nil nil nil nil nil nil     ; 0x20
  31.    "list" nil nil nil nil nil nil nil
  32.    "bind" nil nil nil nil nil nil nil     ; 0x30
  33.    nil nil nil nil nil nil nil nil
  34.    "vref" "vset" "fref" "fset" "init-bind" "unbind" "dup" "swap"    ; 0x40
  35.    "pop" "push\tnil" "push\tt" "cons" "car" "cdr" "rplaca" "rplacd"
  36.    "nth" "nthcdr" "aset" "aref" "length" "eval" "plus-2" "negate" "minus-2"    ; 0x50
  37.    "product-2" "divide-2" "mod-2" "lognot" "not" "logior-2" "logand-2"
  38.    "equal" "eq" "num-eq" "num-not-eq" "g-than" "ge-than" "l-than" "le-than"    ; 0x60
  39.    "inc" "dec" "lsh" "zerop" "null" "atom" "consp" "listp"
  40.    "numberp" "stringp" "vectorp" "catch-kludge" "throw" "unwind-pro" "un-unwind-pro" "fboundp"    ; 0x70
  41.    "boundp" "symbolp" "get" "put" "error-pro" "signal" "return" "reverse"
  42.    "nreverse" "assoc" "assq" "rassoc" "rassq" "last" "mapcar" "mapc" ; 0x80
  43.    "member" "memq" "delete" "delq" "delete-if" "delete-if-not" "copy-sequence" "sequencep"
  44.    "functionp" "special-form-p" "subrp" "eql" "logxor" nil nil nil ; 0x90
  45.    nil nil nil nil nil nil nil nil
  46.    nil nil nil nil nil nil nil nil     ; 0xa0
  47.    nil nil nil nil nil nil nil nil
  48.    "set-current-buffer" "swap-buffer" "current-buffer" "bufferp" "markp" "windowp" "swap-window" nil
  49.    nil nil nil nil nil nil nil nil
  50.    nil nil nil nil nil nil nil nil     ; 0xc0
  51.    nil nil nil nil nil nil nil nil
  52.    nil nil nil nil nil nil nil nil     ; 0xd0
  53.    nil nil nil nil nil nil nil nil
  54.    nil nil nil nil nil nil nil nil     ; 0xe0
  55.    nil nil nil nil nil nil nil nil
  56.    nil nil nil nil nil nil nil nil     ; 0xf0
  57.    nil nil nil "jmp\t%d" "jn\t%d" "jt\t%d" "jnp\t%d" "jtp\t%d" ])
  58.  
  59. ;;;###autoload
  60. (defun disassemble-fun (fun &optional stream)
  61.   "Disassembles the byte code form which is the function value of FUN. If
  62. STREAM is given all output goes to that stream."
  63.   (interactive "aFunction to disassemble:")
  64.   (when (symbolp fun)
  65.     (setq fun (symbol-function fun)))
  66.   (if (eq (car fun) 'macro)
  67.       (setq fun (nthcdr 3 fun))
  68.     (setq fun (nthcdr 2 fun)))
  69.   (when (or (stringp (car fun)) (numberp (car fun)))
  70.     ;; doc-string
  71.     (setq fun (cdr fun)))
  72.   (when (and (consp (car fun)) (eq (car (car fun)) 'interactive))
  73.     ;; interactive decl
  74.     (setq fun (cdr fun)))
  75.   (disassemble (car fun)) stream)
  76.  
  77. ;; Disassembles the FORM, output goes to STREAM
  78. (defun disassemble (form &optional stream)
  79.   (let
  80.       ((code-string (nth 1 form))
  81.        (consts (nth 2 form))
  82.        (i 0)
  83.        c arg op)
  84.     (unless stream
  85.       (setq stream standard-output))
  86.     (while (setq c (aref code-string i))
  87.       (format stream "\n%d:\t" i)
  88.       (cond
  89.        ((< c op-last-with-args)
  90.     (setq op (logand c 0xf8))
  91.     (cond
  92.      ((< (logand c 0x07) 6)
  93.       (setq arg (logand c 0x07)))
  94.      ((= (logand c 0x07) 6)
  95.       (setq i (1+ i)
  96.         arg (aref code-string i)))
  97.      (t
  98.       (setq arg (logior (lsh (aref code-string (1+ i)) 8)
  99.                 (aref code-string (+ i 2)))
  100.         i (+ i 2))))
  101.     (cond
  102.      ((= op op-call)
  103.       (format stream "call\t#%d" arg))
  104.      ((= op op-push)
  105.       (let
  106.           ((argobj (aref consts arg)))
  107.         (if (and (consp argobj) (eq (car argobj) 'jade-byte-code))
  108.         (progn
  109.           (format stream "push\t[%d] %S\n<byte-code" arg argobj)
  110.           (disassemble argobj stream)
  111.           (write stream "\n>"))
  112.           (format stream "push\t[%d] %S" arg (aref consts arg)))))
  113.      ((= op op-vrefc)
  114.       (format stream "vrefc\t[%d] %S" arg (aref consts arg)))
  115.      ((= op op-vsetc)
  116.       (format stream "vsetc\t[%d] %S" arg (aref consts arg)))
  117.      ((= op op-list)
  118.       (format stream "list\t#%d" arg))
  119.      ((= op op-bind)
  120.       (format stream "bind\t[%d] %S" arg (aref consts arg)))))
  121.        ((> c op-last-before-jmps)
  122.     (setq arg (logior (lsh (aref code-string (1+ i)) 8)
  123.               (aref code-string (+ i 2)))
  124.           op c
  125.           i (+ i 2))
  126.     (format stream (aref dis-opcode-vector op) arg))
  127.        (t
  128.     (if (setq op (aref dis-opcode-vector c))
  129.         (write stream op)
  130.       (format stream "<unknown opcode %d>" c))))
  131.       (setq i (1+ i)))
  132.     t))
  133.