lisp/emacs-lisp/gv.el

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