New module: placelet.HEADmaster

1 files changed, 72 insertions, 0 deletions

diff --git a/placelet.lisp b/placelet.lisp
new file mode 100644
index 0000000..72d3c76
--- /dev/null
+++ b/placelet.lisp
@@ -0,0 +1,72 @@
+;;;
+;;; 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)))))