;;; Call stack access functionality library for Common Lisp
;;; The standard CL functions DEFUN LAMBDA LABELS FLET are redefined
;;; in such a way that there would be a dynamic variable *call-stack*
;;; and a symbol macro THIS-FUNCTION accessible.
;;; *CALL-STACK* represents the current call stack, it's a list/stack
;;; of FUNCTION-WRAPPER objects. A FUNCTION-WRAPPER object contains
;;; the function name, lambda list, arguments, the caller and the
;;; current function object/closure.
;;; THIS-FUNCTION is the current FUNCTION-WRAPPER object representing
;;; the current function object/closure.
;;; For convenience reasons FUNCALL APPLY MULTIPLE-VALUE-CALL are
;;; redefined as well, so you can FUNCALL/APPLY/M-V-C FUNCTION-WRAPPER
;;; objects. If you want to get to the original function object
;;; manually, just call function-object.
;;; Current issues:
;;;
;;; This implementation probably breaks lots of optimizations which
;;; can be done on arguments. Some optimizations may be possible by
;;; declaring *CALL-STACK* as having DYNAMIC-EXTENT, but that might
;;; lead to some problems in certain usage cases, so I haven't
;;; included that declaration.
;;; TCO in functions using these library is probably broken as well as
;;; we're keeping our own call stack. Some implementations may be
;;; able to do TCO in the presence of dynamic variables, but I haven't
;;; looked into what implementations can actually do that.
;;; Standard lambda lists are treated as destructuring-bind lists,
;;; which support a bit more options than standard lambda lists.
;;; FLET/LABELS implementation could be slightly more efficient (avoid
;;; the APPLY call).
;;; In closing: this library is rather alpha-quality, although it
;;; works fine. Feel free to spend more time to polish it if you want,
;;; but I've only implemented it to show how it can be done. I've
;;; never actually felt the need for such a library when writing code.
;;; Such functionality isn't in CL because it would add some overhead
;;; to compiled lisps, although if you want it, it's easy to
;;; implement, as I've shown below. In interpreted Lisps, it may
;;; sometimes be present: I think you can do this without overhead in
;;; CLISP by getting the current environment object and examining it.
;;; This is supposed to be split into 3 files and managed by ASDF,
;;; some other defsystem or compile/loaded manually:
;;;
;;; utils.lisp, fun-arguments.lisp, examples.lisp (loaded in that order)
;;; It will however work fine as a single file due to layout/eval-when's.
;; PARSE-BODY is taken from the Alexandria library. (eval-when (:compile-toplevel :load-toplevel :execute) (defun parse-body (body &key documentation whole)
"Parses BODY into (values remaining-forms declarations doc-string).
Documentation strings are recognized only if DOCUMENTATION is true.
Syntax errors in body are signalled and WHOLE is used in the signal
arguments when given." (let ((doc nil) (decls nil) (current nil)) (tagbody
:declarations (setf current (car body)) (when (and documentation (stringp current)(cdr body)) (if doc (error "Too many documentation strings in ~S." (or whole body)) (setf doc (pop body))) (go :declarations)) (when (and (listp current)(eql (first current) 'declare)) (push (pop body) decls) (go :declarations))) (values body (nreverse decls) doc))))
(defvar *print-function-object-long-form* t
"Controls if a long form containg the wrapped function object
will be printed, or a short form containing the name")
(defmethod print-object ((object function-wrapper) stream) (print-unreadable-object (object stream :type t :identity t) (let ((name (function-name object))) (if (or *print-function-object-long-form* (eql name *unbound-marker*)) (princ (function-object object) stream) (princ name stream)))))
(defvar *call-stack* nil
"Call stack of function wrapper objects.")
(eval-when (:compile-toplevel :load-toplevel :execute) (cl:defun generate-wrapper-function-body (anonymousp lambda-list body
&key (name nil name-present-p)
object) (multiple-value-bind (body declarations doc-string) (parse-body body :documentation t) (with-gensyms (rest)
`(,(if anonymousp 'cl:lambda name)(&rest ,rest)
,@(when doc-string `(,doc-string)) (symbol-macrolet ((this-function #1=(first *call-stack*)))
;; the right way is to use a simple lambda-list
;; destructuring function, but this works too, although
;; it supports more patterns than DEFUN does. (destructuring-bind ,lambda-list ,rest
,@declarations (let ((*call-stack* (cons (make-instance 'function-wrapper
,@(when name-present-p
`(:name ',name))
:arguments ,rest
:lambda-list ',lambda-list
:object ,(if anonymousp
object
`#',name)
;; I think caller is pointless
;; when you can just look these
;; objects up the *call-stack*,
;; but for the sake of the example:
:caller #1#)
*call-stack*)))
,@body)))))))
;; This can be defined in a more straightforward way using LABELS,
;; but I did it this way to show that it's still possible even
;; without LABELS. (cl:defun generate-wrapper-lambda-body (lambda-list body &key (name nil name-present-p)) (with-gensyms (the-lambda)
`(let (,the-lambda) (setf ,the-lambda
#',(cl:apply #'generate-wrapper-function-body t lambda-list body
:object the-lambda (when name-present-p `(:name ,name))))))))