/
main.lisp
167 lines (152 loc) · 6.5 KB
/
main.lisp
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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
(in-package #:place-modifiers)
(defun %actual-spot-index (args-count spot-index)
(cond
((minusp spot-index)
(when (>= args-count (abs spot-index))
(+ args-count spot-index)))
(t
(when (> args-count spot-index)
spot-index))))
(defun %actual-spot-value (list spot-index)
(when spot-index
(let ((actual-spot-index (%actual-spot-index (length list) spot-index)))
(when actual-spot-index
(nth actual-spot-index list)))))
#+nil(error "All place modification expressions need ~
at least 1 arg. ~S doesn't qualify."
place-modification-expression)
(defun %augment-template (base-template operator before-spot after-spot)
(lambda (fill-in)
(funcall base-template
`(,operator ,@before-spot ,fill-in ,@after-spot))))
(defun %finish (template place env oldp)
(multiple-value-bind (vars vals stores writer reader)
(get-setf-expansion place env)
(when (/= (length stores) 1)
(error "~S only supports places with exactly ~
one store variable but place ~S has ~D: ~S."
'modify place (length stores) stores))
(let* ((old-var (and oldp (gensym (string '#:old))))
(wrapped-old-var (and old-var (list old-var))))
`(let* (,@vars ,@wrapped-old-var)
(multiple-value-bind ,stores
,(funcall
template
(let ((vars-vals-plist (mapcan #'list vars vals)))
(if oldp
`(setf ,@vars-vals-plist
,old-var ,reader)
(if vars-vals-plist
`(progn (setf ,@vars-vals-plist)
,reader)
reader))))
,writer
,@wrapped-old-var)))))
(defun nop (&rest args)
(declare (ignore args))
(values))
(defun %analyze (pme-or-place &key
(on-place #'nop)
(on-pme #'nop)
(on-ambiguous #'nop))
(etypecase pme-or-place
(atom
(funcall on-place pme-or-place :assumed))
((cons (eql :place))
(destructuring-bind (place) (rest pme-or-place)
(funcall on-place place :explicit)))
(list
(destructuring-bind (pm-name &rest args) pme-or-place
(declare (ignore args))
(let ((pm-info (and pm-name (defsys:locate 'modify pm-name :errorp nil))))
(if pm-info
(funcall (if (inconceivable-place-p pm-info)
on-pme
on-ambiguous)
pme-or-place)
(funcall on-place pme-or-place :assumed)))))))
(defun %map-spots (function args)
(maplist (lambda (tail)
(funcall function
(ldiff args tail)
(first tail)
(rest tail)))
args))
(defun %choose-best (results-list default-spot-index)
(values-list
(let ((explicit-place-results
(remove :assumed results-list :key #'third)))
(case (length explicit-place-results)
(0 (%actual-spot-value results-list default-spot-index))
(1 (first explicit-place-results))
(t (error "Multiple (~A) explicit places found:~{~%~^~S~}"
(length explicit-place-results)
(mapcar #'second explicit-place-results)))))))
(defun %augmented-template-caller (function template)
(lambda (pme)
(let ((operator (first pme)))
(%choose-best (%map-spots (lambda (before-spot spot after-spot)
(multiple-value-list
(funcall function spot
(%augment-template template
operator
before-spot
after-spot))))
(rest pme))
(default-spot-index (defsys:locate 'modify operator))))))
(defun %make-speculative-walk-handler (function template)
(lambda (ambiguous)
(multiple-value-bind (full-template place kind)
(%walk-speculatively-non-top-level ambiguous template)
(multiple-value-call function
(if (eq kind :explicit)
(values full-template place)
(values template ambiguous))
kind))))
(defun %walk-conservatively-non-top-level (pme-or-place)
(labels ((recurse (pme-or-place template)
(%analyze
pme-or-place
:on-place (lambda (place kind)
(values template place kind))
:on-pme (%augmented-template-caller #'recurse template)
:on-ambiguous (%make-speculative-walk-handler #'values template))))
(recurse pme-or-place #'identity)))
(defun %walk-speculatively-non-top-level (pme-or-place template)
(labels ((recurse (pme-or-place template)
(let ((augmented-template-caller
(%augmented-template-caller #'recurse template)))
(%analyze
pme-or-place
:on-place (lambda (place kind)
(values template place kind))
:on-pme augmented-template-caller
:on-ambiguous augmented-template-caller))))
(recurse pme-or-place template)))
(defun %expand (place-modification-expression env)
(let* ((oldp (and (typep place-modification-expression
'(cons (eql :old)))
(destructuring-bind (pme) (cdr place-modification-expression)
(prog1 t
(setf place-modification-expression pme)))))
(finish
(lambda (template place kind)
(declare (ignore kind))
(%finish template place env oldp))))
(%analyze place-modification-expression
:on-place
(lambda (place kind)
(error "Found the following (~(~A~)) place at top-level ~
instead of place-modification-expression:~%~S"
kind place))
:on-pme
(lambda (pme)
(multiple-value-call finish
(%walk-conservatively-non-top-level pme)))
:on-ambiguous
(%make-speculative-walk-handler finish #'identity))))
(defmacro modify (&rest place-modification-expressions &environment env)
`(progn
,@(mapcar (lambda (expression)
(%expand expression env))
place-modification-expressions)))