+(export 'with-places)
+(defmacro with-places (clauses &body body &environment env)
+ "Define symbols which refer to `setf'-able places.
+
+ The syntax is similar to `let'. The CLAUSES are a list of (NAME PLACE)
+ pairs. Each NAME is defined as a symbol-macro referring to the
+ corresponding PLACE: a mention of the NAME within the BODY forms extracts
+ the current value(s) of the PLACE, while a `setf' (or `setq', because
+ symbol macros are strange like that) of a NAME updates the value(s) in the
+ PLACE. The returned values are those of the BODY, evaluated as an
+ implicit `progn'."
+
+ (let ((temp-binds nil)
+ (macro-binds nil))
+ (dolist (clause clauses)
+ (destructuring-bind (name place) clause
+ (multiple-value-bind (valtmps valforms newtmps setform getform)
+ (get-setf-expansion place env)
+ (setf temp-binds
+ (nconc (nreverse (mapcar #'list valtmps valforms))
+ temp-binds))
+ (push `(,name (%place-ref ,getform ,setform ,newtmps))
+ macro-binds))))
+ `(let (,@(nreverse temp-binds))
+ (symbol-macrolet (,@(nreverse macro-binds))
+ ,@body))))
+
+(export 'with-places/gensyms)
+(defmacro with-places/gensyms (clauses &body body)
+ "A kind of a cross between `with-places' and `let*/gensyms'.
+
+ This is a hairy helper for writing `setf'-like macros. The CLAUSES are a
+ list of (NAME [PLACE]) pairs, where the PLACE defaults to NAME, and a
+ bare NAME may be written in place of the singleton list (NAME). The
+ PLACEs are evaluated.
+
+ The BODY forms are evaluated as an implicit `progn', with each NAME bound
+ to a gensym, to produce a Lisp form, called the `kernel'. The result of
+ the `with-places/gensyms' macro is then itself a Lisp form, called the
+ `result'.
+
+ The effect of evaluating the `result' form is to evaluate the `kernel'
+ form with each of the gensyms stands for the value(s) stored in the
+ corresponding PLACE; a `setf' (or `setq') of one of the gensyms updates
+ the value(s) in the corresponding PLACE. The values returned by the
+ `result' form are the values returned by the `kernel'."
+
+ (let* ((clauses (mapcar #'pairify clauses))
+ (names (mapcar #'car clauses))
+ (places (mapcar #'cadr clauses))
+ (gensyms (mapcar (lambda (name) (gensym (symbol-name name)))
+ names)))
+ ``(with-places (,,@(mapcar (lambda (gensym place)
+ ``(,',gensym ,,place))
+ gensyms places))
+ ,(let (,@(mapcar (lambda (name gensym)
+ `(,name ',gensym))
+ names gensyms))
+ ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Some simple yet useful control structures.
+
+(export 'nlet)
+(defmacro nlet (name binds &body body)
+ "Scheme's named let."
+ (multiple-value-bind (vars vals)
+ (loop for bind in binds
+ for (var val) = (pairify bind nil)
+ collect var into vars
+ collect val into vals
+ finally (return (values vars vals)))
+ `(labels ((,name ,vars
+ ,@body))
+ (,name ,@vals))))
+
+(export 'while)
+(defmacro while (cond &body body)
+ "If COND is false, evaluate to nil; otherwise evaluate BODY and try again."
+ `(loop (unless ,cond (return)) (progn ,@body)))
+
+(export 'until)
+(defmacro until (cond &body body)
+ "If COND is true, evaluate to nil; otherwise evaluate BODY and try again."
+ `(loop (when ,cond (return)) (progn ,@body)))
+
+(compile-time-defun do-case2-like (kind vform clauses)
+ "Helper function for `case2' and `ecase2'."
+ (with-gensyms (scrutinee argument)
+ `(multiple-value-bind (,scrutinee ,argument) ,vform
+ (declare (ignorable ,argument))
+ (,kind ,scrutinee
+ ,@(mapcar (lambda (clause)
+ (destructuring-bind
+ (cases (&optional varx vary) &rest forms)
+ clause
+ `(,cases
+ ,@(if varx
+ (list `(let ((,(or vary varx) ,argument)
+ ,@(and vary
+ `((,varx ,scrutinee))))
+ ,@forms))
+ forms))))
+ clauses)))))
+
+(export 'case2)
+(defmacro case2 (vform &body clauses)
+ "VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT.
+ The CLAUSES have the form (CASES ([[SCRUVAR] ARGVAR]) FORMS...), where a
+ standard `case' clause has the form (CASES FORMS...). The `case2' form
+ evaluates the VFORM, and compares the SCRUTINEE to the various CASES, in
+ order, just like `case'. If there is a match, then the corresponding
+ FORMs are evaluated with ARGVAR bound to the ARGUMENT and SCRUVAR bound to
+ the SCRUTINEE (where specified). Note the bizarre defaulting behaviour:
+ ARGVAR is less optional than SCRUVAR."
+ (do-case2-like 'case vform clauses))
+
+(export 'ecase2)
+(defmacro ecase2 (vform &body clauses)
+ "Like `case2', but signals an error if no clause matches the SCRUTINEE."
+ (do-case2-like 'ecase vform clauses))
+
+(export 'setf-default)
+(defmacro setf-default (&rest specs)
+ "Like setf, but only sets places which are currently nil.
+
+ The arguments are an alternating list of PLACEs and DEFAULTs. If a PLACE
+ is nil, the DEFAULT is evaluated and stored in the PLACE; otherwise the
+ default is /not/ stored. The result is the (new) value of the last
+ PLACE."
+ `(progn ,@(do ((list nil)
+ (specs specs (cddr specs)))
+ ((endp specs) (nreverse list))
+ (unless (cdr specs)
+ (error "Odd number of arguments for `setf-default'."))
+ (push (with-places/gensyms ((place (car specs)))
+ `(or ,place (setf ,place ,(cadr specs))))
+ list))))
+
+;;;--------------------------------------------------------------------------
+;;; Update-in-place macros built using with-places.
+
+(export 'update-place)
+(defmacro update-place (op place &rest args)
+ "Update PLACE with (OP PLACE . ARGS), returning the new value."
+ (with-places/gensyms (place)
+ `(setf ,place (,op ,place ,@args))))
+
+(export 'update-place-after)
+(defmacro update-place-after (op place &rest args)
+ "Update PLACE with (OP PLACE . ARGS), returning the old value."
+ (with-places/gensyms (place)
+ (with-gensyms (x)
+ `(let ((,x ,place))
+ (setf ,place (,op ,x ,@args))
+ ,x))))
+
+(export 'incf-after)
+(defmacro incf-after (place &optional (by 1))
+ "Increment PLACE by BY, returning the old value."
+ `(update-place-after + ,place ,by))
+
+(export 'decf-after)
+(defmacro decf-after (place &optional (by 1))
+ "Decrement PLACE by BY, returning the old value."
+ `(update-place-after - ,place ,by))
+
+;;;--------------------------------------------------------------------------
+;;; Locatives.
+
+(export 'locp)