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

[Ben Hyde]

Take another wack at defun-with-cache.  This version should handle  
the optional arg provided variables bound in some lambda lists.  I  
still assume that rip-apart-lambda-list has bugs.  My thanks to  
Kristian Elof Sørensen for doing some actual testing.  I was amused  
to discover that *keywork-package* and *keyword-package* were defined  
in the the larger program this is a little part of. :-)  - 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 rip-apart-lambda-list (lambda-list)
   "Given a lambda list returns three values.  The list of symbols
    bound it binds.  Using those, a call argument list for invoking
    the function passing all arguements (see notes).  And finally a
    flag indicating if the last arguement is a &rest, i.e. if you
    need to use apply rather than funcall on that arglist.  Note
    this does note optional arguement flags, but the arglist returned
    assumes all arguements are passed."
   (let ((binds nil)
	(call nil)
	(apply? nil))
     (flet ((wrapup ()
	     (return-from
	      rip-apart-lambda-list
	      (values
	       (nreverse binds)
	       (if apply?
		   (nreverse (cons apply? call))
		   (nreverse call))
	       apply?))))
       (loop
	  with keys? = nil
	  finally (wrapup)
	  for arg in lambda-list
	  do
	  (flet ((accumulate (var)
		   (push var binds)
		   (when (eq t apply?)
		     (setf apply? var)
		     (return-from accumulate))
		   (when keys?
		     (push (intern (symbol-name var) #.(symbol-package :a))
			   call))
		   (push var call)))
	    (cond
	      ((consp arg)
	       (accumulate (first arg))
	       (when (third arg)
		 (accumulate (third-arg))))
	      ((eq arg '&aux)
	       (wrapup))
	      ((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)
   "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."
   (multiple-value-bind (binding call)
       (rip-apart-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))))))))))