[lisp-snmp] cdr-assoc: alist-get and ralist-get

[John F. <jf...@ms...>]

Chun Tian (binghe) <bin...@gm...> writes:
> On 2009-2-7, at 00:15, Chun Tian (binghe) wrote:
[...]
> I've fixed this bug. I used a very dirty way to implement LispWorks'
> CDR-ASSOC ...

Here is an implementation of cdr-assoc (called alist-get) and also
cdr-rassoc (called ralist-get). It allows you to do something like (setf
(cdr (assoc ...)  ...) ...) but create the key and value if key does not
already exist.

It is from http://common-lisp.net/project/cl-irregsexp/

I'm trying to get it into Alexandria . . . does it look okay?

(macrolet ((define-alist-get (name get-pair get-value-from-pair add)
	     `(progn
		(declaim (inline ,name))
		(defun ,name (alist key &key (test 'eql))
		  (let ((pair (,get-pair key alist :test test)))
		    (values (,get-value-from-pair pair) pair)))
		(define-setf-expander ,name (place key &key (test ''eql)
					     &environment env)
		  (multiple-value-bind (dummies vals newvals setter getter)
		      (get-setf-expansion place env)
		    (when (cdr newvals)
		      (error "~A cannot store multiple values in one place" ',name))
		    (with-unique-names (store key-val test-val alist found)
		      (values 
		       `(,@dummies ,key-val ,test-val)
		       `(,@vals ,key ,test)
		       (list store)
		       `(let ((,alist ,getter))
			  (let ((,found (,',get-pair ,key-val ,alist :test ,test-val)))
			    (cond (,found 
				   (setf (,',get-value-from-pair ,found) ,store))
				  (t
				   (let ,newvals
				     (setf ,(first newvals) (,',add ,key ,store ,alist))
				     ,setter)))
			    ,store))
		       `(,',name ,getter ,key))))))))
  (define-alist-get alist-get assoc cdr acons)
  (define-alist-get ralist-get rassoc car racons))

[...]