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

[Ben Hyde]

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
>