[PATCH] Fix broken defsetf for places with keywords.
Kaz Kylheku <[email protected]> Fri, 01 Mar 2019 16:45:18 -0800
| Newsgroups | gmane.lisp.clisp.general |
|---|---|
| Message-ID | <[email protected]> |
Hi all,
I've investigated and hopefully fixed the failure to handle a sample
defsetf form, straight out of ANSI CL:
[1]> (defsetf xy (&key ((x x) 0) ((y y) 0)) (store)
`(set-xy ,store 'x ,x 'y ,y))
XY
Thus, the keys for this xy place are the symbols X and Y, rather than :X
and :Y, right?
But, oops:
[2]> (macroexpand '(inc (xy 'x 0 'y 0)))
(INC (XY 'X 0 'Y 0)) ;
NIL
[3]> (macroexpand '(incf (xy 'x 0 'y 0)))
*** - The argument 'X to XY should be a keyword.
The following restarts are available:
ABORT :R1 Abort main loop
Break 1 [4]>
What? Okay, let's use a keyword:
[5]> (macroexpand '(incf (xy :x 0 'y 0)))
*** - The argument 'Y to XY should be a keyword.
The following restarts are available:
ABORT :R1 Abort main loop
Break 1 [6]>
Right, Y is the same. So the following workaround should take care of
it:
[7]> (macroexpand '(incf (xy :x 0 :y 0)))
*** - SETF-XY: illegal keyword/value pair :X, #:G3090 in argument
list.
The allowed keywords are (X Y)
The following restarts are available:
ABORT :R1 Abort main loop
Break 1 [8]>
Patch, please review
----8<-----8<-----8<-----8<-----8<-----8<-----8<-----8<-----
Fix broken defsetf for places with keywords.
The get-setf-expansion code assumes that keywords arguments produced by
defsetf
for places are always named by Lisp keywords. When the following
definition
straight from ANSI CL is evaluated, the place does not expand.
(defun set-xy (new-value &key ((x x) 0) ((y y) 0))
(setf (aref *xy* x y) new-value))
Note the code is not prepared to deal with situations when the keywords
are
given by evaluated expressions. I am not fixing that aspect of it, and
it's probably a bad idea; a virtue of the defsetf logic over keyword
arguments is that it understands keyword arguments. It doesn't have to
wastefully generate temporary variables in order to capture values which
produce the keyword argument indicator symbols. In other words, this
does not work: (incf (fun key val)) where key is a variable that must
be evaluated at run-time to produce the identity of the key.
* src/places.lisp (get-setf-expansion): In the keyword processing loop,
we
produce two new-access-form lists: one which contains the original
unevaluated keyword argument syntax like 'a 3 :b 4, and one which
contains evaluated keywords like a 3 :b 4. The evaluated one is needed
for generating the store form, because it's actually apply-ed to
a function! The unevaluated one is needed for generating the access form
(the last of the get-setf-expansion values).
* src/po/en.po: New English message introduced for the situation that
the user tries something like (incf (fun key val)), where key is an
expression
that must be evaluated at run-time to produce the keyword.
* tests/setf.tst: Some new test cases for macro-expanding a defsetf
with keywords.
diff -r bfc8b52d8b52 src/places.lisp
--- a/src/places.lisp Mon Apr 23 18:04:32 2018 +0200
+++ b/src/places.lisp Fri Mar 01 07:06:36 2019 -0800
@@ -62,7 +62,8 @@
(let ((access-form form)
(tempvars '())
(tempforms '())
- (new-access-form '()))
+ (new-access-form '())
+ (ev-new-access-form '()))
(let ((i 0)) ; argument counter
;; argcount = -1 if no keyword arguments exist
;; resp. = number of the arguments before
&KEY,
@@ -70,26 +71,45 @@
(dolist (argform (cdr access-form))
(when (eql i argcount) (setq argcount nil i
0))
(if (and (null argcount) (evenp i))
- (if (keywordp argform)
- (push argform new-access-form)
+ ;; Limitation: the place syntax which
specifies a
+ ;; keyword must be a constant expression
like 'foo.
+ ;; We evaluate that to get the symbol that
it denotes.
+ (if (constantp argform)
+ (let ((ev-argform (eval argform)))
+ (if (and (symbolp ev-argform)
+ (or
+ (keywordp ev-argform)
+ (not (constantp
ev-argform))))
+ (progn
+ (push argform new-access-form)
+ (push ev-argform
ev-new-access-form))
+ (error-of-type 'source-program-error
+ :form form
+ :detail argform
+ (if (symbolp argform)
+ (TEXT "~S: ~S is a constant, may
not be used as a variable")
+ (TEXT "~S: variable ~S should be
a symbol"))
+ (car access-form) argform)))
(error-of-type 'source-program-error
:form form
:detail argform
- (TEXT "The argument ~S to ~S should be
a keyword.")
+ (TEXT "The argument ~S to ~S, which
specifies a keyword argument, must be a constant expression.")
argform (car access-form)))
(let ((tempvar (gensym)))
(push tempvar tempvars)
(push argform tempforms)
- (push tempvar new-access-form)))
+ (push tempvar new-access-form)
+ (push tempvar ev-new-access-form)))
(incf i)))
- (setq new-access-form (nreverse new-access-form))
+ (setq new-access-form (nreverse new-access-form)
+ ev-new-access-form (nreverse
ev-new-access-form))
(let ((newval-vars (gensym-list (cadr
plist-info))))
(values
(nreverse tempvars)
(nreverse tempforms)
newval-vars
(apply (cddr plist-info) env
- (append newval-vars new-access-form))
+ (append newval-vars
ev-new-access-form))
(cons (car access-form)
new-access-form))))))))))))
;; 2nd step: macroexpand
(when (eq form (setq form (macroexpand-1 form env)))
diff -r bfc8b52d8b52 src/po/en.po
--- a/src/po/en.po Mon Apr 23 18:04:32 2018 +0200
+++ b/src/po/en.po Fri Mar 01 07:06:36 2019 -0800
@@ -4162,6 +4162,11 @@
msgid "The argument ~S to ~S should be a keyword."
msgstr "The argument ~S to ~S should be a keyword."
+#: places.lisp:100
+#, lisp-format
+msgid "The argument ~S to ~S, which specifies a keyword argument, must
be a constant expression."
+msgstr "The argument ~S to ~S, which specifies a keyword argument, must
be a constant expression."
+
#: places.lisp:126
#, lisp-format
msgid "~S: Argument ~S is not a SETF place."
diff -r bfc8b52d8b52 tests/setf.tst
--- a/tests/setf.tst Mon Apr 23 18:04:32 2018 +0200
+++ b/tests/setf.tst Fri Mar 01 07:06:36 2019 -0800
@@ -701,6 +701,27 @@
(compile 'foo) FOO
(documentation 'foo 'function) "docstring"
+(defsetf xy (&key ((x x) 0) ((y y) 0)) (store)
+ `(set-xy ,store 'x ,x 'y ,y))
+XY
+
+(macroexpand '(incf (xy)))
+(SET-XY (+ (XY) 1) 'X 0 'Y 0)
+
+(let ((*gensym-counter* 0))
+ (prin1-to-string
+ (macroexpand '(incf (xy 'x 0 'y 0)))))
+"(LET* ((#1=#:G0 0) (#2=#:G1 0)) (SET-XY (+ (XY 'X #1# 'Y #2#) 1) 'X
#1# 'Y #2#))"
+
+(defsetf xy2 (&key (x 0) (y 0)) (store)
+ `(set-xy2 ,store 'x ,x 'y ,y)) ;; wrong keys deliberate
+XY2
+
+(let ((*gensym-counter* 0))
+ (prin1-to-string
+ (macroexpand '(incf (xy2 :x 42 :y 43)))))
+"(LET* ((#1=#:G0 42) (#2=#:G1 43)) (SET-XY2 (+ (XY2 :X #1# :Y #2#) 1)
'X #1# 'Y #2#))"
+
;; Clean up.
-(symbols-cleanup '(x func01 func03 foo))
+(symbols-cleanup '(x func01 func03 foo xy xy2))
()
_______________________________________________
clisp-list mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/clisp-list