Commit | Line | Data |
---|---|---|
2ee3d7f0 SM |
1 | ;;; gv.el --- Generalized variables -*- lexical-binding: t -*- |
2 | ||
3 | ;; Copyright (C) 2012 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> | |
6 | ;; Keywords: extensions | |
7 | ||
8 | ;; This program is free software; you can redistribute it and/or modify | |
9 | ;; it under the terms of the GNU General Public License as published by | |
10 | ;; the Free Software Foundation, either version 3 of the License, or | |
11 | ;; (at your option) any later version. | |
12 | ||
13 | ;; This program is distributed in the hope that it will be useful, | |
14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;; GNU General Public License for more details. | |
17 | ||
18 | ;; You should have received a copy of the GNU General Public License | |
19 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
21 | ;;; Commentary: | |
22 | ||
23 | ;; This is a re-implementation of the setf machinery using a different | |
24 | ;; underlying approach than the one used earlier in CL, which was based on | |
25 | ;; define-setf-expander. | |
26 | ;; `define-setf-expander' makes every "place-expander" return a 5-tuple | |
27 | ;; (VARS VALUES STORES GETTER SETTER) | |
28 | ;; where STORES is a list with a single variable (Common-Lisp allows multiple | |
29 | ;; variables for use with multiple-return-values, but this is rarely used and | |
30 | ;; not applicable to Elisp). | |
31 | ;; It basically says that GETTER is an expression that returns the place's | |
32 | ;; value, and (lambda STORES SETTER) is an expression that assigns the value(s) | |
33 | ;; passed to that function to the place, and that you need to wrap the whole | |
34 | ;; thing within a `(let* ,(zip VARS VALUES) ...). | |
35 | ;; | |
36 | ;; Instead, we use here a higher-order approach: instead | |
37 | ;; of a 5-tuple, a place-expander returns a function. | |
38 | ;; If you think about types, the old approach return things of type | |
39 | ;; {vars: List Var, values: List Exp, | |
40 | ;; stores: List Var, getter: Exp, setter: Exp} | |
41 | ;; whereas the new approach returns a function of type | |
42 | ;; (do: ((getter: Exp, setter: ((store: Exp) -> Exp)) -> Exp)) -> Exp. | |
43 | ;; You can get the new function from the old 5-tuple with something like: | |
44 | ;; (lambda (do) | |
45 | ;; `(let* ,(zip VARS VALUES) | |
46 | ;; (funcall do GETTER (lambda ,STORES ,SETTER)))) | |
47 | ;; You can't easily do the reverse, because this new approach is more | |
48 | ;; expressive than the old one, so we can't provide a backward-compatible | |
49 | ;; get-setf-method. | |
50 | ;; | |
51 | ;; While it may seem intimidating for people not used to higher-order | |
52 | ;; functions, you will quickly see that its use (especially with the | |
53 | ;; `gv-letplace' macro) is actually much easier and more elegant than the old | |
54 | ;; approach which is clunky and often leads to unreadable code. | |
55 | ||
56 | ;; FIXME: `let!' is unsatisfactory because it does not really "restore" the | |
57 | ;; previous state. If the getter/setter loses information, that info is | |
58 | ;; not recovered. | |
59 | ||
60 | ;; FIXME: Add to defun-declarations-alist. | |
61 | ||
62 | ;; Food for thought: the syntax of places does not actually conflict with the | |
63 | ;; pcase patterns. The `cons' gv works just like a `(,a . ,b) pcase | |
64 | ;; pattern, and actually the `logand' gv is even closer since it should | |
65 | ;; arguably fail when trying to set a value outside of the mask. | |
66 | ;; Generally, places are used for destructors (gethash, aref, car, ...) | |
67 | ;; whereas pcase patterns are used for constructors (backquote, constants, | |
68 | ;; vectors, ...). | |
69 | ||
70 | ;;; Code: | |
71 | ||
72 | (require 'macroexp) | |
73 | ||
74 | ;; What we call a "gvar" is basically a function of type "(getter * setter -> | |
75 | ;; code) -> code", where "getter" is code and setter is "code -> code". | |
76 | ||
77 | ;; (defvar gv--macro-environment nil | |
78 | ;; "Macro expanders for generalized variables.") | |
79 | ||
80 | ;;;###autoload | |
81 | (defun gv-get (place do) | |
82 | "Build the code that applies DO to PLACE. | |
83 | PLACE must be a valid generalized variable. | |
84 | DO must be a function; it will be called with 2 arguments: GETTER and SETTER, | |
85 | where GETTER is a (copyable) Elisp expression that returns the value of PLACE, | |
86 | and SETTER is a function which returns the code to set PLACE when called | |
87 | with a (not necessarily copyable) Elisp expression that returns the value to | |
88 | set it to. | |
89 | DO must return an Elisp expression." | |
90 | (if (symbolp place) | |
91 | (funcall do place (lambda (v) `(setq ,place ,v))) | |
92 | (let* ((head (car place)) | |
93 | (gf (get head 'gv-expander))) | |
94 | (if gf (apply gf do (cdr place)) | |
95 | (let ((me (macroexpand place ;FIXME: expand one step at a time! | |
96 | ;; (append macroexpand-all-environment | |
97 | ;; gv--macro-environment) | |
98 | macroexpand-all-environment))) | |
99 | (if (and (eq me place) (get head 'compiler-macro)) | |
100 | ;; Expand compiler macros: this takes care of all the accessors | |
101 | ;; defined via cl-defsubst, such as cXXXr and defstruct slots. | |
102 | (setq me (apply (get head 'compiler-macro) place (cdr place)))) | |
103 | (if (and (eq me place) (fboundp head) | |
104 | (symbolp (symbol-function head))) | |
105 | ;; Follow aliases. | |
106 | (setq me (cons (symbol-function head) (cdr place)))) | |
107 | (if (eq me place) | |
108 | (error "%S is not a valid place expression" place) | |
109 | (gv-get me do))))))) | |
110 | ||
111 | ;;;###autoload | |
112 | (defmacro gv-letplace (vars place &rest body) | |
113 | "Build the code manipulating the generalized variable PLACE. | |
114 | GETTER will be bound to a copyable expression that returns the value | |
115 | of PLACE. | |
116 | SETTER will be bound to a function that takes an expression V and returns | |
117 | and new expression that sets PLACE to V. | |
118 | BODY should return some Elisp expression E manipulating PLACE via GETTER | |
119 | and SETTER. | |
120 | The returned value will then be an Elisp expression that first evaluates | |
121 | all the parts of PLACE that can be evaluated and then runs E. | |
122 | ||
123 | \(fn (GETTER SETTER) PLACE &rest BODY)" | |
124 | (declare (indent 2) (debug (sexp form body))) | |
125 | `(gv-get ,place (lambda ,vars ,@body))) | |
126 | ||
127 | ;; Different ways to declare a generalized variable. | |
128 | ;;;###autoload | |
129 | (defmacro gv-define-expander (name handler) | |
130 | "Use HANDLER to handle NAME as a generalized var. | |
131 | NAME is a symbol: the name of a function, macro, or special form. | |
132 | HANDLER is a function which takes an argument DO followed by the same | |
133 | arguments as NAME. DO is a function as defined in `gv-get'." | |
134 | (declare (indent 1) (debug (sexp form))) | |
135 | ;; Use eval-and-compile so the method can be used in the same file as it | |
136 | ;; is defined. | |
137 | ;; FIXME: Just like byte-compile-macro-environment, we should have something | |
138 | ;; like byte-compile-symbolprop-environment so as to handle these things | |
139 | ;; cleanly without affecting the running Emacs. | |
140 | `(eval-and-compile (put ',name 'gv-expander ,handler))) | |
141 | ||
142 | ;; (eval-and-compile | |
143 | ;; (defun gv--defun-declaration (name args handler) | |
144 | ;; (pcase handler | |
145 | ;; (`(lambda (,do) . ,body) | |
146 | ;; `(gv-define-expander ,name (lambda (,do ,@args) ,@body))) | |
147 | ;; ;; (`(expand ,expander) `(gv-define-expand ,name ,expander)) | |
148 | ;; ;; FIXME: If `setter' is a lambda, give it a name rather | |
149 | ;; ;; than duplicate it at each setf use. | |
150 | ;; (`(setter ,setter) `(gv-define-simple-setter ,name ,setter)) | |
151 | ;; (`(setter (,arg) . ,body) | |
152 | ;; `(gv-define-setter ,name (,arg ,@args) ,@body)) | |
153 | ;; ;; FIXME: Should we prefer gv-define-simple-setter in this case? | |
154 | ;; ;;((pred symbolp) `(gv-define-expander ,name #',handler)) | |
155 | ;; (_ (message "Unknown gv-expander declaration %S" handler) nil))) | |
156 | ||
157 | ;; (push `(gv-expander ,#'gv--defun-declaration) defun-declarations-alist) | |
158 | ;; ) | |
159 | ||
160 | ;; (defmacro gv-define-expand (name expander) | |
161 | ;; "Use EXPANDER to handle NAME as a generalized var. | |
162 | ;; NAME is a symbol: the name of a function, macro, or special form. | |
163 | ;; EXPANDER is a function that will be called as a macro-expander to reduce | |
164 | ;; uses of NAME to some other generalized variable." | |
165 | ;; (declare (debug (sexp form))) | |
166 | ;; `(eval-and-compile | |
167 | ;; (if (not (boundp 'gv--macro-environment)) | |
168 | ;; (setq gv--macro-environment nil)) | |
169 | ;; (push (cons ',name ,expander) gv--macro-environment))) | |
170 | ||
171 | (defun gv--defsetter (name setter do args &optional vars) | |
172 | "Helper function used by code generated by `gv-define-setter'. | |
173 | NAME is the name of the getter function. | |
174 | SETTER is a function that generates the code for the setter. | |
175 | NAME accept ARGS as arguments and SETTER accepts (NEWVAL . ARGS). | |
176 | VARS is used internally for recursive calls." | |
177 | (if (null args) | |
178 | (let ((vars (nreverse vars))) | |
179 | (funcall do `(,name ,@vars) (lambda (v) (apply setter v vars)))) | |
180 | ;; FIXME: Often it would be OK to skip this `let', but in general, | |
181 | ;; `do' may have all kinds of side-effects. | |
182 | (macroexp-let2 nil v (car args) | |
183 | (gv--defsetter name setter do (cdr args) (cons v vars))))) | |
184 | ||
185 | ;;;###autoload | |
186 | (defmacro gv-define-setter (name arglist &rest body) | |
187 | "Define a setter method for generalized variable NAME. | |
188 | This macro is an easy-to-use substitute for `gv-define-expander' that works | |
189 | well for simple place forms. | |
190 | Assignments of VAL to (NAME ARGS...) are expanded by binding the argument | |
191 | forms (VAL ARGS...) according to ARGLIST, then executing BODY, which must | |
192 | return a Lisp form that does the assignment. | |
193 | Actually, ARGLIST may be bound to temporary variables which are introduced | |
194 | automatically to preserve proper execution order of the arguments. Example: | |
195 | (gv-define-setter aref (v a i) `(aset ,a ,i ,v))" | |
196 | (declare (indent 2) (debug (&define name sexp body))) | |
197 | `(gv-define-expander ,name | |
198 | (lambda (do &rest args) | |
199 | (gv--defsetter ',name (lambda ,arglist ,@body) do args)))) | |
200 | ||
201 | ;;;###autoload | |
202 | (defmacro gv-define-simple-setter (name setter &optional fix-return) | |
203 | "Define a simple setter method for generalized variable NAME. | |
204 | This macro is an easy-to-use substitute for `gv-define-expander' that works | |
205 | well for simple place forms. Assignments of VAL to (NAME ARGS...) are | |
206 | turned into calls of the form (SETTER ARGS... VAL). | |
207 | If FIX-RETURN is non-nil, then SETTER is not assumed to return VAL and | |
208 | instead the assignment is turned into (prog1 VAL (SETTER ARGS... VAL)) | |
209 | so as to preserve the semantics of `setf'." | |
210 | (declare (debug (sexp (&or symbolp lambda-expr) &optional sexp))) | |
211 | (let ((set-call `(cons ',setter (append args (list val))))) | |
212 | `(gv-define-setter ,name (val &rest args) | |
213 | ,(if fix-return `(list 'prog1 val ,set-call) set-call)))) | |
214 | ||
215 | ;;; CL compatibility. | |
216 | ||
217 | (defmacro gv-define-modify-macro (name arglist func &optional doc) | |
218 | (let* ((args (copy-sequence arglist)) | |
219 | (rest (memq '&rest args))) | |
220 | (setq args (delq '&optional (delq '&rest args))) | |
221 | `(defmacro ,name (place ,@arglist) | |
222 | ,doc | |
223 | (gv-letplace (getter setter) place | |
224 | (macroexp-let2 nil v | |
225 | ,(list '\` | |
226 | (append (list func ',getter) | |
227 | (mapcar (lambda (arg) (list '\, arg)) args) | |
228 | (if rest (list (list '\,@ (cadr rest)))))) | |
229 | (funcall setter v)))))) | |
230 | ||
231 | (gv-define-simple-setter gv--tree-get gv--tree-set) | |
232 | ||
233 | ;;; Typical operations on generalized variables. | |
234 | ||
235 | ;;;###autoload | |
236 | (defmacro setf (&rest args) | |
237 | "Set each PLACE to the value of its VAL. | |
238 | This is a generalized version of `setq'; the PLACEs may be symbolic | |
239 | references such as (car x) or (aref x i), as well as plain symbols. | |
240 | For example, (setf (cadr x) y) is equivalent to (setcar (cdr x) y). | |
241 | The return value is the last VAL in the list. | |
242 | ||
243 | \(fn PLACE VAL PLACE VAL ...)" | |
244 | (declare (debug (gv-place form))) | |
245 | (if (and args (null (cddr args))) | |
246 | (let ((place (pop args)) | |
247 | (val (car args))) | |
248 | (gv-letplace (_getter setter) place | |
249 | (funcall setter val))) | |
250 | (let ((sets nil)) | |
251 | (while args (push `(setf ,(pop args) ,(pop args)) sets)) | |
252 | (cons 'progn (nreverse sets))))) | |
253 | ||
254 | (defmacro gv-pushnew! (val place) | |
255 | "Like `gv-push!' but only adds VAL if it's not yet in PLACE. | |
256 | Presence is checked with `member'. | |
257 | The return value is unspecified." | |
258 | (declare (debug (form gv-place))) | |
259 | (macroexp-let2 macroexp-copyable-p v val | |
260 | (gv-letplace (getter setter) place | |
261 | `(if (member ,v ,getter) nil | |
262 | ,(funcall setter `(cons ,v ,getter)))))) | |
263 | ||
264 | (defmacro gv-inc! (place &optional val) | |
265 | "Increment PLACE by VAL (default to 1)." | |
266 | (declare (debug (gv-place &optional form))) | |
267 | (gv-letplace (getter setter) place | |
268 | (funcall setter `(+ ,getter ,(or val 1))))) | |
269 | ||
270 | (defmacro gv-dec! (place &optional val) | |
271 | "Decrement PLACE by VAL (default to 1)." | |
272 | (declare (debug (gv-place &optional form))) | |
273 | (gv-letplace (getter setter) place | |
274 | (funcall setter `(- ,getter ,(or val 1))))) | |
275 | ||
276 | ;; For Edebug, the idea is to let Edebug instrument gv-places just like it does | |
277 | ;; for normal expressions, and then give it a gv-expander to DTRT. | |
278 | ;; Maybe this should really be in edebug.el rather than here. | |
279 | ||
280 | (put 'gv-place 'edebug-form-spec 'edebug-match-form) | |
281 | ;; CL did the equivalent of: | |
282 | ;;(gv-define-expand edebug-after (lambda (before index place) place)) | |
283 | ||
284 | (put 'edebug-after 'gv-expander | |
285 | (lambda (do before index place) | |
286 | (gv-letplace (getter setter) place | |
287 | (funcall do `(edebug-after ,before ,index ,getter) | |
288 | setter)))) | |
289 | ||
290 | ;;; The common generalized variables. | |
291 | ||
292 | (gv-define-simple-setter aref aset) | |
293 | (gv-define-simple-setter car setcar) | |
294 | (gv-define-simple-setter cdr setcdr) | |
295 | ;; FIXME: add compiler-macros for `cXXr' instead! | |
296 | (gv-define-setter caar (val x) `(setcar (car ,x) ,val)) | |
297 | (gv-define-setter cadr (val x) `(setcar (cdr ,x) ,val)) | |
298 | (gv-define-setter cdar (val x) `(setcdr (car ,x) ,val)) | |
299 | (gv-define-setter cddr (val x) `(setcdr (cdr ,x) ,val)) | |
300 | (gv-define-setter elt (store seq n) | |
301 | `(if (listp ,seq) (setcar (nthcdr ,n ,seq) ,store) | |
302 | (aset ,seq ,n ,store))) | |
303 | (gv-define-simple-setter get put) | |
304 | (gv-define-setter gethash (val k h &optional _d) `(puthash ,k ,val ,h)) | |
305 | ||
306 | ;; (gv-define-expand nth (lambda (idx list) `(car (nthcdr ,idx ,list)))) | |
307 | (put 'nth 'gv-expander | |
308 | (lambda (do idx list) | |
309 | (macroexp-let2 nil c `(nthcdr ,idx ,list) | |
310 | (funcall do `(car ,c) (lambda (v) `(setcar ,c ,v)))))) | |
311 | (gv-define-simple-setter symbol-function fset) | |
312 | (gv-define-simple-setter symbol-plist setplist) | |
313 | (gv-define-simple-setter symbol-value set) | |
314 | ||
315 | (put 'nthcdr 'gv-expander | |
316 | (lambda (do n place) | |
317 | (macroexp-let2 nil idx n | |
318 | (gv-letplace (getter setter) place | |
319 | (funcall do `(nthcdr ,idx ,getter) | |
320 | (lambda (v) `(if (<= ,idx 0) ,(funcall setter v) | |
321 | (setcdr (nthcdr (1- ,idx) ,getter) ,v)))))))) | |
322 | ||
323 | ;;; Elisp-specific generalized variables. | |
324 | ||
325 | (gv-define-simple-setter default-value set-default) | |
326 | (gv-define-simple-setter frame-parameter set-frame-parameter 'fix) | |
327 | (gv-define-simple-setter terminal-parameter set-terminal-parameter) | |
328 | (gv-define-simple-setter keymap-parent set-keymap-parent) | |
329 | (gv-define-simple-setter match-data set-match-data 'fix) | |
330 | (gv-define-simple-setter overlay-get overlay-put) | |
331 | (gv-define-setter overlay-start (store ov) | |
332 | `(progn (move-overlay ,ov ,store (overlay-end ,ov)) ,store)) | |
333 | (gv-define-setter overlay-end (store ov) | |
334 | `(progn (move-overlay ,ov (overlay-start ,ov) ,store) ,store)) | |
335 | (gv-define-simple-setter process-buffer set-process-buffer) | |
336 | (gv-define-simple-setter process-filter set-process-filter) | |
337 | (gv-define-simple-setter process-sentinel set-process-sentinel) | |
338 | (gv-define-simple-setter process-get process-put) | |
339 | (gv-define-simple-setter window-buffer set-window-buffer) | |
340 | (gv-define-simple-setter window-display-table set-window-display-table 'fix) | |
341 | (gv-define-simple-setter window-dedicated-p set-window-dedicated-p) | |
342 | (gv-define-simple-setter window-hscroll set-window-hscroll) | |
343 | (gv-define-simple-setter window-parameter set-window-parameter) | |
344 | (gv-define-simple-setter window-point set-window-point) | |
345 | (gv-define-simple-setter window-start set-window-start) | |
346 | ||
347 | ;;; Some occasionally handy extensions. | |
348 | ||
349 | ;; While several of the "places" below are not terribly useful for direct use, | |
350 | ;; they can show up as the output of the macro expansion of reasonable places, | |
351 | ;; such as struct-accessors. | |
352 | ||
353 | (put 'progn 'gv-expander | |
354 | (lambda (do &rest exps) | |
355 | (let ((start (butlast exps)) | |
356 | (end (car (last exps)))) | |
357 | (if (null start) (gv-get end do) | |
358 | `(progn ,@start ,(gv-get end do)))))) | |
359 | ||
360 | (let ((let-expander | |
361 | (lambda (letsym) | |
362 | (lambda (do bindings &rest body) | |
363 | `(,letsym ,bindings | |
364 | ,@(macroexp-unprogn | |
365 | (gv-get (macroexp-progn body) do))))))) | |
366 | (put 'let 'gv-expander (funcall let-expander 'let)) | |
367 | (put 'let* 'gv-expander (funcall let-expander 'let*))) | |
368 | ||
369 | (put 'if 'gv-expander | |
370 | (lambda (do test then &rest else) | |
371 | (let ((v (make-symbol "v"))) | |
372 | (if (macroexp-small-p (funcall do 'dummy (lambda (_) 'dummy))) | |
373 | ;; This duplicates the `do' code, which is a problem if that | |
374 | ;; code is large, but otherwise results in more efficient code. | |
375 | `(if ,test ,(gv-get then do) | |
376 | ,@(macroexp-unprogn (gv-get (macroexp-progn else) do))) | |
377 | (macroexp-let2 nil b test | |
378 | (macroexp-let2 nil | |
379 | gv `(if ,b ,(gv-letplace (getter setter) then | |
380 | `(cons (lambda () ,getter) | |
381 | (lambda (,v) ,(funcall setter v)))) | |
382 | ,(gv-letplace (getter setter) (macroexp-progn else) | |
383 | `(cons (lambda () ,getter) | |
384 | (lambda (,v) ,(funcall setter v))))) | |
385 | (funcall do `(funcall (car ,gv)) | |
386 | (lambda (v) `(funcall (cdr ,gv) ,v))))))))) | |
387 | ||
388 | ;;; Even more debatable extensions. | |
389 | ||
390 | (put 'cons 'gv-expander | |
391 | (lambda (do a d) | |
392 | (gv-letplace (agetter asetter) a | |
393 | (gv-letplace (dgetter dsetter) d | |
394 | (funcall do | |
395 | `(cons ,agetter ,dgetter) | |
396 | (lambda (v) `(progn | |
397 | ,(funcall asetter `(car ,v)) | |
398 | ,(funcall dsetter `(cdr ,v))))))))) | |
399 | ||
400 | (put 'logand 'gv-expander | |
401 | (lambda (do place &rest masks) | |
402 | (gv-letplace (getter setter) place | |
403 | (macroexp-let2 macroexp-copyable-p | |
404 | mask (if (cdr masks) `(logand ,@masks) (car masks)) | |
405 | (funcall | |
406 | do `(logand ,getter ,mask) | |
407 | (lambda (v) | |
408 | (funcall setter | |
409 | `(logior (logand ,v ,mask) | |
410 | (logand ,getter (lognot ,mask)))))))))) | |
411 | ||
412 | ;;; Vaguely related definitions that should be moved elsewhere. | |
413 | ||
414 | ;; (defun alist-get (key alist) | |
415 | ;; "Get the value associated to KEY in ALIST." | |
416 | ;; (declare | |
417 | ;; (gv-expander | |
418 | ;; (lambda (do) | |
419 | ;; (macroexp-let2 macroexp-copyable-p k key | |
420 | ;; (gv-letplace (getter setter) alist | |
421 | ;; (macroexp-let2 nil p `(assoc ,k ,getter) | |
422 | ;; (funcall do `(cdr ,p) | |
423 | ;; (lambda (v) | |
424 | ;; `(if ,p (setcdr ,p ,v) | |
425 | ;; ,(funcall setter | |
426 | ;; `(cons (cons ,k ,v) ,getter))))))))))) | |
427 | ;; (cdr (assoc key alist))) | |
428 | ||
429 | (provide 'gv) | |
430 | ;;; gv.el ends here |