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

[Ben Hyde]

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

Thanks!

I have no idea why, but (declaim (optimize (sb-ext::inhibit-warnings  
3)))
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")
   (:export "DEFUN-WITH-CACHE" "CLEAR-CACHE-OF-FUNCTION"))

(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
	    (cons
	     (accumulate (first elt))
	     (when (third elt) (accumulate (third elt))))
	    (symbol
	     (case elt
	       ((&rest &optional &allow-other-keys &key))
	       (&aux (wrapup))
	       (otherwise (accumulate elt))))))))))

#|

(loop
     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  
caching."
   `(get ,function-name :cache-of-function))

(defun clear-cache-of-function (function-name)
   "Forget any cached results from invoking function of the given  
symbol."
   (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)))
	  (values-list
	   (or (gethash #2# #1#)
	       (setf (gethash #2# #1#)
		     (multiple-value-list
			 (progn , at body))))))))))