Hi
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 keyword
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)) FOO
CL-USER> (defun-cache:defun-with-cache foo1 (bar baz &key op0 (op1 42 op1-set)) (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 FOO1
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 24))
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 thrown (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 thrown NIL
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
Kristian
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 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 ,@body)) (let ((#2=#:key (list ,@binding))) (values-list (or (gethash #2# #1#) (setf (gethash #2# #1#) (multiple-value-list ,@(if apply? `((apply #',name ,@call)) `((,name ,@call)))))))))))))
Small-cl-src mailing list Small-cl-src@hexapodia.net http://www.hexapodia.net/mailman/listinfo/small-cl-src