-;;; Disassembler for compiled Emacs Lisp code
-;;; Copyright (C) 1986, 1991 Free Software Foundation, Inc.
-;;; Original version by Doug Cutting (doug@csli.stanford.edu)
-;;; Substantially modified by Jamie Zawinski <jwz@lucid.com> for
-;;; the new lapcode-based byte compiler.
-;;; Last modified 22-oct-91.
+;;; disass.el --- disassembler for compiled Emacs Lisp code
+
+;; Copyright (C) 1986, 1991 Free Software Foundation, Inc.
+
+;; Author: Doug Cutting <doug@csli.stanford.edu>
+;; Jamie Zawinski <jwz@lucid.com>
+;; Maintainer: Jamie Zawinski <jwz@lucid.com>
+;; Keywords: internal
;; This file is part of GNU Emacs.
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; The single entry point, `disassemble', disassembles a code object generated
+;; by the Emacs Lisp byte-compiler. This doesn't invert the compilation
+;; operation, not by a long shot, but it's useful for debugging.
+
+;;
+;; Original version by Doug Cutting (doug@csli.stanford.edu)
+;; Substantially modified by Jamie Zawinski <jwz@lucid.com> for
+;; the new lapcode-based byte compiler.
+;;; Code:
;;; The variable byte-code-vector is defined by the new bytecomp.el.
;;; The function byte-decompile-lapcode is defined in byte-opt.el.
;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt.
-(require 'byte-compile)
+(require 'byte-compile "bytecomp")
-(defvar disassemble-column-1-indent 5 "*")
+(defvar disassemble-column-1-indent 8 "*")
(defvar disassemble-column-2-indent 10 "*")
(defvar disassemble-recursive-indent 3 "*")
+;;;###autoload
(defun disassemble (object &optional buffer indent interactive-p)
"Print disassembled code for OBJECT in (optional) BUFFER.
OBJECT can be a symbol defined as a function, or a function itself
obj (symbol-function obj)))
(if (subrp obj)
(error "Can't disassemble #<subr %s>" name))
+ (if (and (listp obj) (eq (car obj) 'autoload))
+ (progn
+ (load (nth 1 obj))
+ (setq obj (symbol-function name))))
(if (eq (car-safe obj) 'macro) ;handle macros
(setq macro t
obj (cdr obj)))
+ (if (and (listp obj) (eq (car obj) 'byte-code))
+ (setq obj (list 'lambda nil obj)))
(if (and (listp obj) (not (eq (car obj) 'lambda)))
(error "not a function"))
(if (consp obj)
(setq obj (cdr obj)) ;throw lambda away
(setq args (car obj)) ;save arg list
(setq obj (cdr obj)))
- (t
- (setq args (aref obj 0))))
+ ((byte-code-function-p obj)
+ (setq args (aref obj 0)))
+ (t (error "Compilation failed")))
(if (zerop indent) ; not a nested function
(progn
(indent-to indent)
(if name (format " %s" name) "")))))
(let ((doc (if (consp obj)
(and (stringp (car obj)) (car obj))
- (and (> (length obj) 4) (aref obj 4)))))
+ ;; Use documentation to get lazy-loaded doc string
+ (documentation obj t))))
(if (and doc (stringp doc))
(progn (and (consp obj) (setq obj (cdr obj)))
(indent-to indent)
(insert "\n"))))
(cond ((and (consp obj) (assq 'byte-code obj))
(disassemble-1 (assq 'byte-code obj) indent))
- ((compiled-function-p obj)
+ ((byte-code-function-p obj)
(disassemble-1 obj indent))
(t
(insert "Uncompiled body: ")
(if (consp obj)
(setq bytes (car (cdr obj)) ;the byte code
constvec (car (cdr (cdr obj)))) ;constant vector
+ ;; If it is lazy-loaded, load it now
+ (fetch-bytecode obj)
(setq bytes (aref obj 1)
constvec (aref obj 2)))
- (let ((lap (byte-decompile-bytecode bytes constvec))
- op arg opname)
+ (let ((lap (byte-decompile-bytecode (string-as-unibyte bytes) constvec))
+ op arg opname pc-value)
(let ((tagno 0)
tmp
(lap lap))
(setcar (cdr tmp) (setq tagno (1+ tagno)))
(setq lap (cdr (memq tmp lap)))))
(while lap
+ ;; Take off the pc value of the next thing
+ ;; and put it in pc-value.
+ (setq pc-value nil)
+ (if (numberp (car lap))
+ (setq pc-value (car lap)
+ lap (cdr lap)))
+ ;; Fetch the next op and its arg.
(setq op (car (car lap))
arg (cdr (car lap)))
+ (setq lap (cdr lap))
(indent-to indent)
(if (eq 'TAG op)
- (insert (int-to-string (car arg)) ":")
-
+ (progn
+ ;; We have a label. Display it, but first its pc value.
+ (if pc-value
+ (insert (format "%d:" pc-value)))
+ (insert (int-to-string (car arg))))
+ ;; We have an instruction. Display its pc value first.
+ (if pc-value
+ (insert (format "%d" pc-value)))
(indent-to (+ indent disassemble-column-1-indent))
(if (and op
(string-match "^byte-" (setq opname (symbol-name op))))
(setq arg (car arg))
;; but if the value of the constant is compiled code, then
;; recursively disassemble it.
- (cond ((or (compiled-function-p arg)
+ (cond ((or (byte-code-function-p arg)
(and (eq (car-safe arg) 'lambda)
(assq 'byte-code arg))
(and (eq (car-safe arg) 'macro)
- (or (compiled-function-p (cdr arg))
+ (or (byte-code-function-p (cdr arg))
(and (eq (car-safe (cdr arg)) 'lambda)
(assq 'byte-code (cdr arg))))))
- (cond ((compiled-function-p arg)
+ (cond ((byte-code-function-p arg)
(insert "<compiled-function>\n"))
((eq (car-safe arg) 'lambda)
(insert "<compiled lambda>"))
(let ((print-escape-newlines t))
(prin1 arg (current-buffer))))))
)
- (insert "\n"))
- (setq lap (cdr lap)))))
+ (insert "\n")))))
nil)
+
+(provide 'disass)
+
+;;; disass.el ends here
HCoop / bpt / emacs.git / blobdiff