Hello Allegro CL experts:
Is there a function in ACL 4.1 which extracts the function name
from the function object? (similar to SI:COMPILED-FUNCTION-NAME on
the Symbolics, or SYS:PROCEDURE-REF in Lucid)
e.g. #'car ==> 'car
Thanks, kerry
From: Jeff Dalton
Subject: Re: Compiled function name in Allegro CL
Date:
Message-ID: <7844@skye.ed.ac.uk>
In article <····················@bass.statsci.com> ······@statsci.com (Russell G. Almond) writes:
>
>> Is there a function in ACL 4.1 which extracts the function name
>> from the function object? (similar to SI:COMPILED-FUNCTION-NAME on
>> the Symbolics, or SYS:PROCEDURE-REF in Lucid)
>
>I've tried to write a portable function to do that.
>BTW, if anybody has any patches for other LISP dialects, I would be
>interested in getting them.
I don't have patches, but I do have something KCL-specific
that will sometimes work even for functions closes in a non-null
lexical env. The name "listing" comes from Prolog.
I wrote this years ago, so I don't make any claims for the coding
style.
----------------------------------------------------------------------
;;; "Workspace" functions for KCL.
;;; Jeff Dalton, AIAI/PSG, University if Edinburgh
(in-package :util)
(export '(defined listing))
;;; Defined
(defun defined (&optional (package *package*))
"(DEFINED [package]) prints a table of symbols that are defined
and whether they are defined as a function, variable, etc."
(let ((*print-case* :downcase))
(dolist (name (interesting-names package))
(format t "~&~3T~S ~30T~A"
name (def-types name)))))
(defun def-types (name)
(remove-if #'null
(list (if (boundp name)
"variable")
(if (and (fboundp name)
(not (macro-function name))
(not (special-form-p name)))
"function")
(if (macro-function name)
"macro")
(if (special-form-p name)
"special-form"))))
(defun interesting-names (package &optional (pred #'defined?))
(let ((names '()))
(do-symbols (s package)
(if (funcall pred s)
(push s names)))
(sort names #'string-lessp)))
(defun defined? (name)
(or (boundp name)
(fboundp name)))
(defun defined-as-function? (name)
(and (fboundp name)
(not (macro-function name))
(not (special-form-p name))))
;;; Listing
(defun listing (&key (name '() name-p)
(package *package*)
(to *standard-output*))
"(LISTING :NAME symbol :PACKAGE package :TO stream)
Prints a DEFUN for a function (if :NAME is specified) or for
all the functions in a package (if :PACKAGE is specified).
:TO can be used to direct outout to a stream other than
*standard-output*"
(if name-p
(list-function name to)
(dolist (name (interesting-names package #'defined-as-function?))
(list-function name to)
(terpri to))))
(defun list-function (name to)
(let ((def (symbol-function name)))
(let ((*print-case* :downcase)
(*print-pretty* t)
(*print-length* nil)
(*print-level* nil)
(*print-circle* nil))
(cond ((compiled-function-p def)
(format to "~&;;; ~S is ~S~%" name def))
((consp def)
(format to "~&~S~%"
(interpreted-function-defun name def)))
(t
(format to "~&;;; ~S is not reasonably defined.~%"))))))
(defun interpreted-function-defun (name def)
(case (car def)
(lambda-block
`(defun . ,(cdr def)))
(lambda-closure
(format nil "Can't reconstruct ~S." name))
(lambda-block-closure
(let ((v (variable-bindings def))
(d `(defun . ,(closure-def def))))
(if (other-bindings? def)
(format nil "Can't recreate ~S." name)
(if (null v)
d
`(let ,(nreverse
(mapcar
#'(lambda (bind)
(list (car bind)
(if (or (numberp (cadr bind))
(stringp (cadr bind)))
(cadr bind)
`',(cadr bind))))
v))
,d)))))
(t
(format nil "Unknown lambda type ~S for ~S."
(car def) name))))
;;; KCL interpreted closures look like this:
;;;
;;; (lambda-block-closure venv ?env ?env name lambda-list . body)
;;; (lambda-closure venv ?env ?env lambda-list . body)
(defun variable-bindings (closure)
(second closure))
(defun other-bindings? (closure)
(or (third closure)
(fourth closure)))
(defun closure-def (closure)
(nthcdr 4 closure))
----------------------------------------------------------------------
Now an example:
Starting xkcl ...
AKCL (Austin Kyoto Common Lisp) Version(1.505) Thu Jan 3 22:19:53 GMT 1991
Contains Enhancements by W. Schelter
> (use-package util)
t
> (defun f (x) (* x x))
f
> (let ((a 1))
(defun count-up () (incf a)))
count-up
> (count-up)
2
> (count-up)
3
> (defined)
count-up (function)
f (function)
nil
> (listing)
(let ((a 3)) (defun count-up () (incf a)))
Note the 3, rather than 1.
(defun f (x) (* x x))
nil
Jeff Dalton, JANET: ········@uk.ac.ed
AI Applications Institute, ARPA: ·················@nsfnet-relay.ac.uk
Edinburgh University. UUCP: ...!ukc!ed.ac.uk!J.Dalton