1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
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)))))
|
