small-cl-src-discuss

Download

small-cl-src-discuss@common-lisp.net

December 2005

2 participants
1 discussions

[Small-cl-src-discuss] Re: [Small-cl-src] defun-with-cache
by Kristian Elof Sørensen 13 Dec '05

13 Dec '05

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(a)hexapodia.net > http://www.hexapodia.net/mailman/listinfo/small-cl-src

2 4