[Small-cl-src-discuss] Re: [Small-cl-src] defun-with-cache
Kristian Elof Sørensen
elof at image.dk
Sat Dec 10 06:01:58 UTC 2005
I played around with your code a bit.
There are two compilation errors on sbcl, cmucl and clisp on linux.
1) (finish) does not exist - used when the user supplies &aux
2) *keywork-package* does not exist
I changed (finish) into a call to warn
I chanhed *keyword-package* into "KEYWORD" which intern the symbol as a
With these two changes, it seems that ordinary arguments works but
optional does not.
Keyword arguments mostly work but there is a problem with the "was this
keyword parameters value set it is it its default value" parameter.
CL-USER> (defun-cache:defun-with-cache foo (bar baz &optional op0 op1)
(list :bar bar :baz baz :op0 op0 :op1 op1))
CL-USER> (defun-cache:defun-with-cache foo1 (bar baz &key op0 (op1 42
(list :bar bar :baz baz :op0 op0 :op1 op1 :op1-set op1-set))
; caught STYLE-WARNING:
; The variable OP1-SET is defined but never used.
; compilation unit finished
; caught 1 STYLE-WARNING condition
CL-USER> (loop for expr in '((foo 1 2 3 4) (foo 4 3 2) (foo 4 3 '(2)
'(1)) (foo 1 2) (foo 1)
(foo1 1 2 :op1 42) (foo1 1 2 :op0 42) (foo1 1 2 :op1 42 :op0
do (format t "~A " expr)
do (catch 'trap-errors
(handler-bind ((type-error (lambda (err)
(format t "caught type-error: ~A~%" err)
(throw 'trap-errors nil)))
(error (lambda (err)
(format t "caught error: ~A~%" err)
(throw 'trap-errors nil))))
(format t "~A no error thrown~%" (eval expr)))))
(FOO 1 2 3 4) caught type-error: The value 3 is not of type LIST.
(FOO 4 3 2) caught type-error: The value 2 is not of type LIST.
(FOO 4 3 '(2) '(1)) (BAR 4 BAZ 3 OP0 (1) OP1 2) no error thrown
(FOO 1 2) (BAR 1 BAZ 2 OP0 NIL OP1 NIL) no error thrown
(FOO 1) caught error: invalid number of arguments: 1
(FOO1 1 2 OP1 42) (BAR 1 BAZ 2 OP0 NIL OP1 42 OP1-SET T) no error
(FOO1 1 2 OP0 42) (BAR 1 BAZ 2 OP0 42 OP1 42 OP1-SET T) no error thrown
(FOO1 1 2 OP1 42 OP0 24) (BAR 1 BAZ 2 OP0 24 OP1 42 OP1-SET T) no error
The three first expressions shows some problems with optional arguments
In the second to last expression the result for (FOO1 1 2 OP0 42) is
returning op1-set as t where it should be nil
fre, 09 12 2005 kl. 22:38 -0500, skrev 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
> - ben
> (defun rip-apart-arglist (arglist)
> 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))
> for arg in arglist
> (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*)
> (push var call)))
> ((consp arg)
> (accumulate (first arg)))
> ((eq arg '&aux)
> ((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)))
> (or (gethash #2# #1#)
> (setf (gethash #2# #1#)
> ,@(if apply?
> `((apply #',name , at call))
> `((,name , at call)))))))))))))
> Small-cl-src mailing list
> Small-cl-src at hexapodia.net
More information about the Small-cl-src-discuss