Frode Vatvedt Fjeld <······@acm.org> writes:
> So in conclusion, a variant of define-modify-macro that generates
> macros that return the old value, would have been nice to have around,
> either in a library or in the next CL.
(defun d-m-m-parameters (lambda-list &aux (params '()))
(let (head (tail lambda-list))
(loop do (setf head (pop tail))
until (or (null head) (eq head '&optional) (eq head '&rest))
do (push head params))
(when (eq head '&optional)
(loop do (setf head (pop tail))
until (or (null head) (eq head '&rest))
if (consp head)
do (destructuring-bind (var &optional init (suppliedp nil spp)
head
(declare (ignore init))
(push var params)
(when spp (push suppliedp params)))
else
do (push head params)
end))
(if (eq head '&rest)
(values (nreverse params) (first tail))
(nreverse params))))
(defmacro define-modify-macro-old (name lambda-list function &optional doc-string)
(with-unique-names (reference env)
(multiple-value-bind (other-params rest-param)
(d-m-m-parameters lambda-list)
`(defmacro ,name (,reference ,@lambda-list &environment ,env)
,doc-string
(multiple-value-bind (vars vals stores store-form access-form)
(get-setf-expansion ,reference ,env)
`(let* ,(mapcar #'list vars vals)
,(if (rest stores)
`(multiple-value-prog1 ,access-form
(multiple-value-bind (,@stores)
(multiple-value-call #',',function
,access-form ,,@other-params ,@,rest-param)
,store-form))
`(prog1 ,access-form
(let ((,(first stores)
(,',function
,access-form ,,@other-params ,@,rest-param)))
,store-form)))))))))
A good CL implementation would have more sophisticated lambda-list
parsing with error checking and all, but I've written one of those
for LispWorks, and it's not as much fun the second time.
d-m-m-parameters is technically correct, anyway.
That bit with MULTIPLE-VALUE-CALL came to me as I was writing this.
It's not in the standard, but I think it would be a sensible way to
build modify macros for places with multiple store variables. (Also,
it gave me a chance to use #',',.) It works like this:
CL-USER 31> (define-modify-macro-old floorf () floor)
floorf
CL-USER 32> (pprint (macroexpand '(floorf (values a b))))
(let* ()
(multiple-value-prog1 (values a b)
(multiple-value-bind (#:new-value819
#:new-value820)
(multiple-value-call
#'floor
(values a b))
(let*
()
(values
(setq a #:new-value819)
(setq b #:new-value820))))))
CL-USER 33> (defvar *x* 13)
*x*
CL-USER 34> (defvar *y* 4)
*y*
CL-USER 35> (floorf (values *x* *y*))
13
4
CL-USER 36> (values *x* *y*)
3
1
--
Pekka P. Pirinen
"My definition of a free society is a society where it is safe
to be unpopular."
- Adlai Stevenson