| 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 | ;; Package: emacs |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 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 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 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 |
| 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 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 | |
| 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)) |
| 90 | (gf (function-get head 'gv-expander 'autoload))) |
| 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 |
| 114 | and new expression that sets PLACE to V. |
| 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 | |
| 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)))) |
| 156 | |
| 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) |
| 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. |
| 197 | The first arg in ARLIST (the one that receives VAL) receives an expression |
| 198 | which can do arbitrary things, whereas the other arguments are all guaranteed |
| 199 | to be pure and copyable. Example use: |
| 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). |
| 212 | If FIX-RETURN is non-nil, then SETTER is not assumed to return VAL and |
| 213 | instead the assignment is turned into (prog1 VAL (SETTER ARGS... VAL)) |
| 214 | so as to preserve the semantics of `setf'." |
| 215 | (declare (debug (sexp (&or symbolp lambda-expr) &optional sexp))) |
| 216 | (let ((set-call `(cons ',setter (append args (list val))))) |
| 217 | `(gv-define-setter ,name (val &rest args) |
| 218 | ,(if fix-return `(list 'prog1 val ,set-call) set-call)))) |
| 219 | |
| 220 | ;;; Typical operations on generalized variables. |
| 221 | |
| 222 | ;;;###autoload |
| 223 | (defmacro setf (&rest args) |
| 224 | "Set each PLACE to the value of its VAL. |
| 225 | This is a generalized version of `setq'; the PLACEs may be symbolic |
| 226 | references such as (car x) or (aref x i), as well as plain symbols. |
| 227 | For example, (setf (cadr x) y) is equivalent to (setcar (cdr x) y). |
| 228 | The return value is the last VAL in the list. |
| 229 | |
| 230 | \(fn PLACE VAL PLACE VAL ...)" |
| 231 | (declare (debug (gv-place form))) |
| 232 | (if (and args (null (cddr args))) |
| 233 | (let ((place (pop args)) |
| 234 | (val (car args))) |
| 235 | (gv-letplace (_getter setter) place |
| 236 | (funcall setter val))) |
| 237 | (let ((sets nil)) |
| 238 | (while args (push `(setf ,(pop args) ,(pop args)) sets)) |
| 239 | (cons 'progn (nreverse sets))))) |
| 240 | |
| 241 | ;; (defmacro gv-pushnew! (val place) |
| 242 | ;; "Like `gv-push!' but only adds VAL if it's not yet in PLACE. |
| 243 | ;; Presence is checked with `member'. |
| 244 | ;; The return value is unspecified." |
| 245 | ;; (declare (debug (form gv-place))) |
| 246 | ;; (macroexp-let2 macroexp-copyable-p v val |
| 247 | ;; (gv-letplace (getter setter) place |
| 248 | ;; `(if (member ,v ,getter) nil |
| 249 | ;; ,(funcall setter `(cons ,v ,getter)))))) |
| 250 | |
| 251 | ;; (defmacro gv-inc! (place &optional val) |
| 252 | ;; "Increment PLACE by VAL (default to 1)." |
| 253 | ;; (declare (debug (gv-place &optional form))) |
| 254 | ;; (gv-letplace (getter setter) place |
| 255 | ;; (funcall setter `(+ ,getter ,(or val 1))))) |
| 256 | |
| 257 | ;; (defmacro gv-dec! (place &optional val) |
| 258 | ;; "Decrement PLACE by VAL (default to 1)." |
| 259 | ;; (declare (debug (gv-place &optional form))) |
| 260 | ;; (gv-letplace (getter setter) place |
| 261 | ;; (funcall setter `(- ,getter ,(or val 1))))) |
| 262 | |
| 263 | ;; For Edebug, the idea is to let Edebug instrument gv-places just like it does |
| 264 | ;; for normal expressions, and then give it a gv-expander to DTRT. |
| 265 | ;; Maybe this should really be in edebug.el rather than here. |
| 266 | |
| 267 | ;; Autoload this `put' since a user might use C-u C-M-x on an expression |
| 268 | ;; containing a non-trivial `push' even before gv.el was loaded. |
| 269 | ;;;###autoload |
| 270 | (put 'gv-place 'edebug-form-spec 'edebug-match-form) |
| 271 | ;; CL did the equivalent of: |
| 272 | ;;(gv-define-macroexpand edebug-after (lambda (before index place) place)) |
| 273 | |
| 274 | (put 'edebug-after 'gv-expander |
| 275 | (lambda (do before index place) |
| 276 | (gv-letplace (getter setter) place |
| 277 | (funcall do `(edebug-after ,before ,index ,getter) |
| 278 | setter)))) |
| 279 | |
| 280 | ;;; The common generalized variables. |
| 281 | |
| 282 | (gv-define-simple-setter aref aset) |
| 283 | (gv-define-simple-setter car setcar) |
| 284 | (gv-define-simple-setter cdr setcdr) |
| 285 | ;; FIXME: add compiler-macros for `cXXr' instead! |
| 286 | (gv-define-setter caar (val x) `(setcar (car ,x) ,val)) |
| 287 | (gv-define-setter cadr (val x) `(setcar (cdr ,x) ,val)) |
| 288 | (gv-define-setter cdar (val x) `(setcdr (car ,x) ,val)) |
| 289 | (gv-define-setter cddr (val x) `(setcdr (cdr ,x) ,val)) |
| 290 | (gv-define-setter elt (store seq n) |
| 291 | `(if (listp ,seq) (setcar (nthcdr ,n ,seq) ,store) |
| 292 | (aset ,seq ,n ,store))) |
| 293 | (gv-define-simple-setter get put) |
| 294 | (gv-define-setter gethash (val k h &optional _d) `(puthash ,k ,val ,h)) |
| 295 | |
| 296 | ;; (gv-define-expand nth (lambda (idx list) `(car (nthcdr ,idx ,list)))) |
| 297 | (put 'nth 'gv-expander |
| 298 | (lambda (do idx list) |
| 299 | (macroexp-let2 nil c `(nthcdr ,idx ,list) |
| 300 | (funcall do `(car ,c) (lambda (v) `(setcar ,c ,v)))))) |
| 301 | (gv-define-simple-setter symbol-function fset) |
| 302 | (gv-define-simple-setter symbol-plist setplist) |
| 303 | (gv-define-simple-setter symbol-value set) |
| 304 | |
| 305 | (put 'nthcdr 'gv-expander |
| 306 | (lambda (do n place) |
| 307 | (macroexp-let2 nil idx n |
| 308 | (gv-letplace (getter setter) place |
| 309 | (funcall do `(nthcdr ,idx ,getter) |
| 310 | (lambda (v) `(if (<= ,idx 0) ,(funcall setter v) |
| 311 | (setcdr (nthcdr (1- ,idx) ,getter) ,v)))))))) |
| 312 | |
| 313 | ;;; Elisp-specific generalized variables. |
| 314 | |
| 315 | (gv-define-simple-setter default-value set-default) |
| 316 | (gv-define-simple-setter frame-parameter set-frame-parameter 'fix) |
| 317 | (gv-define-simple-setter terminal-parameter set-terminal-parameter) |
| 318 | (gv-define-simple-setter keymap-parent set-keymap-parent) |
| 319 | (gv-define-simple-setter match-data set-match-data 'fix) |
| 320 | (gv-define-simple-setter overlay-get overlay-put) |
| 321 | (gv-define-setter overlay-start (store ov) |
| 322 | `(progn (move-overlay ,ov ,store (overlay-end ,ov)) ,store)) |
| 323 | (gv-define-setter overlay-end (store ov) |
| 324 | `(progn (move-overlay ,ov (overlay-start ,ov) ,store) ,store)) |
| 325 | (gv-define-simple-setter process-buffer set-process-buffer) |
| 326 | (gv-define-simple-setter process-filter set-process-filter) |
| 327 | (gv-define-simple-setter process-sentinel set-process-sentinel) |
| 328 | (gv-define-simple-setter process-get process-put) |
| 329 | (gv-define-simple-setter window-buffer set-window-buffer) |
| 330 | (gv-define-simple-setter window-display-table set-window-display-table 'fix) |
| 331 | (gv-define-simple-setter window-dedicated-p set-window-dedicated-p) |
| 332 | (gv-define-simple-setter window-hscroll set-window-hscroll) |
| 333 | (gv-define-simple-setter window-parameter set-window-parameter) |
| 334 | (gv-define-simple-setter window-point set-window-point) |
| 335 | (gv-define-simple-setter window-start set-window-start) |
| 336 | |
| 337 | ;;; Some occasionally handy extensions. |
| 338 | |
| 339 | ;; While several of the "places" below are not terribly useful for direct use, |
| 340 | ;; they can show up as the output of the macro expansion of reasonable places, |
| 341 | ;; such as struct-accessors. |
| 342 | |
| 343 | (put 'progn 'gv-expander |
| 344 | (lambda (do &rest exps) |
| 345 | (let ((start (butlast exps)) |
| 346 | (end (car (last exps)))) |
| 347 | (if (null start) (gv-get end do) |
| 348 | `(progn ,@start ,(gv-get end do)))))) |
| 349 | |
| 350 | (let ((let-expander |
| 351 | (lambda (letsym) |
| 352 | (lambda (do bindings &rest body) |
| 353 | `(,letsym ,bindings |
| 354 | ,@(macroexp-unprogn |
| 355 | (gv-get (macroexp-progn body) do))))))) |
| 356 | (put 'let 'gv-expander (funcall let-expander 'let)) |
| 357 | (put 'let* 'gv-expander (funcall let-expander 'let*))) |
| 358 | |
| 359 | (put 'if 'gv-expander |
| 360 | (lambda (do test then &rest else) |
| 361 | (if (or (not lexical-binding) ;The other code requires lexical-binding. |
| 362 | (macroexp-small-p (funcall do 'dummy (lambda (_) 'dummy)))) |
| 363 | ;; This duplicates the `do' code, which is a problem if that |
| 364 | ;; code is large, but otherwise results in more efficient code. |
| 365 | `(if ,test ,(gv-get then do) |
| 366 | ,@(macroexp-unprogn (gv-get (macroexp-progn else) do))) |
| 367 | (let ((v (make-symbol "v"))) |
| 368 | (macroexp-let2 nil |
| 369 | gv `(if ,test ,(gv-letplace (getter setter) then |
| 370 | `(cons (lambda () ,getter) |
| 371 | (lambda (,v) ,(funcall setter v)))) |
| 372 | ,(gv-letplace (getter setter) (macroexp-progn else) |
| 373 | `(cons (lambda () ,getter) |
| 374 | (lambda (,v) ,(funcall setter v))))) |
| 375 | (funcall do `(funcall (car ,gv)) |
| 376 | (lambda (v) `(funcall (cdr ,gv) ,v)))))))) |
| 377 | |
| 378 | (put 'cond 'gv-expander |
| 379 | (lambda (do &rest branches) |
| 380 | (if (or (not lexical-binding) ;The other code requires lexical-binding. |
| 381 | (macroexp-small-p (funcall do 'dummy (lambda (_) 'dummy)))) |
| 382 | ;; This duplicates the `do' code, which is a problem if that |
| 383 | ;; code is large, but otherwise results in more efficient code. |
| 384 | `(cond |
| 385 | ,@(mapcar (lambda (branch) |
| 386 | (if (cdr branch) |
| 387 | (cons (car branch) |
| 388 | (macroexp-unprogn |
| 389 | (gv-get (macroexp-progn (cdr branch)) do))) |
| 390 | (gv-get (car branch) do))) |
| 391 | branches)) |
| 392 | (let ((v (make-symbol "v"))) |
| 393 | (macroexp-let2 nil |
| 394 | gv `(cond |
| 395 | ,@(mapcar |
| 396 | (lambda (branch) |
| 397 | (if (cdr branch) |
| 398 | `(,(car branch) |
| 399 | ,@(macroexp-unprogn |
| 400 | (gv-letplace (getter setter) |
| 401 | (macroexp-progn (cdr branch)) |
| 402 | `(cons (lambda () ,getter) |
| 403 | (lambda (,v) ,(funcall setter v)))))) |
| 404 | (gv-letplace (getter setter) |
| 405 | (car branch) |
| 406 | `(cons (lambda () ,getter) |
| 407 | (lambda (,v) ,(funcall setter v)))))) |
| 408 | branches)) |
| 409 | (funcall do `(funcall (car ,gv)) |
| 410 | (lambda (v) `(funcall (cdr ,gv) ,v)))))))) |
| 411 | |
| 412 | ;;; Even more debatable extensions. |
| 413 | |
| 414 | (put 'cons 'gv-expander |
| 415 | (lambda (do a d) |
| 416 | (gv-letplace (agetter asetter) a |
| 417 | (gv-letplace (dgetter dsetter) d |
| 418 | (funcall do |
| 419 | `(cons ,agetter ,dgetter) |
| 420 | (lambda (v) `(progn |
| 421 | ,(funcall asetter `(car ,v)) |
| 422 | ,(funcall dsetter `(cdr ,v))))))))) |
| 423 | |
| 424 | (put 'logand 'gv-expander |
| 425 | (lambda (do place &rest masks) |
| 426 | (gv-letplace (getter setter) place |
| 427 | (macroexp-let2 macroexp-copyable-p |
| 428 | mask (if (cdr masks) `(logand ,@masks) (car masks)) |
| 429 | (funcall |
| 430 | do `(logand ,getter ,mask) |
| 431 | (lambda (v) |
| 432 | (funcall setter |
| 433 | `(logior (logand ,v ,mask) |
| 434 | (logand ,getter (lognot ,mask)))))))))) |
| 435 | |
| 436 | ;;; References |
| 437 | |
| 438 | ;;;###autoload |
| 439 | (defmacro gv-ref (place) |
| 440 | "Return a reference to PLACE. |
| 441 | This is like the `&' operator of the C language." |
| 442 | (gv-letplace (getter setter) place |
| 443 | `(cons (lambda () ,getter) |
| 444 | (lambda (gv--val) ,(funcall setter 'gv--val))))) |
| 445 | |
| 446 | ;;;###autoload |
| 447 | (defsubst gv-deref (ref) |
| 448 | "Dereference REF, returning the referenced value. |
| 449 | This is like the `*' operator of the C language. |
| 450 | REF must have been previously obtained with `gv-ref'." |
| 451 | (declare (gv-setter (lambda (v) `(funcall (cdr ,ref) ,v)))) |
| 452 | (funcall (car ref))) |
| 453 | |
| 454 | ;;; Vaguely related definitions that should be moved elsewhere. |
| 455 | |
| 456 | ;; (defun alist-get (key alist) |
| 457 | ;; "Get the value associated to KEY in ALIST." |
| 458 | ;; (declare |
| 459 | ;; (gv-expander |
| 460 | ;; (lambda (do) |
| 461 | ;; (macroexp-let2 macroexp-copyable-p k key |
| 462 | ;; (gv-letplace (getter setter) alist |
| 463 | ;; (macroexp-let2 nil p `(assoc ,k ,getter) |
| 464 | ;; (funcall do `(cdr ,p) |
| 465 | ;; (lambda (v) |
| 466 | ;; `(if ,p (setcdr ,p ,v) |
| 467 | ;; ,(funcall setter |
| 468 | ;; `(cons (cons ,k ,v) ,getter))))))))))) |
| 469 | ;; (cdr (assoc key alist))) |
| 470 | |
| 471 | (provide 'gv) |
| 472 | ;;; gv.el ends here |