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

[Kristian Elof Sørensen]

Hi

lør, 10 12 2005 kl. 22:19 -0500, skrev 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

This version passed all the tests from my previous bug report. It is
very nice to see such a fast turn around time for bug fixes.

There was a single compile error this time around:

(cond
  ((consp arg)
    (accumulate (first arg))
    (when (third arg)
      (accumulate (third arg)))) ;; It said (third-arg) here ???

Compiling this macro with sbcl gives a "Style Warning" saying that
"call" is never referenced. If you have no use for "call" then you could
swap the (multiple-value-bind (binding call) ... for a (let
((binding ... :

(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)



> 
> ;;; -*- 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))))))))))
> 
> 
> 
> 
> _______________________________________________
> Small-cl-src-discuss mailing list
> Small-cl-src-discuss at hexapodia.net
> http://www.hexapodia.net/mailman/listinfo/small-cl-src-discuss