"Debugging tool: print the expression X and its values."
(let ((tmp (gensym)))
`(let ((,tmp (multiple-value-list ,x)))
"Debugging tool: print the expression X and its values."
(let ((tmp (gensym)))
`(let ((,tmp (multiple-value-list ,x)))
(pprint-logical-block (*standard-output* nil :per-line-prefix ";; ")
(format t
"~S = ~@_~:I~:[#<no values>~;~:*~{~S~^ ~_~}~]"
(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))))
(defmacro with-gensyms (syms &body body)
"Everyone's favourite macro helper."
`(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))
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)
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)))))))
;;;--------------------------------------------------------------------------
;;; Some simple yet useful control structures.
;;;--------------------------------------------------------------------------
;;; Some simple yet useful control structures.
- (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))))))))
+ (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))))))))
;;;--------------------------------------------------------------------------
;;; Update-in-place macros built using with-places.
;;;--------------------------------------------------------------------------
;;; Update-in-place macros built using with-places.
(get-setf-expansion place env)
`(let* (,@(mapcar #'list valtmps valforms))
(make-loc (lambda () ,getform)
(get-setf-expansion place env)
`(let* (,@(mapcar #'list valtmps valforms))
(make-loc (lambda () ,getform)