diff options
Diffstat (limited to 'lisp/emacs-lisp/gv.el')
| -rw-r--r-- | lisp/emacs-lisp/gv.el | 166 |
1 files changed, 153 insertions, 13 deletions
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index c9eac70d8f3..d6272a52469 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -135,7 +135,7 @@ The returned value will then be an Elisp expression that first evaluates all the parts of PLACE that can be evaluated and then runs E. \(fn (GETTER SETTER) PLACE &rest BODY)" - (declare (indent 2) (debug (sexp form body))) + (declare (indent 2) (debug (sexp form def-body))) `(gv-get ,place (lambda ,vars ,@body))) ;; Different ways to declare a generalized variable. @@ -166,17 +166,34 @@ arguments as NAME. DO is a function as defined in `gv-get'." ;; (`(expand ,expander) `(gv-define-expand ,name ,expander)) (_ (message "Unknown %s declaration %S" symbol handler) nil)))) +;; Additions for `declare'. We specify the values as named aliases so +;; that `describe-variable' prints something useful; cf. Bug#40491. + +;;;###autoload +(defsubst gv--expander-defun-declaration (&rest args) + (apply #'gv--defun-declaration 'gv-expander args)) + +;;;###autoload +(defsubst gv--setter-defun-declaration (&rest args) + (apply #'gv--defun-declaration 'gv-setter args)) + ;;;###autoload (or (assq 'gv-expander defun-declarations-alist) - (let ((x `(gv-expander - ,(apply-partially #'gv--defun-declaration 'gv-expander)))) + (let ((x (list 'gv-expander #'gv--expander-defun-declaration))) (push x macro-declarations-alist) (push x defun-declarations-alist))) ;;;###autoload (or (assq 'gv-setter defun-declarations-alist) - (push `(gv-setter ,(apply-partially #'gv--defun-declaration 'gv-setter)) + (push (list 'gv-setter #'gv--setter-defun-declaration) defun-declarations-alist)) +;;;###autoload +(let ((spec (get 'compiler-macro 'edebug-declaration-spec))) + ;; It so happens that it's the same spec for gv-* as for compiler-macros. + ;; '(&or symbolp ("lambda" &define lambda-list lambda-doc def-body)) + (put 'gv-expander 'edebug-declaration-spec spec) + (put 'gv-setter 'edebug-declaration-spec spec)) + ;; (defmacro gv-define-expand (name expander) ;; "Use EXPANDER to handle NAME as a generalized var. ;; NAME is a symbol: the name of a function, macro, or special form. @@ -214,7 +231,8 @@ The first arg in ARGLIST (the one that receives VAL) receives an expression which can do arbitrary things, whereas the other arguments are all guaranteed to be pure and copyable. Example use: (gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))" - (declare (indent 2) (debug (&define name sexp def-body))) + (declare (indent 2) + (debug (&define [&name symbolp "@gv-setter"] sexp def-body))) `(gv-define-expander ,name (lambda (do &rest args) (declare-function @@ -297,7 +315,7 @@ The return value is the last VAL in the list. ;; Autoload this `put' since a user might use C-u C-M-x on an expression ;; containing a non-trivial `push' even before gv.el was loaded. ;;;###autoload -(put 'gv-place 'edebug-form-spec 'edebug-match-form) +(def-edebug-elem-spec 'gv-place '(form)) ;; CL did the equivalent of: ;;(gv-define-macroexpand edebug-after (lambda (before index place) place)) @@ -406,6 +424,17 @@ The return value is the last VAL in the list. `(delq ,p ,getter)))))) ,v)))))))))) +(gv-define-expander plist-get + (lambda (do plist prop) + (macroexp-let2 macroexp-copyable-p key prop + (gv-letplace (getter setter) plist + (macroexp-let2 nil p `(cdr (plist-member ,getter ,key)) + (funcall do + `(car ,p) + (lambda (val) + `(if ,p + (setcar ,p ,val) + ,(funcall setter `(cons ,key (cons ,val ,getter))))))))))) ;;; Some occasionally handy extensions. @@ -482,6 +511,11 @@ The return value is the last VAL in the list. (funcall do `(funcall (car ,gv)) (lambda (v) `(funcall (cdr ,gv) ,v)))))))) +(put 'error 'gv-expander + (lambda (do &rest args) + (funcall do `(error . ,args) + (lambda (v) `(progn ,v (error . ,args)))))) + (defmacro gv-synthetic-place (getter setter) "Special place described by its setter and getter. GETTER and SETTER (typically obtained via `gv-letplace') get and @@ -516,9 +550,12 @@ This macro only makes sense when used in a place." (gv-letplace (dgetter dsetter) d (funcall do `(cons ,agetter ,dgetter) - (lambda (v) `(progn - ,(funcall asetter `(car ,v)) - ,(funcall dsetter `(cdr ,v))))))))) + (lambda (v) + (macroexp-let2 nil v v + `(progn + ,(funcall asetter `(car ,v)) + ,(funcall dsetter `(cdr ,v)) + ,v)))))))) (put 'logand 'gv-expander (lambda (do place &rest masks) @@ -528,9 +565,12 @@ This macro only makes sense when used in a place." (funcall do `(logand ,getter ,mask) (lambda (v) - (funcall setter - `(logior (logand ,v ,mask) - (logand ,getter (lognot ,mask)))))))))) + (macroexp-let2 nil v v + `(progn + ,(funcall setter + `(logior (logand ,v ,mask) + (logand ,getter (lognot ,mask)))) + ,v)))))))) ;;; References @@ -552,7 +592,7 @@ binding mode." ;; dynamic binding mode as well. (eq (car-safe code) 'cons)) code - (macroexp--warn-and-return + (macroexp-warn-and-return "Use of gv-ref probably requires lexical-binding" code)))) @@ -574,5 +614,105 @@ REF must have been previously obtained with `gv-ref'." ;; (,(nth 1 vars) (v) (funcall ',setter v))) ;; ,@body))) +;;; Generalized variables. + +;; Some Emacs-related place types. +(gv-define-simple-setter buffer-file-name set-visited-file-name t) +(gv-define-setter buffer-modified-p (flag &optional buf) + (macroexp-let2 nil buffer `(or ,buf (current-buffer)) + `(with-current-buffer ,buffer + (set-buffer-modified-p ,flag)))) +(gv-define-simple-setter buffer-name rename-buffer t) +(gv-define-setter buffer-string (store) + `(insert (prog1 ,store (erase-buffer)))) +(gv-define-simple-setter buffer-substring cl--set-buffer-substring) +(gv-define-simple-setter current-buffer set-buffer) +(gv-define-simple-setter current-column move-to-column t) +(gv-define-simple-setter current-global-map use-global-map t) +(gv-define-setter current-input-mode (store) + `(progn (apply #'set-input-mode ,store) ,store)) +(gv-define-simple-setter current-local-map use-local-map t) +(gv-define-simple-setter current-window-configuration + set-window-configuration t) +(gv-define-simple-setter default-file-modes set-default-file-modes t) +(gv-define-simple-setter documentation-property put) +(gv-define-setter face-background (x f &optional s) + `(set-face-background ,f ,x ,s)) +(gv-define-setter face-background-pixmap (x f &optional s) + `(set-face-background-pixmap ,f ,x ,s)) +(gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s)) +(gv-define-setter face-foreground (x f &optional s) + `(set-face-foreground ,f ,x ,s)) +(gv-define-setter face-underline-p (x f &optional s) + `(set-face-underline ,f ,x ,s)) +(gv-define-simple-setter file-modes set-file-modes t) +(gv-define-setter frame-height (x &optional frame) + `(set-frame-height (or ,frame (selected-frame)) ,x)) +(gv-define-simple-setter frame-parameters modify-frame-parameters t) +(gv-define-simple-setter frame-visible-p cl--set-frame-visible-p) +(gv-define-setter frame-width (x &optional frame) + `(set-frame-width (or ,frame (selected-frame)) ,x)) +(gv-define-simple-setter getenv setenv t) +(gv-define-simple-setter get-register set-register) +(gv-define-simple-setter global-key-binding global-set-key) +(gv-define-simple-setter local-key-binding local-set-key) +(gv-define-simple-setter mark set-mark t) +(gv-define-simple-setter mark-marker set-mark t) +(gv-define-simple-setter marker-position set-marker t) +(gv-define-setter mouse-position (store scr) + `(set-mouse-position ,scr (car ,store) (cadr ,store) + (cddr ,store))) +(gv-define-simple-setter point goto-char) +(gv-define-simple-setter point-marker goto-char t) +(gv-define-setter point-max (store) + `(progn (narrow-to-region (point-min) ,store) ,store)) +(gv-define-setter point-min (store) + `(progn (narrow-to-region ,store (point-max)) ,store)) +(gv-define-setter read-mouse-position (store scr) + `(set-mouse-position ,scr (car ,store) (cdr ,store))) +(gv-define-simple-setter screen-height set-screen-height t) +(gv-define-simple-setter screen-width set-screen-width t) +(gv-define-simple-setter selected-window select-window) +(gv-define-simple-setter selected-screen select-screen) +(gv-define-simple-setter selected-frame select-frame) +(gv-define-simple-setter standard-case-table set-standard-case-table) +(gv-define-simple-setter syntax-table set-syntax-table) +(gv-define-simple-setter visited-file-modtime set-visited-file-modtime t) +(gv-define-setter window-height (store) + `(progn (enlarge-window (- ,store (window-height))) ,store)) +(gv-define-setter window-width (store) + `(progn (enlarge-window (- ,store (window-width)) t) ,store)) +(gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t) + +;; More complex setf-methods. + +;; This is a hack that allows (setf (eq a 7) B) to mean either +;; (setq a 7) or (setq a nil) depending on whether B is nil or not. +;; This is useful when you have control over the PLACE but not over +;; the VALUE, as is the case in define-minor-mode's :variable. +;; It turned out that :variable needed more flexibility anyway, so +;; this doesn't seem too useful now. +(gv-define-expander eq + (lambda (do place val) + (gv-letplace (getter setter) place + (macroexp-let2 nil val val + (funcall do `(eq ,getter ,val) + (lambda (v) + `(cond + (,v ,(funcall setter val)) + ((eq ,getter ,val) ,(funcall setter `(not ,val)))))))))) + +(gv-define-expander substring + (lambda (do place from &optional to) + (gv-letplace (getter setter) place + (macroexp-let2* nil ((start from) (end to)) + (funcall do `(substring ,getter ,start ,end) + (lambda (v) + (macroexp-let2 nil v v + `(progn + ,(funcall setter `(cl--set-substring + ,getter ,start ,end ,v)) + ,v)))))))) + (provide 'gv) ;;; gv.el ends here |