get-setf-expansion

[steve gonedes]

I think that in get-setf-expansion <SYS:SRC;CODE;SETF.LISP> binding *gensym-counter* is a problem.

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))
                 (make-gensym-list count "NEW")))

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)))
         (equal-gensyms (x y)
           (if (and (symbolp y) (symbolp x)) (string= x y) (eql x y)))
         (extract-setf-subforms (forms)
           (mapcar #'(lambda (form)
             (if (null (cddr form))
                 (cadr form)
                 (error 'program-error
                  :format-arguments (list (cdr form))
                  :format-control
                  "~@<Odd number of subforms to setf: ~_~:w.~:@>")))
             forms)))

    (let ((getters ()) (getvars ())
          (setters ()) (storevars ())
          (valuevars (make-vars (length forms)))
          (valueforms (extract-setf-subforms forms)))
      (dolist (form forms)
        (multiple-value-bind (vars vals store-vars writer-form reader-form)
            (get-setf-expansion (car form) env)
          (setq getvars (nconc (mapcar #'list vars vals) getvars))
          (push reader-form getters)
          (push writer-form setters)
          (if (cdr store-vars)
              (error 'program-error
                :format-control "~@<Cannot expand form: ~_~:w.~:@>"
                :format-arguments (list form))
              (push (car store-vars) storevars))))

      (labels ((unroll-body (tempsetters body resetters)
                 (cond ((endp tempsetters)
                        (cons 'progn body))
                       (t `(unwind-protect
                      (progn ,(car tempsetters)
                        ,(unroll-body (cdr tempsetters) body (cdr resetters)))
                    ,(car resetters))))))

        (let ((tempsetters
             (sublis (pairlis storevars valuevars)
                setters :test #'equal-gensyms)))

        `(let* (
                ,@(mapcar #'list valuevars valueforms)
                ,@getvars
                ,@(mapcar #'list storevars getters))
           ,(unroll-body tempsetters body setters)))))))

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)
       (UNWIND-PROTECT
           (PROGN
            (FUNCALL #'(SETF AREF) #:G633 #:*Y*638 3)
            (UNWIND-PROTECT
                (PROGN
                 (FUNCALL #'(SETF AREF) #:G633 #:*X*637 0)
                 (PROGN (PPRINT *X*) (PPRINT *Y*)))
              (FUNCALL #'(SETF AREF) #:NEW1 #:*X*637 0)))
         (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-expansion> it binds *gensym-counter* leading to a problem.
Just substitute the variables that sbcl returns with unique ones."
  (flet ((make-vars (count)
           (loop repeat count collect (gensym)))
         (equal-gensyms (x y)
     (if (and (symbolp y) (symbolp x)) (string= x y) (eql x y)))
         (extract-setf-subforms (forms)
           (mapcar #'(lambda (form)
             (if (null (cddr form))
                 (cadr form)
                 (error 'program-error
                  :format-arguments (list (cdr form))
                  :format-control
                  "~@<Odd number of subforms to setf: ~_~:w.~:@>")))
             forms)))

    (let ((getters ()) (getvars ()) (tmpvars nil)
          (setters ()) (storevars ())
          (valuevars (make-vars (length forms)))
          (valueforms (extract-setf-subforms forms)))
      (dolist (form forms)
        (multiple-value-bind (vars vals store-vars writer-form reader-form)
   (get-setf-expansion (car form) env)

    ;; this is a fixup for sbcl: replace #:NEW1
    (setq tmpvars (copy-list store-vars))
                  ;; debug-io: tmpvars

     (setq store-vars (make-vars (length store-vars)))
     (setq getvars (nconc (mapcar #'list vars vals) getvars))
    (push reader-form getters)

                   ;; this is a fixup for sbcl: replace #:NEW1
    (setq writer-form (sublis (pairlis tmpvars store-vars) writer-form))

    (push writer-form setters)
    (if (cdr store-vars)
              (error 'program-error
                :format-control "~@<Cannot expand form: ~_~:w.~:@>"
                :format-arguments (list form))
              (push (car store-vars) storevars))))

      (labels ((unroll-body (tempsetters body resetters)
                 (cond ((endp tempsetters)
                        (cons 'progn body))
                       (t `(unwind-protect
                      (progn ,(car tempsetters)
                        ,(unroll-body (cdr tempsetters) body (cdr resetters)))
                    ,(car resetters))))))

        (let ((tempsetters
             (sublis (pairlis storevars valuevars)
                setters :test #'equal-gensyms)))

        `(let* (
                ,@(mapcar #'list valuevars valueforms)
                ,@getvars
                ,@(mapcar #'list storevars getters))
           ,(unroll-body tempsetters body setters)))))))

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.

[Douglas Katzman (dougk)]

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.

[steve gonedes (sgonedes1977)]

the string= is to test for equal gensyms.
I believe that if a gensym is eq there is a problem.

CL-USER> (setq *x* (gensym 100))
#:G100
CL-USER> (setq *y* (gensym 100))
#:G100
CL-USER> (eq *x* *y*)
NIL
CL-USER> (equalp *x* *y*)
NIL
CL-USER> (string= *x* *y*)
T
CL-USER>

[steve gonedes (sgonedes1977)]

(make-symbol "TEMP") is interned. gensym is not. big difference.

[Douglas Katzman (dougk)]

RTFM @ http://www.lispworks.com/documentation/HyperSpec/Body/f_mk_sym.htm#make-symbol
"make-symbol creates and returns a fresh, uninterned symbol whose name is the given name."