X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/d28a19252165bf9cbf272608d24c6eb8db336b4d..b08b261e8b7aabbc3a7647e620728a6dbe973652:/lisp/emacs-lisp/disass.el diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 09f6ea3d68..47a5a0c342 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -1,11 +1,11 @@ ;;; disass.el --- disassembler for compiled Emacs Lisp code -;;; Copyright (C) 1986, 1991 Free Software Foundation, Inc. +;; Copyright (C) 1986, 1991 Free Software Foundation, Inc. ;; Author: Doug Cutting ;; Jamie Zawinski ;; Maintainer: Jamie Zawinski -;; Keyword: internal +;; Keywords: internal ;; This file is part of GNU Emacs. @@ -20,14 +20,20 @@ ;; 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: -;;; Original version by Doug Cutting (doug@csli.stanford.edu) -;;; Substantially modified by Jamie Zawinski for -;;; the new lapcode-based byte compiler. +;; 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 for +;; the new lapcode-based byte compiler. ;;; Code: @@ -36,11 +42,12 @@ ;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt. (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 @@ -73,9 +80,15 @@ redefine OBJECT if it is a symbol." obj (symbol-function obj))) (if (subrp obj) (error "Can't disassemble #" 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) @@ -91,8 +104,9 @@ redefine OBJECT if it is a symbol." (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) @@ -102,7 +116,8 @@ redefine OBJECT if it is a symbol." (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) @@ -136,7 +151,7 @@ redefine OBJECT if it is a symbol." (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: ") @@ -154,10 +169,12 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (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)) @@ -165,12 +182,26 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (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)))) @@ -195,14 +226,14 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (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 "\n")) ((eq (car-safe arg) 'lambda) (insert "")) @@ -229,8 +260,9 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (let ((print-escape-newlines t)) (prin1 arg (current-buffer)))))) ) - (insert "\n")) - (setq lap (cdr lap))))) + (insert "\n"))))) nil) +(provide 'disass) + ;;; disass.el ends here