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 ,@binding))) (values-list (or (gethash #2# #1#) (setf (gethash #2# #1#) (multiple-value-list (progn ,@body))))))))))
Small-cl-src-discuss mailing list Small-cl-src-discuss@hexapodia.net http://www.hexapodia.net/mailman/listinfo/small-cl-src-discuss