[Small-cl-src-discuss] defun-with-cache (take 3)

Ben Hyde bhyde at pobox.com
Tue Dec 13 14:52:39 UTC 2005

On Dec 11, 2005, at 11:42 PM, Kristian Elof Sørensen wrote:
> ; It said (third-arg) here ???
> "call" is never referenced.


I have no idea why, but (declaim (optimize (sb-ext::inhibit-warnings  
was in my .sbclrc and no good can come of that.

Pretty soon this will get so simple it won't be small, it will be tiny.

  - ben

;;; -*- Lisp -*- mode

(cl:defpackage "DEFUN-WITH-CACHE"
     (:use "COMMON-LISP")

(in-package "DEFUN-WITH-CACHE")

(defun bindings-of-lambda-list (lambda-list)
   "Given a lambda list returns a list of the symbols it binds."
   (block nil
     (let ((binds nil))
       (flet ((accumulate (var) (push var binds))
	     (wrapup () (return (nreverse binds))))
	(dolist (elt lambda-list (wrapup))
	  (etypecase elt
	     (accumulate (first elt))
	     (when (third elt) (accumulate (third elt))))
	     (case elt
	       ((&rest &optional &allow-other-keys &key))
	       (&aux (wrapup))
	       (otherwise (accumulate elt))))))))))


     finally (return 'ok)
   for (in out) in '(((x y z) (x y z))
		    ((x y &optional z) (x y z))
		    ((x &optional (y 2 z)) (x y z))
		    ((x &optional (y 2)) (x y))
		    ((x &optional (y 2) &key z) (x y z)))
   do (assert (equal (bindings-of-lambda-list in) out)))


(defmacro cache-of-function (function-name)
   "An equal hash table maybe stored on the plist of a function for  
   `(get ,function-name :cache-of-function))

(defun clear-cache-of-function (function-name)
   "Forget any cached results from invoking function of the given  
   (clrhash (cache-of-function function-name)))

(defmacro defun-with-cache (name args &body body)
   "Like defun, but this memoizes the function into a cache that maybe
    latter cleared."
   (let ((binding (bindings-of-lambda-list args)))
     `(let ((#1=#:cache (make-hash-table :test #'equal)))
       (setf (cache-of-function ',name) #1#)
       (defun ,name ,args
	(let ((#2=#:key (list , at binding)))
	   (or (gethash #2# #1#)
	       (setf (gethash #2# #1#)
			 (progn , at body))))))))))

More information about the Small-cl-src-discuss mailing list