lisp/emacs-lisp/debug.el patch.

[Lute Kamstra]

Here's a patch to handle debug-on-entry for autoloaded functions and
compiled macros.  

The patch also solves a problem with cancel-debug-on-entry.
Currently, it signals an error for built-in functions, autoloaded
functions, and aliases that are not set to debug-on entry.  The patch
makes cancel-debug-on-entry a no-op in these cases.

Ok to commit?

Lute.


Index: lisp/ChangeLog
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/ChangeLog,v
retrieving revision 1.7147
diff -c -r1.7147 ChangeLog
*** lisp/ChangeLog      23 Mar 2005 10:48:20 -0000      1.7147
--- lisp/ChangeLog      23 Mar 2005 12:14:14 -0000
***************
*** 1,5 ****
--- 1,11 ----
  2005-03-23  Lute Kamstra  <address@hidden>
  
+       * emacs-lisp/debug.el (debug-on-entry): Handle autoloaded
+       functions and compiled macros.
+       (debug-convert-byte-code): Handle macros too.
+       (debug-on-entry-1): Don't signal an error when trying to clear a
+       function that is not set to debug on entry.
+ 
        * generic-x.el: Code cleanup: make arguments constant whenever
        possible.
        (installshield-statement-keyword-list)
Index: lisp/emacs-lisp/debug.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/emacs-lisp/debug.el,v
retrieving revision 1.77
diff -c -r1.77 debug.el
*** lisp/emacs-lisp/debug.el    14 Mar 2005 17:44:56 -0000      1.77
--- lisp/emacs-lisp/debug.el    23 Mar 2005 12:14:15 -0000
***************
*** 633,656 ****
  Use \\[cancel-debug-on-entry] to cancel the effect of this command.
  Redefining FUNCTION also cancels it."
    (interactive "aDebug on entry (to function): ")
