From: Kerry Koitzsch
Subject: (Semi-) portable methods to extract function names
Date: Fri, 26 Jun 1992 22:45:25 +0000
Message-ID: <1992Jun26.224525.20860@ads.com>

Barmar is certainly correct in that there isnt a portable (Common Lisp)
means to extract function names from function objects, e.g. 'CAR from
#'car : there are ways to do it which hide the internal 'function name
accessors', however: one particularly kludgey way is to parse the function
object as a string! Fortunately, most mainstream Common Lisp vendors have
an internal function name accessor: the following code illustrates this
for Lucid, Allegro, Symbolics, CMU Common Lisp, and MCL. The Allegro/
CMU kludge with the readmacro will probably work with AKCL, too.
kerry

;;; Clip here --- insert in your favorite package....

(defun PSEUDO-QUOTE-READER (stream subchar arg)
  "Reader to convert a function spec into a more parsable format."
  (declare (ignore subchar arg))
  (eval
   (list 'quote
	 (second (read-from-string 
		  (nsubstitute #\space #\#
       (concatenate 'string "(" 
	    (read-line stream t nil t) ")")
			       :test #'equal))))))

#+lucid
(defun FUNCTION-NAME (x)
"The 1th slot of the procedure struct is the function name in Lucid 4.0.
 i.e. SYS:PROCEDURE-SYMBOL <X>. SYS:PROCEDURE-SYMBOL is a constant, representing the
index to the function name within the procedures slots. (see wizard doc for 4.0 lucid."
(when (sys:procedurep x)(sys:procedure-ref x SYS:PROCEDURE-SYMBOL)))

#+lucid
(defun GET-COMPILED-FUNCTION-NAME (compiled-function)
""
(function-name compiled-function))

#+(or cmu excl)
(defun GET-COMPILED-FUNCTION-NAME (compiled-function)
""
(let ((ans nil)
      (strname ""))
(setq *readtable* (copy-readtable))
(set-dispatch-macro-character #\# #\' (function pseudo-quote-reader))
(set-dispatch-macro-character #\# #\< (function pseudo-quote-reader))
(setf strname (format nil "~S" compiled-function))
(setq ans (read-from-string (SUBSEQ strname 0 (length strname))))
(setq *readtable* (copy-readtable nil))
ans))

#+lispm
(defun GET-COMPILED-FUNCTION-NAME (fn)
(cond ((symbolp fn) fn)
      ((si:lexical-closure-p x) nil)
      (T (si:compiled-function-name fn))))

#+:mcl
(defun GET-COMPILED-FUNCTION-NAME (fn)
(cond ((symbolp fn) fn)
      (T (ccl::compiled-function-name fn))))

;;; eof.