Defaulting places in Common Lisp
Or: less boilerplate.
Common Lisp (CL) has a general notion of a place, which is a form which has a value or values and into which a value or values can be stored. Variables are places, but so are forms like (car c): (setf (car c) 2) will store 2 into the car of the cons bound to c. Places can even store multiple values:
(let ((a 1) (b 3))
(setf (values a b) (values 3 4))
(values a b))for instance. Here the place is (values a b) which is a place composed of two other places.
This is a really useful notion, not only because places mean the language no longer needs all sorts of special-purpose mutation functions — rplaca still exists for compatibility but there is no sethash or aset — but because you can implement your own places which behave just like the ones the language provides.
Here’s an example of a place called a ‘wrapped alist’: it’s just a cons whose cdr is an alist. It’s done like this so storing works in general (think about empty alists).
(defun make-wrapped-alist (&optional (for-alist '()))
(cons nil for-alist))
(defun wrapped-alist-alist (wa)
(cdr wa))
(defun wav (item wrapped-alist &key (test nil testp) (default nil))
(let ((found (if testp
(assoc item (cdr wrapped-alist) :test test)
(assoc item (cdr wrapped-alist)))))
(if found
(values (cdr found) t)
(values default nil))))
(defun (setf wav) (new item wrapped-alist &key (test nil testp) default)
(declare (ignore default))
(let ((found (if testp
(assoc item (cdr wrapped-alist) :test test)
(assoc item (cdr wrapped-alist)))))
(if found
(setf (cdr found) new)
(progn
(push (cons item new) (cdr wrapped-alist))
new))))I will use these wrapped alist places in the examples below.
Defaulting places
Quite often, a place has a default value or a way of indicating that there is no value in it, and you want to be able to say ‘if this place has not been stored into, then store this into it’. In the case of hash tables, the indicator is that gethash returns a second value of nil, and that is the same for av and my wrapped alists.
Sometimes this is not a problem, especially when the accessor for a place lets you provide a default:
(defun symbol-counts (l)
(let ((table (make-hash-table)))
(dolist (e l)
(when (symbolp e)
(incf (gethash e table 0))))
(collecting
(maphash (lambda (k v)
(collect (cons k v)))
table))))Or
(defun symbol-counts/probably-slower (l)
(let ((wa (make-wrapped-alist)))
(dolist (e l)
(when (symbolp e)
(incf (av e wa :default 0))))
(wrapped-alist-alist wa)))But sometimes it is a problem. Consider the case where the fallback thing you want to store is expensive, or has side-effects. Now you need to write some boilerplate code:
(unless (nth-value 1 (wav item wa)
(setf (wav item wa) (compute-complicated-thing))))The wrong way
Well, boilerplate is bad. So you might want to replace this by a macro:
(defmacro defaulting/wrong (place-form value-form)
;; This just assumes that PLACE-FORM returns NIL if it has no value:
;; in real life you need to be cleverer.
`(or ,place-form
(setf ,place-form ,value-form)))This is not only limited, but incorrect. It’s incorrect because it multiply evaluates subforms to place-form. Consider this:
(let ((i 0) (table (make-hash-table)))
(defaulting/wrong (gethash (incf i) table) 3))Well, using wrapped alists it’s easy to see what this is doing wrong:
> (let ((i 0) (wa (make-wrapped-alist)))
(defaulting/wrong (wav (incf i) wa) 3)
(wrapped-alist-alist wa))
((2 . 3))So, not great. The boilerplate you’d need to write is:
> (let ((i 0) (wa (make-wrapped-alist)))
(let ((k (incf i)))
(unless (wav k wa)
(setf (wav k wa) 3)))
(wrapped-alist-alist wa))
((1 . 3))The right way
The problem is that any such defaulting macro doesn’t know anything about the place it’s defaulting. So it can’t know which subforms of the place it needs to stash values for.
Well, it turns out that the designers of CL thought of this, and they provided the tool you need, which is get-setf-expansion. Given a place and optionally an environment, this will tell you exactly what you need to know to both read from that place and write to it, and to do so multiple times if need be.
get-setf-expansion is what you need to be able to write your own setf:
(defmacro assign (&rest pairs &environment e)
;; This should be SETF give or take
`(progn
,@(collecting
(for ((tail (on-list pairs :by #'cddr)))
(destructuring-bind (place-form value-form . _) tail
(declare (ignore _))
(multiple-value-bind (vars vals store-vars writer-form reader-form)
(get-setf-expansion place-form e)
(declare (ignore reader-form))
(collect
`(let* ,(mapcar #'list vars vals)
(multiple-value-bind ,store-vars ,value-form
,writer-form)))))))))But you can also use it to write defaulting properly. Here is a much fancier version of it, which is now correct (I hope):
(defmacro defaulting (place value-form
&body options
&key test default-value nth-value &environment e)
(declare (ignore options)) ;just for indent
(multiple-value-bind (tvars tforms store-variables storing-form accessing-form)
(get-setf-expansion place e)
`(let* ,(mapcar #'list tvars tforms)
(when ,(cond
((and test nth-value)
`(not (funcall ,test ,default-value (nth-value ,nth-value ,accessing-form))))
(test
`(not (multiple-value-call ,test ,default-value ,accessing-form)))
((and default-value nth-value)
`(eql ,default-value (nth-value ,nth-value ,accessing-form)))
(default-value
`(eql ,default-value ,accessing-form))
(nth-value
`(not (nth-value ,nth-value ,accessing-form)))
(t
`(not ,accessing-form)))
(multiple-value-bind ,store-variables ,value-form
,storing-form))
,accessing-form)))So now:
> (let ((i 0) (wa (make-wrapped-alist)))
(defaulting (wav (incf i) wa) 3)
(wrapped-alist-alist wa))Or, using options to this defaulting to tell it the value to be checked:
> (let ((i 0) (wa (make-wrapped-alist)))
(defaulting (wav (incf i) wa) 3 :nth-value 1)
(wrapped-alist-alist wa))
((1 . 3))Finally, you can see the expansion using trace-macroexpand:
> (let ((a (make-wrapped-alist)))
(defaulting (wav 'k a) 3 :nth-value 1))
(defaulting (wav 'k a)
3
:nth-value 1)
-> (let* ((#:a1 a))
(when (not (nth-value 1 (wav 'k #:a1)))
(multiple-value-bind (#:new0) 3 (funcall #'(setf wav) #:new0 'k #:a1)))
(wav 'k #:a1))
3
tand this is obviously correct.
This macro exists in org.tfeb.hax.utilities, the git repo for which is tfeb.org/computer/repos/tfeb-lisp-hax.git. Note it is not in the archived GitHub repo.
This is version 10.7.0 of the TFEB.ORG Lisp hax.