Re: describe-function and advised C functions

[Tassilo Horn <tsdh@gnu.org>]

Stefan Monnier <monnier@iro.umontreal.ca> writes:

>> The following patch restores that behavior for the current trunk.  Good
>> to commit?
>
> No: Anything that starts with "ad-" means that it will only work with
> functions advised via the old advice.el but not with the new nadvice.el.
>
> Can you try and adjust your patch to use advice-* functions?

Yeah.  Here's a patch that removes all ad-* function usages in
help-fns.el which also fixes the original regression.  It's a bit hairy,
especially when you have pieces of advice on aliases, but it seems to do
the trick.  It wouldn't be bad if someone else could have a look at the
patch.

--8<---------------cut here---------------start------------->8---
=== modified file 'lisp/help-fns.el'
--- lisp/help-fns.el	2013-06-15 01:12:05 +0000
+++ lisp/help-fns.el	2013-12-04 10:43:34 +0000
@@ -382,8 +382,6 @@
 			    (match-string 1 str))))
 	(and src-file (file-readable-p src-file) src-file))))))
 
-(declare-function ad-get-advice-info "advice" (function))
-
 (defun help-fns--key-bindings (function)
   (when (commandp function)
     (let ((pt2 (with-current-buffer standard-output (point)))
@@ -531,27 +529,46 @@
 
 ;;;###autoload
 (defun describe-function-1 (function)
-  (let* ((advised (and (symbolp function) (featurep 'advice)
-		       (ad-get-advice-info function)))
+  (let* ((advised (and (symbolp function)
+		       (featurep 'nadvice)
+		       (advice--p (advice--symbol-function function))))
 	 ;; If the function is advised, use the symbol that has the
 	 ;; real definition, if that symbol is already set up.
 	 (real-function
 	  (or (and advised
-		   (let ((origname (cdr (assq 'origname advised))))
-		     (and (fboundp origname) origname)))
+		   (let* ((f function)
+			  (advised-fn (advice--cdr (advice--symbol-function f))))
+		     (while (advice--p advised-fn)
+		       (setq f advised-fn)
+		       (setq advised-fn (advice--cdr (if (symbolp f)
+							 (advice--symbol-function f)
+						       f))))
+		     advised-fn))
 	      function))
 	 ;; Get the real definition.
 	 (def (if (symbolp real-function)
 		  (symbol-function real-function)
-		function))
-	 (aliased (symbolp def))
-	 (real-def (if aliased
-		       (let ((f def))
-			 (while (and (fboundp f)
-				     (symbolp (symbol-function f)))
-			   (setq f (symbol-function f)))
-			 f)
-		     def))
+		real-function))
+	 (aliased (or (symbolp def)
+		      ;; advised, aliased lisp function
+		      (and (symbolp function)
+			   (symbolp real-function)
+			   (not (eq function real-function)))
+		      ;; advised, aliased subr
+		      (and (symbolp function)
+			   (subrp def)
+			   (not (eq (intern (subr-name def)) function)))))
+	 (real-def (cond
+		    ((and aliased ;;(symbolp def)
+			  )
+		     (let ((f real-function))
+		       (while (and (fboundp f)
+				   (symbolp (symbol-function f)))
+			 (setq f (symbol-function f)))
+		       f))
+		    ((and aliased (symbolp real)))
+		    ((subrp def) (intern (subr-name def)))
+		    (t def)))
 	 (file-name (find-lisp-object-file-name function def))
          (pt1 (with-current-buffer (help-buffer) (point)))
 	 (beg (if (and (or (byte-code-function-p def)
@@ -567,14 +584,14 @@
     ;; Print what kind of function-like object FUNCTION is.
     (princ (cond ((or (stringp def) (vectorp def))
 		  "a keyboard macro")
+		 (aliased
+		  (format "an alias for `%s'" real-def))
 		 ((subrp def)
 		  (if (eq 'unevalled (cdr (subr-arity def)))
 		      (concat beg "special form")
 		    (concat beg "built-in function")))
 		 ((byte-code-function-p def)
 		  (concat beg "compiled Lisp function"))
-		 (aliased
-		  (format "an alias for `%s'" real-def))
 		 ((eq (car-safe def) 'lambda)
 		  (concat beg "Lisp function"))
 		 ((eq (car-safe def) 'macro)
--8<---------------cut here---------------end--------------->8---

To test it, I did the following old and new advice definitions in
*scratch*.

--8<---------------cut here---------------start------------->8---
(defadvice load (before my-load-advice activate)
  ;; do nothing
  )

(advice-add 'append :before #'ignore)

(defalias 'concat-seqs 'append)

(advice-add 'concat-seqs :after #'ignore)

(defadvice concat-seqs (around blabla activate)
  ad-do-it)

(defalias 'quack-mode 'scheme-mode)

(defadvice scheme-mode (before before-scheme-mode activate)
  ;; do nothing
  )

(advice-add 'quack-mode :before #'ignore)
--8<---------------cut here---------------end--------------->8---

Here's what I now get with C-h f:

,----[ C-h f load RET ]
| load is a built-in function in `C source code'.
| 
| (load FILE &optional NOERROR NOMESSAGE NOSUFFIX MUST-SUFFIX)
| 
| :around advice: `ad-Advice-load'
`----

,----[ C-h f append RET ]
| append is a built-in function in `C source code'.
| 
| (append &rest SEQUENCES)
| 
| :before advice: `ignore'
`----

,----[ C-h f concat-seqs RET ]
| concat-seqs is an alias for `append'.
| 
| (concat-seqs &rest SEQUENCES)
| 
| :around advice: `ad-Advice-concat-seqs'
| :after advice: `ignore'
| 
| :before advice: `ignore'
`----

,----[ C-h f scheme-mode RET ]
| scheme-mode is an interactive autoloaded compiled Lisp function in `scheme.el'.
| 
| (scheme-mode)
| 
| Parent mode: `prog-mode'.
| 
| :around advice: `ad-Advice-scheme-mode'
`----

,----[ C-h f quack-mode RET ]
| quack-mode is an alias for `scheme-mode'.
| 
| (quack-mode)
| 
| :before advice: `ignore'
| 
| :around advice: `ad-Advice-scheme-mode'
`----

That looks reasonable to me.

Bye,
Tassilo