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