patternMinor
Using get-setf-expansion
Viewed 0 times
setfgetexpansionusing
Problem
In a previous post at Simplifying complex setf expressions, @sds suggested using the
The macro is intended to perform (and return) an in-place modification based on an arbitrary common-lisp function. A simple example would be
```
(defmacro ! (fn &rest args)
"Modifies an object at a place according to a given function.
Obviates the need for some specialized macros--eg, (incf x) == (! 1+ @x);
and generalizes place modification for standard common-lisp functions."
(let* ((sym (find-if #'(lambda (arg) ;find the place argument signaled by @
(and (symbolp arg) (string= (aref (symbol-name arg) 0) "@")))
args))
(fn-args (cond ((eq sym '@) ;sym indicates a generalized reference
(remove '@ args))
((> (length (symbol-name sym)) 1) ;sym i
get-setf-expansion macro for implementing place modification, as discussed in On Lisp (p171ff) by Paul Graham . In a related post at Destructive place-modifying operators, @acelent provides additional guidance. Based on their advice, I've written a place modifying macro (below), and would appreciate any comments, improvements, corrections, or error checking procedures. It has passed the preliminary tests I have performed. However, my experience with macros, is limited, and I know their workings can be subtle.The macro is intended to perform (and return) an in-place modification based on an arbitrary common-lisp function. A simple example would be
(! 1+ @x) == (incf x). The ! signifies modification, and @ indicates the place being modified (and returned). A more complex example is (! delete 3 @(car x) :test #'equal) == (setf (car x) (delete 3 (car x) :test #'equal)). I've had to include the @ marker for the place, since I can't think of another way to pass the place on to (get-setf-expansion place). (Is there any way to analyze the features of the input function in order to zero in on the appropriate place argument?) Otherwise, Paul Graham's macro template (he calls it _f) seems to work, if you substitute get-setf-expansion for his get-setf-method.```
(defmacro ! (fn &rest args)
"Modifies an object at a place according to a given function.
Obviates the need for some specialized macros--eg, (incf x) == (! 1+ @x);
and generalizes place modification for standard common-lisp functions."
(let* ((sym (find-if #'(lambda (arg) ;find the place argument signaled by @
(and (symbolp arg) (string= (aref (symbol-name arg) 0) "@")))
args))
(fn-args (cond ((eq sym '@) ;sym indicates a generalized reference
(remove '@ args))
((> (length (symbol-name sym)) 1) ;sym i
Solution
First things first, you should know about the order of evaluation in modifying forms:
(operator preceding-form place following-form)
The evaluation of each such form proceeds like this:
-
Evaluate each of the preceding-forms, in left-to-right order.
-
Evaluate the subforms of the place, in the order specified by the second value of the setf expansion for that place.
-
Evaluate each of the following-forms, in left-to-right order.
-
Read the old value from place.
-
Compute the new value.
-
Store the new value into place.
I'll take your idea with these changes:
-
Instead of
-
Instead of
vars vals)
;; In case there are more vars than vals
,@(nthcdr (length vals) vars))
;; In case there a
(operator preceding-form place following-form)
The evaluation of each such form proceeds like this:
-
Evaluate each of the preceding-forms, in left-to-right order.
-
Evaluate the subforms of the place, in the order specified by the second value of the setf expansion for that place.
-
Evaluate each of the following-forms, in left-to-right order.
-
Read the old value from place.
-
Compute the new value.
-
Store the new value into place.
I'll take your idea with these changes:
-
Instead of
!, I'll call it updatef-
Instead of
@, I'll use an identifying form, (:place ), where ` is the actual place
-
Instead of splashing the form (e.g. (updatef delete 2 (:place x))), I'll make it a single destructuring argument of the macro (e.g. (updatef (delete 2 (:place x))))
I'm aware that this syntax is more verbose, but due to the specific nature of updatef's behavior, I think it shouldn't be used just about anywhere.
(defmacro updatef ((&whole form function &rest args) &environment env)
(flet ((is-place-form (arg)
(and (consp arg)
(eq (card arg) :place)
(consp (cdr arg)))))
(let ((place-rest (member-if #'is-place-form args)))
(assert (not (null place-rest)) ()
"No place form in updatef.")
(assert (null (member-if #'is-place-form (rest place-rest))) ()
"More than one place form in updatef.")
(let* ((preceding-forms (ldiff args place-rest))
(place (second (first place-rest)))
(following-forms (rest place-rest))
(preceding-vars (loop for preceding-form in preceding-forms collect (gensym "preceding-var")))
(following-vars (loop for following-form in following-forms collect (gensym "following-var"))))
(multiple-value-bind (vars vals store-vars writer-form reader-form)
(get-setf-expansion place env)
(assert (= (length vars) (length vals)) ()
"Place expansion has different amount of variables than initializing forms in updatef.")
`(let* (,@(mapcar #'(lambda (var form)
`(,var ,form))
(append preceding-vars vars following-vars)
(append preceding-forms vals following-forms)))
(multiple-value-bind (,@store-vars)
(,function ,@preceding-vars ,reader-form ,@following-vars)
,writer-form)))))))
One of the good things that this macro does is to evaluate the subforms only once. However, it doesn't help with certain kinds of places where it would be useful to operate atomically, such as setf of gethash or implementation specific atomic operations on places.
Here's a more permissive version that allows certain errors from setf expansions, namely: more or less vars than vals and a writer-form that doesn't return the new value(s).
Also, I made it so it does nothing special (regarding setf behavior) in case no form is (:place ), and to use the first such form in case there are more than one.
`
(defmacro updatef ((&whole form function &rest args) &environment env)
(flet ((is-place-form (arg)
(and (consp arg)
(eq (card arg) :place)
(consp (cdr arg)))))
(let ((place-rest (member-if #'is-place-form args)))
(cond ((null place-rest)
(warn "No place form in updatef, no update generated.")
form)
(t
(when (not (null (member-if #'is-place-form (rest place-rest))))
(warn "More than one place form in updatef, first place will be used."))
(let* ((preceding-forms (ldiff args place-rest))
(place (second (first place-rest)))
(following-forms (rest place-rest))
(preceding-vars (loop for preceding-form in preceding-forms collect (gensym "preceding-var")))
(following-vars (loop for following-form in following-forms collect (gensym "following-var"))))
(multiple-value-bind (vars vals store-vars writer-form reader-form)
(get-setf-expansion place env)
(when (not (= (length vars) (length vals)))
(warn "Place expansion has different amount of variables than initializing forms in updatef."))
(,var ,form))
preceding-vars preceding-forms)
,@(mapcar #'(lambda (var form)
(,var ,form))vars vals)
;; In case there are more vars than vals
,@(nthcdr (length vals) vars))
;; In case there a
Code Snippets
(defmacro updatef ((&whole form function &rest args) &environment env)
(flet ((is-place-form (arg)
(and (consp arg)
(eq (card arg) :place)
(consp (cdr arg)))))
(let ((place-rest (member-if #'is-place-form args)))
(assert (not (null place-rest)) ()
"No place form in updatef.")
(assert (null (member-if #'is-place-form (rest place-rest))) ()
"More than one place form in updatef.")
(let* ((preceding-forms (ldiff args place-rest))
(place (second (first place-rest)))
(following-forms (rest place-rest))
(preceding-vars (loop for preceding-form in preceding-forms collect (gensym "preceding-var")))
(following-vars (loop for following-form in following-forms collect (gensym "following-var"))))
(multiple-value-bind (vars vals store-vars writer-form reader-form)
(get-setf-expansion place env)
(assert (= (length vars) (length vals)) ()
"Place expansion has different amount of variables than initializing forms in updatef.")
`(let* (,@(mapcar #'(lambda (var form)
`(,var ,form))
(append preceding-vars vars following-vars)
(append preceding-forms vals following-forms)))
(multiple-value-bind (,@store-vars)
(,function ,@preceding-vars ,reader-form ,@following-vars)
,writer-form)))))))(defmacro updatef ((&whole form function &rest args) &environment env)
(flet ((is-place-form (arg)
(and (consp arg)
(eq (card arg) :place)
(consp (cdr arg)))))
(let ((place-rest (member-if #'is-place-form args)))
(cond ((null place-rest)
(warn "No place form in updatef, no update generated.")
form)
(t
(when (not (null (member-if #'is-place-form (rest place-rest))))
(warn "More than one place form in updatef, first place will be used."))
(let* ((preceding-forms (ldiff args place-rest))
(place (second (first place-rest)))
(following-forms (rest place-rest))
(preceding-vars (loop for preceding-form in preceding-forms collect (gensym "preceding-var")))
(following-vars (loop for following-form in following-forms collect (gensym "following-var"))))
(multiple-value-bind (vars vals store-vars writer-form reader-form)
(get-setf-expansion place env)
(when (not (= (length vars) (length vals)))
(warn "Place expansion has different amount of variables than initializing forms in updatef."))
`(let* (,@(mapcar #'(lambda (var form)
`(,var ,form))
preceding-vars preceding-forms)
,@(mapcar #'(lambda (var form)
`(,var ,form))
vars vals)
;; In case there are more vars than vals
,@(nthcdr (length vals) vars))
;; In case there are more vals than vars
,@(nthcdr (length vars) vals)
(let* (,@(mapcar #'(lambda (var form)
`(,var ,form))
following-vars following-forms))
(multiple-value-bind (,@store-vars)
(,function ,@preceding-vars ,reader-form ,@following-vars)
,writer-form
;; In case writer-form doesn't return the new value(s)
(values ,@store-vars)))))))))))Context
StackExchange Code Review Q#155545, answer score: 3
Revisions (0)
No revisions yet.