Dynamically bound functions

FLET-dynamic.lisp

;;; Dynamically bound functions.

;;; DEFUN-DYNAMIC defines a function which may be dynamically bound
;;; with FLET-DYNAMIC.

(defconstant +dynamic-fun-tag+ 'dynamic-fun-tag)


(defmacro defun-dynamic (name params &body body)
  (let ((args (gensym))
	(hidden (or (get name +dynamic-fun-tag+) (gensym))))
    `(progn
       (defparameter ,hidden
	 (lambda ,params ,@body))
       (defun ,name (&rest ,args)
	 (declare (special ,hidden))
	 (apply (symbol-value ',hidden) ,args))
       (setf (get ',name  +dynamic-fun-tag+) ',hidden))))



(defmacro flet-dynamic (clauses &body body)
  (let ((names (list)))
    `(let ,(loop
	      :for (name params . fn-body) :in clauses
	      :for hidden = (or (get name +dynamic-fun-tag+)
				(error "~a in FLET-DYNAMIC ~
                                    was not defined by DEFUN-DYNAMIC."
				       name))
	      :do (push hidden names)
	      :collect `(,hidden
			 (lambda ,params ,@fn-body)))
       (declare (special ,@names))
       ,@body)))




;;;; test

(defun-dynamic foo (x)
  (* 2 x))

(defun bar (x)
  (foo x))

(defun test ()
  (assert (boundp (get 'foo +dynamic-fun-tag+)))
  (assert (= 6 (foo 3)))
  (assert (= 30 (flet-dynamic ((foo (x) (* 10 x)))
                  (foo 3))))
  (assert (= 30 (flet-dynamic ((foo (x) (* 10 x)))
                  (bar 3))))
  (assert (= 30 (funcall (compile nil '(lambda ()
                                        (flet-dynamic ((foo (x) (* 10 x)))
                                          (bar 3)))))))
  :ok)