Fix disassembly of non-compiled lexical functions (bug#21377)

[gnu-emacs] / lisp / emacs-lisp / disass.el

diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el
index 15489fc2015abed1e3c7c1ebb7f01e85a5e7ac67..12cf605cce91030cae2952479b304c2fb283037a 100644 (file)
--- a/lisp/emacs-lisp/disass.el
+++ b/lisp/emacs-lisp/disass.el
@@ -1,4 +1,4 @@
-;;; disass.el --- disassembler for compiled Emacs Lisp code
+;;; disass.el --- disassembler for compiled Emacs Lisp code  -*- lexical-binding:t -*-
 
 ;; Copyright (C) 1986, 1991, 2002-2015 Free Software Foundation, Inc.
 
@@ -37,9 +37,9 @@
 
 (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 "*")
@@ -57,8 +57,8 @@ 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)))
+  (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))
@@ -72,37 +72,34 @@ redefine OBJECT if it is a symbol."
 
 (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))
-    (setq obj (autoload-do-load obj 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)
-       (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
@@ -127,10 +124,7 @@ redefine OBJECT if it is a symbol."
     (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))
@@ -226,15 +220,16 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler."
                 ;; 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