(car (more (mapcar #'pairify (listify binds)))))))
;;;--------------------------------------------------------------------------
+;;; Capturing places as symbols.
+
+(defmacro %place-ref (getform setform newtmp)
+ "Grim helper macro for with-places."
+ (declare (ignore setform newtmp))
+ getform)
+
+(define-setf-expander %place-ref (getform setform newtmp)
+ "Grim helper macro for with-places."
+ (values nil nil newtmp setform getform))
+
+(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)
(doit specs)))
;;;--------------------------------------------------------------------------
-;;; Capturing places as symbols.
-
-(defmacro %place-ref (getform setform newtmp)
- "Grim helper macro for with-places."
- (declare (ignore setform newtmp))
- getform)
-
-(define-setf-expander %place-ref (getform setform newtmp)
- "Grim helper macro for with-places."
- (values nil nil newtmp setform getform))
-
-(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))))
-
-;;;--------------------------------------------------------------------------
;;; Update-in-place macros built using with-places.
(export 'update-place)
~mdw / lisp / commitdiff