"Debugging tool: print the expression X and its values."
(let ((tmp (gensym)))
`(let ((,tmp (multiple-value-list ,x)))
- (format t "~&")
+ (fresh-line)
(pprint-logical-block (*standard-output* nil :per-line-prefix ";; ")
(format t
"~S = ~@_~:I~:[#<no values>~;~:*~{~S~^ ~_~}~]"
(defmacro with-gensyms (syms &body body)
"Everyone's favourite macro helper."
`(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))
- (listify syms)))
+ (listify syms)))
,@body))
(defmacro let*/gensyms (binds &body body)
each VAR is bound to a gensym, and in the final expansion, each of those
gensyms will be bound to the corresponding VALUE."
(labels ((more (binds)
- (let ((tmp (gensym "TMP")) (bind (car binds)))
- `((let ((,tmp ,(cadr bind))
- (,(car bind) (gensym ,(symbol-name (car bind)))))
- `(let ((,,(car bind) ,,tmp))
- ,,@(if (cdr binds)
- (more (cdr binds))
- body)))))))
+ (let ((tmp (gensym "TMP")) (bind (car binds)))
+ `((let ((,tmp ,(cadr bind))
+ (,(car bind) (gensym ,(symbol-name (car bind)))))
+ `(let ((,,(car bind) ,,tmp))
+ ,,@(if (cdr binds)
+ (more (cdr binds))
+ body)))))))
(if (null binds)
- `(progn ,@body)
- (car (more (mapcar #'pairify (listify binds)))))))
+ `(progn ,@body)
+ (car (more (mapcar #'pairify (listify binds)))))))
;;;--------------------------------------------------------------------------
;;; Some simple yet useful control structures.
collect val into vals
finally (return (values vars vals)))
`(labels ((,name ,vars
- ,@body))
+ ,@body))
(,name ,@vals))))
(defmacro while (cond &body body)
(list `(let ((,(or vary varx) ,argument)
,@(and vary
`((,varx ,scrutinee))))
- ,@forms))
+ ,@forms))
forms))))
clauses)))))
(doit specs)))
;;;--------------------------------------------------------------------------
-;;; with-places
+;;; Capturing places as symbols.
(defmacro %place-ref (getform setform newtmp)
"Grim helper macro for with-places."
"Grim helper macro for with-places."
(values nil nil newtmp setform getform))
-(defmacro with-places ((&key environment) places &body body)
- "A hairy helper, for writing setf-like macros. PLACES is a list of binding
- pairs (VAR PLACE), where PLACE defaults to VAR. The result is that BODY
- is evaluated in a context where each VAR is bound to a gensym, and in the
- final expansion, each of those gensyms will be bound to a symbol-macro
- capable of reading or setting the value of the corresponding PLACE."
- (if (null places)
- `(progn ,@body)
- (let*/gensyms (environment)
- (labels
- ((more (places)
- (let ((place (car places)))
- (with-gensyms (tmp valtmps valforms
- newtmps setform getform)
- `((let ((,tmp ,(cadr place))
- (,(car place)
- (gensym ,(symbol-name (car place)))))
- (multiple-value-bind
- (,valtmps ,valforms
- ,newtmps ,setform ,getform)
- (get-setf-expansion ,tmp
- ,environment)
- (list 'let*
- (mapcar #'list ,valtmps ,valforms)
- `(symbol-macrolet ((,,(car place)
- (%place-ref ,,getform
- ,,setform
- ,,newtmps)))
- ,,@(if (cdr places)
- (more (cdr places))
- body))))))))))
- (car (more (mapcar #'pairify (listify 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))))
+
+(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))))
;;;--------------------------------------------------------------------------
;;; Update-in-place macros built using with-places.
-(defmacro update-place (op place arg &environment env)
- "Update PLACE with the value of OP PLACE ARG, returning the new value."
- (with-places (:environment env) (place)
- `(setf ,place (,op ,place ,arg))))
+(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))))
-(defmacro update-place-after (op place arg &environment env)
- "Update PLACE with the value of OP PLACE ARG, returning the old value."
- (with-places (:environment env) (place)
+(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 ,arg))
+ (setf ,place (,op ,x ,@args))
,x))))
(defmacro incf-after (place &optional (by 1))
(get-setf-expansion place env)
`(let* (,@(mapcar #'list valtmps valforms))
(make-loc (lambda () ,getform)
- (lambda (,@newtmps) ,setform)))))
+ (lambda (,@newtmps) ,setform)))))
(declaim (inline loc (setf loc)))