[Emacs-diffs] /srv/bzr/emacs/trunk r105533: * lisp/emacs-lisp/debug.el (debug-arglist): New function.

[Stefan Monnier]

------------------------------------------------------------
revno: 105533
fixes bug(s): http://debbugs.gnu.org/cgi/bugreport.cgi?bug=9120
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Mon 2011-08-22 17:16:46 -0400
message:
  * lisp/emacs-lisp/debug.el (debug-arglist): New function.
  (debug-convert-byte-code): Use it.  Handle lexical byte-codes.
  (debug-on-entry-1): Handle interpreted closures.
modified:
  lisp/ChangeLog
  lisp/emacs-lisp/debug.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2011-08-22 12:46:45 +0000
+++ b/lisp/ChangeLog    2011-08-22 21:16:46 +0000
@@ -1,3 +1,9 @@
+2011-08-22  Stefan Monnier  <address@hidden>
+
+       * emacs-lisp/debug.el (debug-arglist): New function.
+       (debug-convert-byte-code): Use it.  Handle lexical byte-codes.
+       (debug-on-entry-1): Handle interpreted closures (bug#9120).
+
 2011-08-22  Juri Linkov  <address@hidden>
 
        * progmodes/compile.el (compilation-mode-font-lock-keywords):

=== modified file 'lisp/emacs-lisp/debug.el'
--- a/lisp/emacs-lisp/debug.el  2011-07-15 02:16:55 +0000
+++ b/lisp/emacs-lisp/debug.el  2011-08-22 21:16:46 +0000
@@ -778,6 +778,7 @@
                         (not (debugger-special-form-p symbol))))
                t nil nil (symbol-name fn)))
      (list (if (equal val "") fn (intern val)))))
+  ;; FIXME: Use advice.el.
   (when (debugger-special-form-p function)
     (error "Function %s is a special form" function))
   (if (or (symbolp (symbol-function function))
@@ -835,24 +836,30 @@
     (message "Cancelling debug-on-entry for all functions")
     (mapcar 'cancel-debug-on-entry debug-function-list)))
 
+(defun debug-arglist (definition)
+  ;; FIXME: copied from ad-arglist.
+  "Return the argument list of DEFINITION."
+  (require 'help-fns)
+  (help-function-arglist definition 'preserve-names))
+
 (defun debug-convert-byte-code (function)
   (let* ((defn (symbol-function function))
         (macro (eq (car-safe defn) 'macro)))
     (when macro (setq defn (cdr defn)))
-    (unless (consp defn)
-      ;; Assume a compiled code object.
-      (let* ((contents (append defn nil))
+    (when (byte-code-function-p defn)
+      (let* ((args (debug-arglist defn))
             (body
-             (list (list 'byte-code (nth 1 contents)
-                         (nth 2 contents) (nth 3 contents)))))
-       (if (nthcdr 5 contents)
-           (setq body (cons (list 'interactive (nth 5 contents)) body)))
-       (if (nth 4 contents)
+              `((,(if (memq '&rest args) #'apply #'funcall)
+                 ,defn
+                 ,@(remq '&rest (remq '&optional args))))))
+       (if (> (length defn) 5)
+           (push `(interactive ,(aref defn 5)) body))
+       (if (aref defn 4)
            ;; Use `documentation' here, to get the actual string,
            ;; in case the compiled function has a reference
            ;; to the .elc file.
            (setq body (cons (documentation function) body)))
-       (setq defn (cons 'lambda (cons (car contents) body))))
+       (setq defn `(closure (t) ,args ,@body)))
       (when macro (setq defn (cons 'macro defn)))
       (fset function defn))))
 
@@ -861,11 +868,12 @@
         (tail defn))
     (when (eq (car-safe tail) 'macro)
       (setq tail (cdr tail)))
-    (if (not (eq (car-safe tail) 'lambda))
+    (if (not (memq (car-safe tail) '(closure lambda)))
        ;; Only signal an error when we try to set debug-on-entry.
        ;; When we try to clear debug-on-entry, we are now done.
        (when flag
          (error "%s is not a user-defined Lisp function" function))
+      (if (eq (car tail) 'closure) (setq tail (cdr tail)))
       (setq tail (cdr tail))
       ;; Skip the docstring.
       (when (and (stringp (cadr tail)) (cddr tail))
@@ -875,9 +883,9 @@
        (setq tail (cdr tail)))
       (unless (eq flag (equal (cadr tail) '(implement-debug-on-entry)))
        ;; Add/remove debug statement as needed.
-       (if flag
-           (setcdr tail (cons '(implement-debug-on-entry) (cdr tail)))
-         (setcdr tail (cddr tail)))))
+       (setcdr tail (if flag
+                         (cons '(implement-debug-on-entry) (cdr tail))
+                       (cddr tail)))))
     defn))
 
 (defun debugger-list-functions ()