From elof at image.dk Sat Dec 10 06:01:58 2005 From: elof at image.dk (Kristian Elof =?ISO-8859-1?Q?S=F8rensen?=) Date: Sat, 10 Dec 2005 07:01:58 +0100 Subject: [Small-cl-src-discuss] Re: [Small-cl-src] defun-with-cache In-Reply-To: <0C57B69F-AC76-44A0-9DDE-73F7D8A4716A@pobox.com> References: <0C57B69F-AC76-44A0-9DDE-73F7D8A4716A@pobox.com> Message-ID: <1134194518.7986.50.camel@localhost.localdomain> 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 , at body)) > (let ((#2=#:key (list , at binding))) > (values-list > (or (gethash #2# #1#) > (setf (gethash #2# #1#) > (multiple-value-list > ,@(if apply? > `((apply #',name , at call)) > `((,name , at call))))))))))))) > > _______________________________________________ > Small-cl-src mailing list > Small-cl-src at hexapodia.net > http://www.hexapodia.net/mailman/listinfo/small-cl-src From bhyde at pobox.com Sat Dec 10 06:25:56 2005 From: bhyde at pobox.com (Ben Hyde) Date: Sat, 10 Dec 2005 01:25:56 -0500 Subject: [Small-cl-src-discuss] Re: [Small-cl-src] defun-with-cache In-Reply-To: <1134194518.7986.50.camel@localhost.localdomain> References: <0C57B69F-AC76-44A0-9DDE-73F7D8A4716A@pobox.com> <1134194518.7986.50.camel@localhost.localdomain> Message-ID: <5D92E671-D0C0-4FB4-8AE5-002361FED95E@pobox.com> On Dec 10, 2005, at 1:01 AM, Kristian Elof S?rensen wrote: > 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 right, the intent was to bail from the loop; but i need to reframe the finally > 2) *keywork-package* does not exist yeah. > 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. hm, that is difficult to fix. I may need to loose the flet. > 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 nice. thanks, ben. > 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 , at body)) >> (let ((#2=#:key (list , at binding))) >> (values-list >> (or (gethash #2# #1#) >> (setf (gethash #2# #1#) >> (multiple-value-list >> ,@(if apply? >> `((apply #',name , at call)) >> `((,name , at call))))))))))))) >> >> _______________________________________________ >> Small-cl-src mailing list >> Small-cl-src at hexapodia.net >> http://www.hexapodia.net/mailman/listinfo/small-cl-src > > > _______________________________________________ > Small-cl-src-discuss mailing list > Small-cl-src-discuss at hexapodia.net > http://www.hexapodia.net/mailman/listinfo/small-cl-src-discuss > From bhyde at pobox.com Sun Dec 11 03:19:14 2005 From: bhyde at pobox.com (Ben Hyde) Date: Sat, 10 Dec 2005 22:19:14 -0500 Subject: [Small-cl-src-discuss] defun-with-cache (take 2) In-Reply-To: <5D92E671-D0C0-4FB4-8AE5-002361FED95E@pobox.com> References: <0C57B69F-AC76-44A0-9DDE-73F7D8A4716A@pobox.com> <1134194518.7986.50.camel@localhost.localdomain> <5D92E671-D0C0-4FB4-8AE5-002361FED95E@pobox.com> Message-ID: 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 ;;; -*- 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)))))))))) From elof at image.dk Mon Dec 12 04:42:37 2005 From: elof at image.dk (Kristian Elof =?ISO-8859-1?Q?S=F8rensen?=) Date: Mon, 12 Dec 2005 05:42:37 +0100 Subject: [Small-cl-src-discuss] defun-with-cache (take 2) In-Reply-To: References: <0C57B69F-AC76-44A0-9DDE-73F7D8A4716A@pobox.com> <1134194518.7986.50.camel@localhost.localdomain> <5D92E671-D0C0-4FB4-8AE5-002361FED95E@pobox.com> Message-ID: <1134362558.7945.8.camel@localhost.localdomain> 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 From bhyde at pobox.com Tue Dec 13 14:52:39 2005 From: bhyde at pobox.com (Ben Hyde) Date: Tue, 13 Dec 2005 09:52:39 -0500 Subject: [Small-cl-src-discuss] defun-with-cache (take 3) In-Reply-To: <1134362558.7945.8.camel@localhost.localdomain> References: <0C57B69F-AC76-44A0-9DDE-73F7D8A4716A@pobox.com> <1134194518.7986.50.camel@localhost.localdomain> <5D92E671-D0C0-4FB4-8AE5-002361FED95E@pobox.com> <1134362558.7945.8.camel@localhost.localdomain> Message-ID: On Dec 11, 2005, at 11:42 PM, Kristian Elof S?rensen wrote: ... > ; It said (third-arg) here ??? ... > "call" is never referenced. Thanks! I have no idea why, but (declaim (optimize (sb-ext::inhibit-warnings 3))) was in my .sbclrc and no good can come of that. Pretty soon this will get so simple it won't be small, it will be tiny. - ben ;;; -*- Lisp -*- mode (cl:defpackage "DEFUN-WITH-CACHE" (:use "COMMON-LISP") (:export "DEFUN-WITH-CACHE" "CLEAR-CACHE-OF-FUNCTION")) (in-package "DEFUN-WITH-CACHE") (defun bindings-of-lambda-list (lambda-list) "Given a lambda list returns a list of the symbols it binds." (block nil (let ((binds nil)) (flet ((accumulate (var) (push var binds)) (wrapup () (return (nreverse binds)))) (dolist (elt lambda-list (wrapup)) (etypecase elt (cons (accumulate (first elt)) (when (third elt) (accumulate (third elt)))) (symbol (case elt ((&rest &optional &allow-other-keys &key)) (&aux (wrapup)) (otherwise (accumulate elt)))))))))) #| (loop finally (return 'ok) for (in out) in '(((x y z) (x y z)) ((x y &optional z) (x y z)) ((x &optional (y 2 z)) (x y z)) ((x &optional (y 2)) (x y)) ((x &optional (y 2) &key z) (x y z))) do (assert (equal (bindings-of-lambda-list in) out))) |# (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." (let ((binding (bindings-of-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))))))))))