;;;
;;; Implementation of TXR Lisp "placelet", in Common Lisp
;;;
;;; Copyright 2019 Kaz Kylheku <kaz@kylheku.com>
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions are met:
;;;
;;; 1. Redistributions of source code must retain the above copyright notice,
;;;    this list of conditions and the following disclaimer.
;;;
;;; 2. Redistributions in binary form must reproduce the above copyright
;;;    notice, this list of conditions and the following disclaimer in the
;;;    documentation and/or other materials provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;; POSSIBILITY OF SUCH DAMAGE.
;;;

;;
;; This is subtly broken. The proxy-place we establish with
;; define-setf-expander is not not actually used. sym ends up being bound to
;; the r-form of the original place, and then we are relying on that form being
;; place. That just happens to work for most well-behaved places.
;;
;; What we need here is a forced full expansion between the symbol-macrolet
;; and macrolet, like in the TXR Lisp implementation. We most process body
;; in an environment in which ,sym to (,proxy-place), but (,proxy-place)
;; doesn't expand to r-form, so that all the occurrences of sym which the
;; body treats as places are treated that way through the ,proxy-place
;; setf expander. When we obtain those expansions, then we impose the
;; macrolet in order to replace the remaining (,proxy-place) references
;; that are not places with the read form.
;;
(defmacro placelet1 (sym place &environment env &body body)
  (multiple-value-bind (vars vals store-vars w-form r-form)
                       (get-setf-expansion place env)
    (let ((proxy-place (gensym)))
      (define-setf-expander proxy-place ()
        (values nil nil store-vars w-form r-form))
      `(let* (,@(mapcar #'list vars vals))
         (macrolet ((,proxy-place () ',r-form))
           ;; we need to fully expand this symbol-macrolet,
           ;; then insert it into here: ,(full-expand (symbol-macrolet ...))
           (symbol-macrolet ((,sym (,proxy-place)))
             ,@body))))))


(defmacro placelet* (sym-place-pairs &body body)
  (cond
    ((null sym-place-pairs) `(progn ,@body))
    ((atom sym-place-pairs) (error "~s: bad syntax" 'placelet))
    (t (destructuring-bind (sym place) (car sym-place-pairs)
         `(placelet1 ,sym ,place ,@(if (cdr sym-place-pairs)
                                     `((placelet ,(cdr sym-place-pairs) ,@body))
                                     body))))))

(defmacro placelet (sym-place-pairs &body body)
  (destructuring-bind (syms places) (apply #'mapcar #'list sym-place-pairs)
    (let ((temps (mapcar (lambda (sym) (gensym)) syms)))
      `(placelet* (,@(mapcar #'list temps places))
         (symbol-macrolet (,@(mapcar #'list syms temps))
           ,@body)))))