[Small-cl-src] defun-with-cache

[Ben Hyde]

This is a lark.

Given a function:    (defun f (...) ...)

You can rewrite that into:   (defun-with-cache f (...) ...)

at which point a second call upon f with the same arguments will  
return the values returned the first time.  You can clear the cache  
by calling.
   (clear-cache-of-function 'f)

If I was to guess where this is likely to have a bug I'd pick rip- 
apart-arglist; who's job is to handle &optional, &rest, &keys, etc.   
If I was to pick the part likely to make the casual reader's brain  
hurt it would be body of defun-with-cache, which was pure fun to write.

It's fine if F returns multiple values.

This does what I need in the code where I'm using it, so "I think I'm  
happy."

   - ben


(defun rip-apart-arglist (arglist)
   (loop
       with binds = nil
       with call = nil
       with apply? = nil
       with keys? = nil
       finally (return (values
		       (nreverse binds)
		       (if apply?
			   (nreverse (cons apply? call))
			   (nreverse call))
		       apply?))
       for arg in arglist
       do
       (flet ((accumulate (var)
	       (push var binds)
	       (when (eq t apply?)
		 (setf apply? var)
		 (return-from accumulate))
	       (when keys?
		 (push (intern (symbol-name var) *keywork-package*)
		       call))
	       (push var call)))
	(cond
	  ((consp arg)
	   (accumulate (first arg)))
	  ((eq arg '&aux)
	   (finish))	
	  ((eq arg '&rest)
	   (setf apply? t))	
	  ((eq arg '&optional)
	   (setf apply? t))
	  ((eq arg '&allow-other-keys)
	   (setf apply? t))
	  ((eq arg '&key)
	   (setf keys? t))
	  ((symbolp arg)
	   (accumulate arg))))))

(defmacro cache-of-function (function-name)
   `(get ,function-name :cache-of-function))

(defun clear-cache-of-function (function-name)
   (clrhash (cache-of-function function-name)))

(defmacro defun-with-cache (name args &body body)
   (multiple-value-bind (binding call apply?)
       (rip-apart-arglist args)
     `(let ((#1=#:cache (make-hash-table :test #'equal)))
       (setf (cache-of-function ',name) #1#)
       (defun ,name ,args
	(flet ((,name ,args , at body))
	  (let ((#2=#:key (list , at binding)))
	    (values-list
	     (or (gethash #2# #1#)
		 (setf (gethash #2# #1#)
		       (multiple-value-list
			   ,@(if apply?
				 `((apply #',name , at call))
				 `((,name , at call)))))))))))))