get-setf-expansion
Affects | Status | Importance | Assigned to | Milestone | |
---|---|---|---|---|---|
SBCL |
Invalid
|
Undecided
|
Unassigned |
Bug Description
I think that in get-setf-expansion <SYS:SRC;
here is the code:
(defun get-setf-expansion (form &optional environment)
"Return five values needed by the SETF machinery: a list of temporary
variables, a list of values with which to fill them, a list of temporaries
for the new values, the setting function, and the accessing function."
(named-let retry ((form form))
(labels ((newvals (count)
(let ((*gensym-counter* 1))
This is the example of the problem. It might be me.
(defmacro bad-letf (forms &body body &environment env)
(flet ((make-vars (count)
(loop repeat count collect (gensym)))
(if (and (symbolp y) (symbolp x)) (string= x y) (eql x y)))
(mapcar #'(lambda (form)
(if (null (cddr form))
(let ((getters ()) (getvars ())
(setters ()) (storevars ())
(dolist (form forms)
(setq getvars (nconc (mapcar #'list vars vals) getvars))
(push reader-form getters)
(push writer-form setters)
(if (cdr store-vars)
(push (car store-vars) storevars))))
(labels ((unroll-body (tempsetters body resetters)
(let ((tempsetters
`(let* (
You will see in the macroexpansion the value of #:NEW1
CL-USER> (defvar *x* "12345")
*X*
CL-USER> (defvar *y* "abcdefg")
*Y*
CL-USER> (macroexpand-1 '(bad-letf (((aref *x* 0) #\@ ) ((aref *y* 3) #\!) ((aref *x* 4) #\% ))
(pprint *x*) (pprint *y*)))
(LET* ((#:G631 #\@)
(#:G632 #\!)
(#:G633 #\%)
(#:*X*639 *X*)
(#:*Y*638 *Y*)
(#:*X*637 *X*)
(#:NEW1 (AREF #:*X*639 4))
(#:NEW1 (AREF #:*Y*638 3))
(#:NEW1 (AREF #:*X*637 0)))
(UNWIND-PROTECT
(PROGN
(FUNCALL #'(SETF AREF) #:G633 #:*X*639 4)
(PROGN
(FUNCALL #'(SETF AREF) #:NEW1 #:*Y*638 3)))
(FUNCALL #'(SETF AREF) #:NEW1 #:*X*639 4)))
The output is:
"%234%6"
"abc%efg"
This is the current fix.
(defmacro si-letf (forms &body body &environment env)
"This is fixed _again_ for sbcl. In <get-setf-
Just substitute the variables that sbcl returns with unique ones."
(flet ((make-vars (count)
(loop repeat count collect (gensym)))
(if (and (symbolp y) (symbolp x)) (string= x y) (eql x y)))
(mapcar #'(lambda (form)
(if (null (cddr form))
(let ((getters ()) (getvars ()) (tmpvars nil)
(setters ()) (storevars ())
(dolist (form forms)
(get-
;; this is a fixup for sbcl: replace #:NEW1
(setq tmpvars (copy-list store-vars))
(setq store-vars (make-vars (length store-vars)))
(setq getvars (nconc (mapcar #'list vars vals) getvars))
(push reader-form getters)
(setq writer-form (sublis (pairlis tmpvars store-vars) writer-form))
(push writer-form setters)
(if (cdr store-vars)
(push (car store-vars) storevars))))
(labels ((unroll-body (tempsetters body resetters)
(let ((tempsetters
`(let* (
The output
(si-letf (((aref *x* 0) #\@ ) ((aref *y* 3) #\!) ((aref *x* 2) #\% )) (pprint *x*) (pprint *y*))
=>
"%2@456"
"abc!efg"
The letf in CMUCL works fine if you change get-setf-method to -expandsion. I just thought that gensyms are never supposed to be the same value. I test them with string= . This weird version I keep around does trigger this issue. I do not want lexical scope for the accessors.
This example is a little confusing to me, but whatever the problem is can't have to do with binding *gensym-counter*. SETF could legally use (make-symbol "TEMP") for all the variables it generates, and it would be perfectly valid.
I don't know what the STRING= calls are for in that macro, but surely that's the source of a problem. To test whether two uninterned symbols are "the same" you must compare by EQ.