[Small-cl-src-discuss] Re: [Small-cl-src] defun-with-cache

[Kristian Elof Sørensen]

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