!   ;; Handle a function that has been aliased to some other function.
!   (if (and (subrp (symbol-function function))
!          (eq (cdr (subr-arity (symbol-function function))) 'unevalled))
!       (error "Function %s is a special form" function))
!   (if (or (symbolp (symbol-function function))
          (subrp (symbol-function function)))
!       ;; Create a wrapper in which we can then add the necessary debug call.
        (fset function `(lambda (&rest debug-on-entry-args)
                        ,(interactive-form (symbol-function function))
!                       (apply ',(symbol-function function)
!                              debug-on-entry-args))))
!   (or (consp (symbol-function function))
!       (debug-convert-byte-code function))
!   (or (consp (symbol-function function))
!       (error "Definition of %s is not a list" function))
    (fset function (debug-on-entry-1 function t))
!   (or (memq function debug-function-list)
!       (push function debug-function-list))
    function)
  
  ;;;###autoload
--- 633,663 ----
  Use \\[cancel-debug-on-entry] to cancel the effect of this command.
  Redefining FUNCTION also cancels it."
    (interactive "aDebug on entry (to function): ")
!   (when (and (subrp (symbol-function function)) 
!            (eq (cdr (subr-arity (symbol-function function))) 'unevalled))
!     (error "Function %s is a special form" function))
!   (if (or (symbolp (symbol-function function)) 
          (subrp (symbol-function function)))
!       ;; The function is built-in or aliased to another function.
!       ;; Create a wrapper in which we can add the debug call.
        (fset function `(lambda (&rest debug-on-entry-args)
                        ,(interactive-form (symbol-function function))
!                       (apply ',(symbol-function function) 
!                              debug-on-entry-args)))
!     (when (eq (car-safe (symbol-function function)) 'autoload)
!       ;; The function is autoloaded.  Load its real definition.
!       (load (cadr (symbol-function function)) nil noninteractive nil t))
!     (when (or (not (consp (symbol-function function)))
!             (and (eq (car (symbol-function function)) 'macro)
!                  (not (consp (cdr (symbol-function function))))))
!       ;; The function is byte-compiled.  Create a wrapper in which
!       ;; we can add the debug call.
!       (debug-convert-byte-code function)))
!   (unless (consp (symbol-function function))
!     (error "Definition of %s is not a list" function))
    (fset function (debug-on-entry-1 function t))
!   (unless (memq function debug-function-list)
!     (push function debug-function-list))
    function)
  
  ;;;###autoload
***************
*** 665,709 ****
           (if name (intern name)))))
    (if (and function (not (string= function "")))
        (progn
!       (let ((f (debug-on-entry-1 function nil)))
          (condition-case nil
!             (if (and (equal (nth 1 f) '(&rest debug-on-entry-args))
!                      (eq (car (nth 3 f)) 'apply))
!                 ;; `f' is a wrapper introduced in debug-on-entry.
!                 ;; Get rid of it since we don't need it any more.
!                 (setq f (nth 1 (nth 1 (nth 3 f)))))
            (error nil))
!         (fset function f))
        (setq debug-function-list (delq function debug-function-list))
        function)
      (message "Cancelling debug-on-entry for all functions")
      (mapcar 'cancel-debug-on-entry debug-function-list)))
  
  (defun debug-convert-byte-code (function)
!   (let ((defn (symbol-function function)))
!     (if (not (consp defn))
!       ;; Assume a compiled code object.
!       (let* ((contents (append defn nil))
!              (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)
!             ;; 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)))
!         (fset function (cons 'lambda (cons (car contents) body)))))))
  
  (defun debug-on-entry-1 (function flag)
    (let* ((defn (symbol-function function))
         (tail defn))
!     (if (subrp tail)
!       (error "%s is a built-in function" function)
!       (if (eq (car tail) 'macro) (setq tail (cdr tail)))
!       (if (eq (car tail) 'lambda) (setq tail (cdr tail))
!       (error "%s not user-defined Lisp function" function))
        ;; Skip the docstring.
        (when (and (stringp (cadr tail)) (cddr tail))
        (setq tail (cdr tail)))
--- 672,723 ----
           (if name (intern name)))))
    (if (and function (not (string= function "")))
        (progn
!       (let ((defn (debug-on-entry-1 function nil)))
          (condition-case nil
!             (when (and (equal (nth 1 defn) '(&rest debug-on-entry-args))
!                        (eq (car (nth 3 defn)) 'apply))
!               ;; `defn' is a wrapper introduced in debug-on-entry.
!               ;; Get rid of it since we don't need it any more.
!               (setq defn (nth 1 (nth 1 (nth 3 defn)))))
            (error nil))
!         (fset function defn))
        (setq debug-function-list (delq function debug-function-list))
        function)
      (message "Cancelling debug-on-entry for all functions")
      (mapcar 'cancel-debug-on-entry debug-function-list)))
  
  (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))
!            (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)
!           ;; 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))))
!       (when macro (setq defn (cons 'macro defn)))
!       (fset function defn))))
  
  (defun debug-on-entry-1 (function flag)
    (let* ((defn (symbol-function function))
         (tail defn))
!     (when (eq (car-safe tail) 'macro) 
!       (setq tail (cdr tail)))
!     (if (not (eq (car-safe tail) '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))
!       (setq tail (cdr tail))
        ;; Skip the docstring.
        (when (and (stringp (cadr tail)) (cddr tail))
        (setq tail (cdr tail)))
***************
*** 714,721 ****
        ;; Add/remove debug statement as needed.
        (if flag
            (setcdr tail (cons '(implement-debug-on-entry) (cdr tail)))
!         (setcdr tail (cddr tail))))
!       defn)))
  
  (defun debugger-list-functions ()
    "Display a list of all the functions now set to debug on entry."
--- 728,735 ----
        ;; Add/remove debug statement as needed.
        (if flag
            (setcdr tail (cons '(implement-debug-on-entry) (cdr tail)))
!         (setcdr tail (cddr tail)))))
!     defn))
  
  (defun debugger-list-functions ()
    "Display a list of all the functions now set to debug on entry."