(defmacro symbol-macroletf (((symbol place)) &body body
                            &environment environment)
  "Like SYMBOL-MACROLET but evaluate subforms just once up front.
Binding multiple symbols in the same form has not yet been implemented."
  (multiple-value-bind (vars vals store-vars writer-form reader-form)
      (get-setf-expansion place environment)
    (let ((route (gensym (string symbol))))
      `(let* (,@(mapcar #'list vars vals))
         (flet ((,route () ,reader-form)
                ((setf ,route) (,(first store-vars)) ,writer-form))
           (symbol-macrolet ((,symbol (,route)))
             ,@body))))))

;; this works OK
(let ((x 0)
      (v (copy-seq '(totally alone again))))
  (symbol-macroletf ((s (elt v (incf x))))
    (values (shiftf s 'wasted) s v)))

;; this doesn't
(let ((x 0)
      (v (copy-seq '(totally alone again))))
  (symbol-macroletf ((s (values (elt v (incf x))
                                (elt v (incf x)))))
    (shiftf s (values 'successful 'incubation))))

(let (x)
  (with-setf-expander (1plus (place &environment env)
                        (multiple-value-bind (vars vals stores write read)
                            (get-setf-expansion place env)
                          (let ((store (gensym)))
                            (values vars vals `(,store)
                                    ;; Bind the first store variable
                                    ;; to the computed value and the
                                    ;; rest to nil.  This also handles
                                    ;; the case where there are no
                                    ;; store variables.
                                    `(multiple-value-bind (,@stores)
                                         (values (1- ,store))
                                       ,write
                                       ;; Remember to return the
                                       ;; correct value per 5.1.1.2.
                                       (values ,store))
                                    `(1+ ,read)))))
    (values (setf (1plus x) 42)                 ; 42
            (shiftf (1plus (1plus x)) 69)       ; 43
            (1plus (1plus x))                   ; 69
            x)))                                ; 67

(defmacro redirect-place (setf-expander-macro place &environment env)
  (multiple-value-bind (vars vals stores write read)
      (funcall (macro-function setf-expander-macro env) place env)
    (declare (ignore stores write))
    `(let* ,(mapcar #'list vars vals)
       ,read)))

(define-setf-expander redirect-place (setf-expander-macro place
                                      &environment env)
  (funcall (macro-function setf-expander-macro env) place env))

(defmacro with-setf-expander ((access-fn lambda-list &body expander-body)
                              &body with-body)
  (let ((expander (gensym))
        (ignore (gensym))
        (place (gensym)))
    `(macrolet ((,expander ,lambda-list
                  ;; PORTABILITY: This assumes MACROLET can define a macro
                  ;; function that returns multiple values.  If your Lisp
                  ;; implementation disagrees, you can wrap the values in
                  ;; a list instead.  But then you'd have to separate the
                  ;; body into declarations and forms.
                  ,@expander-body)
                (,access-fn (&whole ,place &rest ,ignore)
                  (declare (ignore ,ignore))
                  `(redirect-place ,',expander ,,place)))
       ,@with-body)))

;; test
(let ((x 42))
  (with-setf-expander (1plus (place &environment env)
                        (multiple-value-bind (vars vals stores write read)
                            (get-setf-expansion place env)
                          (let ((store (gensym)))
                            (values vars vals `(,store)
                                    `(multiple-value-bind (,@stores)
                                         (1- ,store)
                                       ,write)
                                    `(1+ ,read)))))
    (values (1plus x)                   ; 43
            (shiftf (1plus x) 69)       ; 43
            (1plus x)                   ; 69
            x)))                        ; 68

;; ERROR: The variable #:G1 occurs more than once in the lambda list.
(let (x)
  (symbol-macroletf ((y x))
    (setf (values y y) t)))

;; This change fixes it.
(define-setf-expander symbol-macroletf-helper (store-vars writer-form
                                               reader-form)
  (let* ((new-store-vars (loop repeat (length store-vars)
                               collect (gensym)))
         (new-writer-form `(let (,@(mapcar #'list store-vars new-store-vars))
                             ,writer-form)))
    (values '() '() new-store-vars new-writer-form reader-form)))

(defmacro symbol-macroletf-helper (store-vars writer-form reader-form)
  (declare (ignore store-vars writer-form))
  reader-form)

(define-setf-expander symbol-macroletf-helper (store-vars writer-form
                                               reader-form)
  (values '() '() store-vars writer-form reader-form))

(defmacro symbol-macroletf ((&rest bindings) &body body
                            &environment environment)
  "Like SYMBOL-MACROLET but evaluate subforms just once up front."
  (loop with (vars vals store-vars writer-form reader-form)
        for (symbol place) in bindings
        do (setf (values vars vals store-vars writer-form reader-form)
                 (get-setf-expansion place environment))
        nconc (mapcar #'list vars vals)
          into let*-bindings
        collect `(,symbol (symbol-macroletf-helper ,store-vars ,writer-form
                                                   ,reader-form))
          into symbol-macrolet-bindings
        finally (return `(let* (,@let*-bindings)
                           (symbol-macrolet (,@symbol-macrolet-bindings)
                             ,@body)))))