-;;; disass.el --- disassembler for compiled Emacs Lisp code
+;;; disass.el --- disassembler for compiled Emacs Lisp code -*- lexical-binding:t -*-
-;; Copyright (C) 1986, 1991, 2002-2012 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1991, 2002-2016 Free Software Foundation, Inc.
;; Author: Doug Cutting <doug@csli.stanford.edu>
;; Jamie Zawinski <jwz@lucid.com>
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
;; Keywords: internal
;; This file is part of GNU Emacs.
(require 'macroexp)
-;;; 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.
+;; 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 "bytecomp")
(defvar disassemble-column-1-indent 8 "*")
\(a lambda expression or a compiled-function object).
If OBJECT is not already compiled, we compile it, but do not
redefine OBJECT if it is a symbol."
- (interactive (list (intern (completing-read "Disassemble function: "
- obarray 'fboundp t))
- nil 0 t))
- (if (and (consp object) (not (eq (car object) 'lambda)))
- (setq object (list 'lambda () object)))
+ (interactive
+ (let* ((fn (function-called-at-point))
+ (prompt (if fn (format "Disassemble function (default %s): " fn)
+ "Disassemble function: "))
+ (def (and fn (symbol-name fn))))
+ (list (intern (completing-read prompt obarray 'fboundp t nil nil def))
+ nil 0 t)))
+ (if (and (consp object) (not (functionp object)))
+ (setq object `(lambda () ,object)))
(or indent (setq indent 0)) ;Default indent to zero
(save-excursion
(if (or interactive-p (null buffer))
(defun disassemble-internal (obj indent interactive-p)
(let ((macro 'nil)
- (name 'nil)
- (doc 'nil)
+ (name (when (symbolp obj)
+ (prog1 obj
+ (setq obj (indirect-function obj)))))
args)
- (while (symbolp obj)
- (setq name obj
- obj (symbol-function obj)))
+ (setq obj (autoload-do-load obj name))
(if (subrp obj)
(error "Can't disassemble #<subr %s>" name))
- (when (and (listp obj) (eq (car obj) 'autoload))
- (load (nth 1 obj))
- (setq obj (symbol-function name)))
- (if (eq (car-safe obj) 'macro) ;handle macros
+ (if (eq (car-safe obj) 'macro) ;Handle macros.
(setq macro t
obj (cdr obj)))
- (when (and (listp obj) (eq (car obj) 'closure))
- (error "Don't know how to compile an interpreted closure"))
- (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)
- (if (assq 'byte-code obj)
- nil
- (if interactive-p (message (if name
- "Compiling %s's definition..."
- "Compiling definition...")
- name))
- (setq obj (byte-compile obj))
- (if interactive-p (message "Done compiling. Disassembling..."))))
+ (if (eq (car-safe obj) 'byte-code)
+ (setq obj `(lambda () ,obj)))
+ (when (consp obj)
+ (unless (functionp obj) (error "not a function"))
+ (if (assq 'byte-code obj)
+ nil
+ (if interactive-p (message (if name
+ "Compiling %s's definition..."
+ "Compiling definition...")
+ name))
+ (setq obj (byte-compile obj))
+ (if interactive-p (message "Done compiling. Disassembling..."))))
(cond ((consp obj)
+ (setq args (help-function-arglist obj)) ;save arg list
(setq obj (cdr obj)) ;throw lambda away
- (setq args (car obj)) ;save arg list
(setq obj (cdr obj)))
((byte-code-function-p obj)
- (setq args (aref obj 0)))
+ (setq args (help-function-arglist obj)))
(t (error "Compilation failed")))
(if (zerop indent) ; not a nested function
(progn
(insert " args: ")
(prin1 args (current-buffer))
(insert "\n")
- (let ((interactive (cond ((consp obj)
- (assq 'interactive obj))
- ((> (length obj) 5)
- (list 'interactive (aref obj 5))))))
+ (let ((interactive (interactive-form obj)))
(if interactive
(progn
(setq interactive (nth 1 interactive))
;; but if the value of the constant is compiled code, then
;; recursively disassemble it.
(cond ((or (byte-code-function-p arg)
- (and (eq (car-safe arg) 'lambda)
+ (and (consp arg) (functionp arg)
(assq 'byte-code arg))
(and (eq (car-safe arg) 'macro)
(or (byte-code-function-p (cdr arg))
- (and (eq (car-safe (cdr arg)) 'lambda)
+ (and (consp (cdr arg))
+ (functionp (cdr arg))
(assq 'byte-code (cdr arg))))))
(cond ((byte-code-function-p arg)
(insert "<compiled-function>\n"))
- ((eq (car-safe arg) 'lambda)
+ ((functionp arg)
(insert "<compiled lambda>"))
(t (insert "<compiled macro>\n")))
(disassemble-internal