Commit | Line | Data |
---|---|---|
0c765e5f | 1 | ;;; gv.el --- generalized variables -*- lexical-binding: t -*- |
2ee3d7f0 SM |
2 | |
3 | ;; Copyright (C) 2012 Free Software Foundation, Inc. | |
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) | |
105 | (error "%S is not a valid place expression" place) | |
106 | (gv-get me do))))))) | |
107 | ||
108 | ;;;###autoload | |
109 | (defmacro gv-letplace (vars place &rest body) | |
110 | "Build the code manipulating the generalized variable PLACE. | |
111 | GETTER will be bound to a copyable expression that returns the value | |
112 | of PLACE. | |
113 | SETTER will be bound to a function that takes an expression V and returns | |
2ee1d59f | 114 | a new expression that sets PLACE to V. |
2ee3d7f0 SM |
115 | BODY should return some Elisp expression E manipulating PLACE via GETTER |
116 | and SETTER. | |
117 | The returned value will then be an Elisp expression that first evaluates | |
118 | all the parts of PLACE that can be evaluated and then runs E. | |
119 | ||
120 | \(fn (GETTER SETTER) PLACE &rest BODY)" | |
121 | (declare (indent 2) (debug (sexp form body))) | |
122 | `(gv-get ,place (lambda ,vars ,@body))) | |
123 | ||
124 | ;; Different ways to declare a generalized variable. | |
125 | ;;;###autoload | |
126 | (defmacro gv-define-expander (name handler) | |
127 | "Use HANDLER to handle NAME as a generalized var. | |
128 | NAME is a symbol: the name of a function, macro, or special form. | |
129 | HANDLER is a function which takes an argument DO followed by the same | |
130 | arguments as NAME. DO is a function as defined in `gv-get'." | |
131 | (declare (indent 1) (debug (sexp form))) | |
132 | ;; Use eval-and-compile so the method can be used in the same file as it | |
133 | ;; is defined. | |
134 | ;; FIXME: Just like byte-compile-macro-environment, we should have something | |
135 | ;; like byte-compile-symbolprop-environment so as to handle these things | |
136 | ;; cleanly without affecting the running Emacs. | |
137 | `(eval-and-compile (put ',name 'gv-expander ,handler))) | |
138 | ||
36cec983 SM |
139 | ;;;###autoload |
140 | (defun gv--defun-declaration (symbol name args handler &optional fix) | |
141 | `(progn | |
142 | ;; No need to autoload this part, since gv-get will auto-load the | |
143 | ;; function's definition before checking the `gv-expander' property. | |
144 | :autoload-end | |
145 | ,(pcase (cons symbol handler) | |
146 | (`(gv-expander . (lambda (,do) . ,body)) | |
147 | `(gv-define-expander ,name (lambda (,do ,@args) ,@body))) | |
148 | (`(gv-expander . ,(pred symbolp)) | |
149 | `(gv-define-expander ,name #',handler)) | |
150 | (`(gv-setter . (lambda (,store) . ,body)) | |
151 | `(gv-define-setter ,name (,store ,@args) ,@body)) | |
152 | (`(gv-setter . ,(pred symbolp)) | |
153 | `(gv-define-simple-setter ,name ,handler ,fix)) | |
154 | ;; (`(expand ,expander) `(gv-define-expand ,name ,expander)) | |
155 | (_ (message "Unknown %s declaration %S" symbol handler) nil)))) | |
2ee3d7f0 | 156 | |
36cec983 SM |
157 | ;;;###autoload |
158 | (push `(gv-expander ,(apply-partially #'gv--defun-declaration 'gv-expander)) | |
159 | defun-declarations-alist) | |
160 | ;;;###autoload | |
161 | (push `(gv-setter ,(apply-partially #'gv--defun-declaration 'gv-setter)) | |
162 | defun-declarations-alist) | |
2ee3d7f0 SM |
163 | |
164 | ;; (defmacro gv-define-expand (name expander) | |
165 | ;; "Use EXPANDER to handle NAME as a generalized var. | |
166 | ;; NAME is a symbol: the name of a function, macro, or special form. | |
167 | ;; EXPANDER is a function that will be called as a macro-expander to reduce | |
168 | ;; uses of NAME to some other generalized variable." | |
169 | ;; (declare (debug (sexp form))) | |
170 | ;; `(eval-and-compile | |
171 | ;; (if (not (boundp 'gv--macro-environment)) | |
172 | ;; (setq gv--macro-environment nil)) | |
173 | ;; (push (cons ',name ,expander) gv--macro-environment))) | |
174 | ||
175 | (defun gv--defsetter (name setter do args &optional vars) | |
176 | "Helper function used by code generated by `gv-define-setter'. | |
177 | NAME is the name of the getter function. | |
178 | SETTER is a function that generates the code for the setter. | |
179 | NAME accept ARGS as arguments and SETTER accepts (NEWVAL . ARGS). | |
180 | VARS is used internally for recursive calls." | |
181 | (if (null args) | |
182 | (let ((vars (nreverse vars))) | |
183 | (funcall do `(,name ,@vars) (lambda (v) (apply setter v vars)))) | |
184 | ;; FIXME: Often it would be OK to skip this `let', but in general, | |
185 | ;; `do' may have all kinds of side-effects. | |
186 | (macroexp-let2 nil v (car args) | |
187 | (gv--defsetter name setter do (cdr args) (cons v vars))))) | |
188 | ||
189 | ;;;###autoload | |
190 | (defmacro gv-define-setter (name arglist &rest body) | |
191 | "Define a setter method for generalized variable NAME. | |
192 | This macro is an easy-to-use substitute for `gv-define-expander' that works | |
193 | well for simple place forms. | |
194 | Assignments of VAL to (NAME ARGS...) are expanded by binding the argument | |
195 | forms (VAL ARGS...) according to ARGLIST, then executing BODY, which must | |
196 | return a Lisp form that does the assignment. | |
6b3770fb | 197 | The first arg in ARGLIST (the one that receives VAL) receives an expression |
35e62fc9 SM |
198 | which can do arbitrary things, whereas the other arguments are all guaranteed |
199 | to be pure and copyable. Example use: | |
2ee3d7f0 SM |
200 | (gv-define-setter aref (v a i) `(aset ,a ,i ,v))" |
201 | (declare (indent 2) (debug (&define name sexp body))) | |
202 | `(gv-define-expander ,name | |
203 | (lambda (do &rest args) | |
204 | (gv--defsetter ',name (lambda ,arglist ,@body) do args)))) | |
205 | ||
206 | ;;;###autoload | |
207 | (defmacro gv-define-simple-setter (name setter &optional fix-return) | |
208 | "Define a simple setter method for generalized variable NAME. | |
209 | This macro is an easy-to-use substitute for `gv-define-expander' that works | |
210 | well for simple place forms. Assignments of VAL to (NAME ARGS...) are | |
211 | turned into calls of the form (SETTER ARGS... VAL). | |
2ee1d59f | 212 | |
2ee3d7f0 | 213 | If FIX-RETURN is non-nil, then SETTER is not assumed to return VAL and |
2ee1d59f GM |
214 | instead the assignment is turned into something equivalent to |
215 | \(let ((temp VAL)) | |
216 | (SETTER ARGS... temp) | |
217 | temp) | |
2ee3d7f0 SM |
218 | so as to preserve the semantics of `setf'." |
219 | (declare (debug (sexp (&or symbolp lambda-expr) &optional sexp))) | |
2ee3d7f0 | 220 | `(gv-define-setter ,name (val &rest args) |
b715ed44 SM |
221 | ,(if fix-return |
222 | `(macroexp-let2 nil v val | |
f8705f6e SM |
223 | `(progn |
224 | (,',setter ,@(append args (list v))) | |
225 | ,v)) | |
b715ed44 | 226 | `(cons ',setter (append args (list val)))))) |
2ee3d7f0 | 227 | |
2ee3d7f0 SM |
228 | ;;; Typical operations on generalized variables. |
229 | ||
230 | ;;;###autoload | |
231 | (defmacro setf (&rest args) | |
232 | "Set each PLACE to the value of its VAL. | |
233 | This is a generalized version of `setq'; the PLACEs may be symbolic | |
234 | references such as (car x) or (aref x i), as well as plain symbols. | |
235 | For example, (setf (cadr x) y) is equivalent to (setcar (cdr x) y). | |
236 | The return value is the last VAL in the list. | |
237 | ||
238 | \(fn PLACE VAL PLACE VAL ...)" | |
239 | (declare (debug (gv-place form))) | |
240 | (if (and args (null (cddr args))) | |
241 | (let ((place (pop args)) | |
242 | (val (car args))) | |
243 | (gv-letplace (_getter setter) place | |
244 | (funcall setter val))) | |
245 | (let ((sets nil)) | |
246 | (while args (push `(setf ,(pop args) ,(pop args)) sets)) | |
247 | (cons 'progn (nreverse sets))))) | |
248 | ||
36cec983 SM |
249 | ;; (defmacro gv-pushnew! (val place) |
250 | ;; "Like `gv-push!' but only adds VAL if it's not yet in PLACE. | |
251 | ;; Presence is checked with `member'. | |
252 | ;; The return value is unspecified." | |
253 | ;; (declare (debug (form gv-place))) | |
254 | ;; (macroexp-let2 macroexp-copyable-p v val | |
255 | ;; (gv-letplace (getter setter) place | |
256 | ;; `(if (member ,v ,getter) nil | |
257 | ;; ,(funcall setter `(cons ,v ,getter)))))) | |
258 | ||
259 | ;; (defmacro gv-inc! (place &optional val) | |
260 | ;; "Increment PLACE by VAL (default to 1)." | |
261 | ;; (declare (debug (gv-place &optional form))) | |
262 | ;; (gv-letplace (getter setter) place | |
263 | ;; (funcall setter `(+ ,getter ,(or val 1))))) | |
264 | ||
265 | ;; (defmacro gv-dec! (place &optional val) | |
266 | ;; "Decrement PLACE by VAL (default to 1)." | |
267 | ;; (declare (debug (gv-place &optional form))) | |
268 | ;; (gv-letplace (getter setter) place | |
269 | ;; (funcall setter `(- ,getter ,(or val 1))))) | |
2ee3d7f0 SM |
270 | |
271 | ;; For Edebug, the idea is to let Edebug instrument gv-places just like it does | |
272 | ;; for normal expressions, and then give it a gv-expander to DTRT. | |
273 | ;; Maybe this should really be in edebug.el rather than here. | |
274 | ||
36cec983 SM |
275 | ;; Autoload this `put' since a user might use C-u C-M-x on an expression |
276 | ;; containing a non-trivial `push' even before gv.el was loaded. | |
277 | ;;;###autoload | |
2ee3d7f0 SM |
278 | (put 'gv-place 'edebug-form-spec 'edebug-match-form) |
279 | ;; CL did the equivalent of: | |
07b1a5fb | 280 | ;;(gv-define-macroexpand edebug-after (lambda (before index place) place)) |
2ee3d7f0 SM |
281 | |
282 | (put 'edebug-after 'gv-expander | |
283 | (lambda (do before index place) | |
284 | (gv-letplace (getter setter) place | |
285 | (funcall do `(edebug-after ,before ,index ,getter) | |
286 | setter)))) | |
287 | ||
288 | ;;; The common generalized variables. | |
289 | ||
290 | (gv-define-simple-setter aref aset) | |
291 | (gv-define-simple-setter car setcar) | |
292 | (gv-define-simple-setter cdr setcdr) | |
293 | ;; FIXME: add compiler-macros for `cXXr' instead! | |
294 | (gv-define-setter caar (val x) `(setcar (car ,x) ,val)) | |
295 | (gv-define-setter cadr (val x) `(setcar (cdr ,x) ,val)) | |
296 | (gv-define-setter cdar (val x) `(setcdr (car ,x) ,val)) | |
297 | (gv-define-setter cddr (val x) `(setcdr (cdr ,x) ,val)) | |
298 | (gv-define-setter elt (store seq n) | |
299 | `(if (listp ,seq) (setcar (nthcdr ,n ,seq) ,store) | |
300 | (aset ,seq ,n ,store))) | |
301 | (gv-define-simple-setter get put) | |
302 | (gv-define-setter gethash (val k h &optional _d) `(puthash ,k ,val ,h)) | |
303 | ||
304 | ;; (gv-define-expand nth (lambda (idx list) `(car (nthcdr ,idx ,list)))) | |
305 | (put 'nth 'gv-expander | |
306 | (lambda (do idx list) | |
307 | (macroexp-let2 nil c `(nthcdr ,idx ,list) | |
308 | (funcall do `(car ,c) (lambda (v) `(setcar ,c ,v)))))) | |
309 | (gv-define-simple-setter symbol-function fset) | |
310 | (gv-define-simple-setter symbol-plist setplist) | |
311 | (gv-define-simple-setter symbol-value set) | |
312 | ||
313 | (put 'nthcdr 'gv-expander | |
314 | (lambda (do n place) | |
315 | (macroexp-let2 nil idx n | |
316 | (gv-letplace (getter setter) place | |
317 | (funcall do `(nthcdr ,idx ,getter) | |
318 | (lambda (v) `(if (<= ,idx 0) ,(funcall setter v) | |
319 | (setcdr (nthcdr (1- ,idx) ,getter) ,v)))))))) | |
320 | ||
321 | ;;; Elisp-specific generalized variables. | |
322 | ||
323 | (gv-define-simple-setter default-value set-default) | |
324 | (gv-define-simple-setter frame-parameter set-frame-parameter 'fix) | |
325 | (gv-define-simple-setter terminal-parameter set-terminal-parameter) | |
326 | (gv-define-simple-setter keymap-parent set-keymap-parent) | |
327 | (gv-define-simple-setter match-data set-match-data 'fix) | |
328 | (gv-define-simple-setter overlay-get overlay-put) | |
329 | (gv-define-setter overlay-start (store ov) | |
330 | `(progn (move-overlay ,ov ,store (overlay-end ,ov)) ,store)) | |
331 | (gv-define-setter overlay-end (store ov) | |
332 | `(progn (move-overlay ,ov (overlay-start ,ov) ,store) ,store)) | |
333 | (gv-define-simple-setter process-buffer set-process-buffer) | |
334 | (gv-define-simple-setter process-filter set-process-filter) | |
335 | (gv-define-simple-setter process-sentinel set-process-sentinel) | |
336 | (gv-define-simple-setter process-get process-put) | |
337 | (gv-define-simple-setter window-buffer set-window-buffer) | |
338 | (gv-define-simple-setter window-display-table set-window-display-table 'fix) | |
339 | (gv-define-simple-setter window-dedicated-p set-window-dedicated-p) | |
340 | (gv-define-simple-setter window-hscroll set-window-hscroll) | |
341 | (gv-define-simple-setter window-parameter set-window-parameter) | |
342 | (gv-define-simple-setter window-point set-window-point) | |
343 | (gv-define-simple-setter window-start set-window-start) | |
344 | ||
345 | ;;; Some occasionally handy extensions. | |
346 | ||
347 | ;; While several of the "places" below are not terribly useful for direct use, | |
348 | ;; they can show up as the output of the macro expansion of reasonable places, | |
349 | ;; such as struct-accessors. | |
350 | ||
351 | (put 'progn 'gv-expander | |
352 | (lambda (do &rest exps) | |
353 | (let ((start (butlast exps)) | |
354 | (end (car (last exps)))) | |
355 | (if (null start) (gv-get end do) | |
356 | `(progn ,@start ,(gv-get end do)))))) | |
357 | ||
358 | (let ((let-expander | |
359 | (lambda (letsym) | |
360 | (lambda (do bindings &rest body) | |
361 | `(,letsym ,bindings | |
362 | ,@(macroexp-unprogn | |
363 | (gv-get (macroexp-progn body) do))))))) | |
364 | (put 'let 'gv-expander (funcall let-expander 'let)) | |
365 | (put 'let* 'gv-expander (funcall let-expander 'let*))) | |
366 | ||
367 | (put 'if 'gv-expander | |
368 | (lambda (do test then &rest else) | |
5046ef67 SM |
369 | (if (or (not lexical-binding) ;The other code requires lexical-binding. |
370 | (macroexp-small-p (funcall do 'dummy (lambda (_) 'dummy)))) | |
2519d43a SM |
371 | ;; This duplicates the `do' code, which is a problem if that |
372 | ;; code is large, but otherwise results in more efficient code. | |
373 | `(if ,test ,(gv-get then do) | |
374 | ,@(macroexp-unprogn (gv-get (macroexp-progn else) do))) | |
375 | (let ((v (make-symbol "v"))) | |
376 | (macroexp-let2 nil | |
377 | gv `(if ,test ,(gv-letplace (getter setter) then | |
378 | `(cons (lambda () ,getter) | |
379 | (lambda (,v) ,(funcall setter v)))) | |
380 | ,(gv-letplace (getter setter) (macroexp-progn else) | |
381 | `(cons (lambda () ,getter) | |
382 | (lambda (,v) ,(funcall setter v))))) | |
383 | (funcall do `(funcall (car ,gv)) | |
384 | (lambda (v) `(funcall (cdr ,gv) ,v)))))))) | |
385 | ||
386 | (put 'cond 'gv-expander | |
387 | (lambda (do &rest branches) | |
90eacf99 SM |
388 | (if (or (not lexical-binding) ;The other code requires lexical-binding. |
389 | (macroexp-small-p (funcall do 'dummy (lambda (_) 'dummy)))) | |
2519d43a SM |
390 | ;; This duplicates the `do' code, which is a problem if that |
391 | ;; code is large, but otherwise results in more efficient code. | |
392 | `(cond | |
393 | ,@(mapcar (lambda (branch) | |
394 | (if (cdr branch) | |
395 | (cons (car branch) | |
396 | (macroexp-unprogn | |
397 | (gv-get (macroexp-progn (cdr branch)) do))) | |
398 | (gv-get (car branch) do))) | |
399 | branches)) | |
400 | (let ((v (make-symbol "v"))) | |
401 | (macroexp-let2 nil | |
402 | gv `(cond | |
403 | ,@(mapcar | |
404 | (lambda (branch) | |
405 | (if (cdr branch) | |
406 | `(,(car branch) | |
407 | ,@(macroexp-unprogn | |
408 | (gv-letplace (getter setter) | |
409 | (macroexp-progn (cdr branch)) | |
410 | `(cons (lambda () ,getter) | |
411 | (lambda (,v) ,(funcall setter v)))))) | |
412 | (gv-letplace (getter setter) | |
413 | (car branch) | |
414 | `(cons (lambda () ,getter) | |
415 | (lambda (,v) ,(funcall setter v)))))) | |
416 | branches)) | |
417 | (funcall do `(funcall (car ,gv)) | |
418 | (lambda (v) `(funcall (cdr ,gv) ,v)))))))) | |
2ee3d7f0 SM |
419 | |
420 | ;;; Even more debatable extensions. | |
421 | ||
422 | (put 'cons 'gv-expander | |
423 | (lambda (do a d) | |
424 | (gv-letplace (agetter asetter) a | |
425 | (gv-letplace (dgetter dsetter) d | |
426 | (funcall do | |
427 | `(cons ,agetter ,dgetter) | |
428 | (lambda (v) `(progn | |
429 | ,(funcall asetter `(car ,v)) | |
430 | ,(funcall dsetter `(cdr ,v))))))))) | |
431 | ||
432 | (put 'logand 'gv-expander | |
433 | (lambda (do place &rest masks) | |
434 | (gv-letplace (getter setter) place | |
435 | (macroexp-let2 macroexp-copyable-p | |
436 | mask (if (cdr masks) `(logand ,@masks) (car masks)) | |
437 | (funcall | |
438 | do `(logand ,getter ,mask) | |
439 | (lambda (v) | |
440 | (funcall setter | |
441 | `(logior (logand ,v ,mask) | |
442 | (logand ,getter (lognot ,mask)))))))))) | |
443 | ||
d14bb752 SM |
444 | ;;; References |
445 | ||
446 | ;;;###autoload | |
447 | (defmacro gv-ref (place) | |
448 | "Return a reference to PLACE. | |
449 | This is like the `&' operator of the C language." | |
450 | (gv-letplace (getter setter) place | |
451 | `(cons (lambda () ,getter) | |
452 | (lambda (gv--val) ,(funcall setter 'gv--val))))) | |
453 | ||
d14bb752 SM |
454 | (defsubst gv-deref (ref) |
455 | "Dereference REF, returning the referenced value. | |
456 | This is like the `*' operator of the C language. | |
457 | REF must have been previously obtained with `gv-ref'." | |
d14bb752 | 458 | (funcall (car ref))) |
a9a5c7f6 SM |
459 | ;; Don't use `declare' because it seems to introduce circularity problems: |
460 | ;; Warning: Eager macro-expansion skipped due to cycle: | |
461 | ;; … => (load "gv.el") => (macroexpand-all (defsubst gv-deref …)) => (macroexpand (defun …)) => (load "gv.el") | |
462 | (gv-define-setter gv-deref (v ref) `(funcall (cdr ,ref) ,v)) | |
d14bb752 | 463 | |
2ee3d7f0 SM |
464 | ;;; Vaguely related definitions that should be moved elsewhere. |
465 | ||
466 | ;; (defun alist-get (key alist) | |
467 | ;; "Get the value associated to KEY in ALIST." | |
468 | ;; (declare | |
469 | ;; (gv-expander | |
470 | ;; (lambda (do) | |
471 | ;; (macroexp-let2 macroexp-copyable-p k key | |
472 | ;; (gv-letplace (getter setter) alist | |
473 | ;; (macroexp-let2 nil p `(assoc ,k ,getter) | |
474 | ;; (funcall do `(cdr ,p) | |
475 | ;; (lambda (v) | |
476 | ;; `(if ,p (setcdr ,p ,v) | |
477 | ;; ,(funcall setter | |
478 | ;; `(cons (cons ,k ,v) ,getter))))))))))) | |
479 | ;; (cdr (assoc key alist))) | |
480 | ||
481 | (provide 'gv) | |
482 | ;;; gv.el ends here |