From: Stefan Monnier <monnier@iro.umontreal.ca>
Date: Wed, 1 Oct 2014 17:23:42 +0000 (-0400)
Subject: * lisp/subr.el (alist-get): New accessor.
X-Git-Tag: emacs-25.0.90~2635^2~679^2~171
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=a57fa9642d4953dd6b249f563776e8e9ed60ced5;p=emacs.git
* lisp/subr.el (alist-get): New accessor.
* lisp/emacs-lisp/gv.el (alist-get): Provide expander.
* lisp/winner.el (winner-remember):
* lisp/tempo.el (tempo-use-tag-list):
* lisp/progmodes/gud.el (minor-mode-map-alist):
* lisp/international/mule-cmds.el (define-char-code-property):
* lisp/frameset.el (frameset-filter-params):
* lisp/files.el (dir-locals-set-class-variables):
* lisp/register.el (get-register, set-register):
* lisp/calc/calc-yank.el (calc-set-register): Use it.
* lisp/ps-print.el (ps-get, ps-put, ps-del): Mark as obsolete.
* lisp/tooltip.el (tooltip-set-param): Mark as obsolete.
(tooltip-show): Use alist-get instead.
* lisp/ses.el (ses--alist-get): Remove. Use alist-get instead.
* admin/unidata/unidata-gen.el (unidata-gen-table-word-list): Use alist-get
and cl-incf.
---
diff --git a/admin/ChangeLog b/admin/ChangeLog
index 4ebf97d3163..cd5f08989fc 100644
--- a/admin/ChangeLog
+++ b/admin/ChangeLog
@@ -1,3 +1,8 @@
+2014-10-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * unidata/unidata-gen.el (unidata-gen-table-word-list): Use alist-get
+ and cl-incf.
+
2014-09-08 Eli Zaretskii <eliz@gnu.org>
* unidata/unidata-gen.el (unidata-check): Bring this function up
diff --git a/admin/unidata/unidata-gen.el b/admin/unidata/unidata-gen.el
index fb9b6dccc72..ec4f9d154d2 100644
--- a/admin/unidata/unidata-gen.el
+++ b/admin/unidata/unidata-gen.el
@@ -88,6 +88,8 @@
;; CHAR-or-RANGE: a character code or a cons of character codes
;; PROPn: string representing the nth property value
+(eval-when-compile (require 'cl-lib))
+
(defvar unidata-list nil)
;; Name of the directory containing files of Unicode Character Database.
@@ -923,11 +925,7 @@ is the character itself.")))
(dotimes (i (length vec))
(dolist (elt (aref vec i))
(if (symbolp elt)
- (let ((slot (assq elt word-list)))
- (if slot
- (setcdr slot (1+ (cdr slot)))
- (setcdr word-list
- (cons (cons elt 1) (cdr word-list))))))))
+ (cl-incf (alist-get elt (cdr word-list) 0)))))
(set-char-table-range table (cons start limit) vec))))))
(setq word-list (sort (cdr word-list)
#'(lambda (x y) (> (cdr x) (cdr y)))))
diff --git a/etc/NEWS b/etc/NEWS
index 59842fa7eee..8c2b64b14fc 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -245,6 +245,8 @@ Emacs-21.
*** call-process-shell-command and process-file-shell-command
don't take "&rest args" any more.
+** New function `alist-get', which is also a valid place (aka lvalue).
+
** New function `funcall-interactively', which works like `funcall'
but makes `called-interactively-p' treat the function as (you guessed it)
called interactively.
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index b1e510b6f7d..ea8587e40a4 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,20 @@
+2014-10-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (alist-get): New accessor.
+ * emacs-lisp/gv.el (alist-get): Provide expander.
+ * winner.el (winner-remember):
+ * tempo.el (tempo-use-tag-list):
+ * progmodes/gud.el (minor-mode-map-alist):
+ * international/mule-cmds.el (define-char-code-property):
+ * frameset.el (frameset-filter-params):
+ * files.el (dir-locals-set-class-variables):
+ * register.el (get-register, set-register):
+ * calc/calc-yank.el (calc-set-register): Use it.
+ * ps-print.el (ps-get, ps-put, ps-del): Mark as obsolete.
+ * tooltip.el (tooltip-set-param): Mark as obsolete.
+ (tooltip-show): Use alist-get instead.
+ * ses.el (ses--alist-get): Remove. Use alist-get instead.
+
2014-10-01 Ulf Jasper <ulf.jasper@web.de>
* net/newst-backend.el: Remove Time-stamp. Rename variable
@@ -5,8 +22,8 @@
make it customizable.
(newsticker--sentinel-work): Move xml-workarounds to function
`newsticker--do-xml-workarounds', call unless libxml-parser is
- used. Allow single quote in regexp for encoding. Use
- libxml-parser if available, else fall back to `xml-parse-region'.
+ used. Allow single quote in regexp for encoding.
+ Use libxml-parser if available, else fall back to `xml-parse-region'.
Take care of possibly missing namespace prefixes (like "RDF"
instead of "rdf:RDF") when checking xml nodes and attributes (as
libxml correctly removes the prefixes). Always use Atom 1.0 as
diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el
index 30a06a2aa00..156bf4cd0db 100644
--- a/lisp/calc/calc-prog.el
+++ b/lisp/calc/calc-prog.el
@@ -139,6 +139,7 @@
"calc-"))))
(let* ((kmap (calc-user-key-map))
(old (assq key kmap)))
+ ;; FIXME: Why not (define-key kmap (vector key) func)?
(if old
(setcdr old func)
(setcdr kmap (cons (cons key func) (cdr kmap))))))))
@@ -322,6 +323,7 @@
(if key
(let* ((kmap (calc-user-key-map))
(old (assq key kmap)))
+ ;; FIXME: Why not (define-key kmap (vector key) cmd)?
(if old
(setcdr old cmd)
(setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
@@ -467,6 +469,7 @@
(format "z%c" key)))))
(let* ((kmap (calc-user-key-map))
(old (assq key kmap)))
+ ;; FIXME: Why not (define-key kmap (vector key) func)?
(if old
(setcdr old cmd)
(setcdr kmap (cons (cons key cmd) (cdr kmap))))))))
diff --git a/lisp/calc/calc-yank.el b/lisp/calc/calc-yank.el
index 8d182372cfb..9781d4174f5 100644
--- a/lisp/calc/calc-yank.el
+++ b/lisp/calc/calc-yank.el
@@ -143,10 +143,7 @@ TEXT and CALCVAL are the TEXT and internal structure of stack entries.")
"Set the contents of the Calc register REGISTER to (TEXT . CALCVAL),
as well as set the contents of the Emacs register REGISTER to TEXT."
(set-register register text)
- (let ((aelt (assq register calc-register-alist)))
- (if aelt
- (setcdr aelt (cons text calcval))
- (push (cons register (cons text calcval)) calc-register-alist))))
+ (setf (alist-get register calc-register-alist) (cons text calcval)))
(defun calc-get-register (reg)
"Return the CALCVAL portion of the contents of the Calc register REG,
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index 692b76e8a36..229ad275bf5 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -357,6 +357,34 @@ The return value is the last VAL in the list.
(macroexp-let2 nil v val
`(with-current-buffer ,buf (set (make-local-variable ,var) ,v))))
+(gv-define-expander alist-get
+ (lambda (do key alist &optional default remove)
+ (macroexp-let2 macroexp-copyable-p k key
+ (gv-letplace (getter setter) alist
+ (macroexp-let2 nil p `(assq ,k ,getter)
+ (funcall do (if (null default) `(cdr ,p)
+ `(if ,p (cdr ,p) ,default))
+ (lambda (v)
+ (macroexp-let2 nil v v
+ (let ((set-exp
+ `(if ,p (setcdr ,p ,v)
+ ,(funcall setter
+ `(cons (setq ,p (cons ,k ,v))
+ ,getter)))))
+ (cond
+ ((null remove) set-exp)
+ ((or (eql v default)
+ (and (eq (car-safe v) 'quote)
+ (eq (car-safe default) 'quote)
+ (eql (cadr v) (cadr default))))
+ `(if ,p ,(funcall setter `(delq ,p ,getter))))
+ (t
+ `(cond
+ ((not (eql ,default ,v)) ,set-exp)
+ (,p ,(funcall setter
+ `(delq ,p ,getter)))))))))))))))
+
+
;;; Some occasionally handy extensions.
;; While several of the "places" below are not terribly useful for direct use,
@@ -479,22 +507,13 @@ REF must have been previously obtained with `gv-ref'."
;; ⦠=> (load "gv.el") => (macroexpand-all (defsubst gv-deref â¦)) => (macroexpand (defun â¦)) => (load "gv.el")
(gv-define-setter gv-deref (v ref) `(funcall (cdr ,ref) ,v))
-;;; Vaguely related definitions that should be moved elsewhere.
-
-;; (defun alist-get (key alist)
-;; "Get the value associated to KEY in ALIST."
-;; (declare
-;; (gv-expander
-;; (lambda (do)
-;; (macroexp-let2 macroexp-copyable-p k key
-;; (gv-letplace (getter setter) alist
-;; (macroexp-let2 nil p `(assoc ,k ,getter)
-;; (funcall do `(cdr ,p)
-;; (lambda (v)
-;; `(if ,p (setcdr ,p ,v)
-;; ,(funcall setter
-;; `(cons (cons ,k ,v) ,getter)))))))))))
-;; (cdr (assoc key alist)))
+;; (defmacro gv-letref (vars place &rest body)
+;; (declare (indent 2) (debug (sexp form &rest body)))
+;; (require 'cl-lib) ;Can't require cl-lib at top-level for bootstrap reasons!
+;; (gv-letplace (getter setter) place
+;; `(cl-macrolet ((,(nth 0 vars) () ',getter)
+;; (,(nth 1 vars) (v) (funcall ',setter v)))
+;; ,@body)))
(provide 'gv)
;;; gv.el ends here
diff --git a/lisp/files.el b/lisp/files.el
index 5d1276f261e..f360c1342d6 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -3649,10 +3649,7 @@ VARIABLES list of the class. The list is processed in order.
* If the element is of the form (DIRECTORY . LIST), and DIRECTORY
is an initial substring of the file's directory, then LIST is
applied by recursively following these rules."
- (let ((elt (assq class dir-locals-class-alist)))
- (if elt
- (setcdr elt variables)
- (push (cons class variables) dir-locals-class-alist))))
+ (setf (alist-get class dir-locals-class-alist) variables))
(defconst dir-locals-file ".dir-locals.el"
"File that contains directory-local variables.
diff --git a/lisp/frameset.el b/lisp/frameset.el
index b943d47e7bf..f8436259df0 100644
--- a/lisp/frameset.el
+++ b/lisp/frameset.el
@@ -664,10 +664,7 @@ nil while the filtering is done to restore it."
;; Set the display parameter after filtering, so that filter functions
;; have access to its original value.
(when frameset--target-display
- (let ((display (assq 'display filtered)))
- (if display
- (setcdr display (cdr frameset--target-display))
- (push frameset--target-display filtered))))
+ (setf (alist-get 'display filtered) (cdr frameset--target-display)))
filtered))
diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el
index f6c0719e4c4..61ecc8b702a 100644
--- a/lisp/international/mule-cmds.el
+++ b/lisp/international/mule-cmds.el
@@ -2776,11 +2776,7 @@ See also the documentation of `get-char-code-property' and
(or (stringp table)
(error "Not a char-table nor a file name: %s" table)))
(if (stringp table) (setq table (purecopy table)))
- (let ((slot (assq name char-code-property-alist)))
- (if slot
- (setcdr slot table)
- (setq char-code-property-alist
- (cons (cons name table) char-code-property-alist))))
+ (setf (alist-get name char-code-property-alist) table)
(put name 'char-code-property-documentation (purecopy docstring)))
(defvar char-code-property-table
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index a2e015fd287..24d5469adc3 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -256,9 +256,8 @@ Used to gray out relevant toolbar icons.")
([menu-bar file] . undefined))))
"Map used in visited files.")
-(let ((m (assq 'gud-minor-mode minor-mode-map-alist)))
- (if m (setcdr m gud-minor-mode-map)
- (push (cons 'gud-minor-mode gud-minor-mode-map) minor-mode-map-alist)))
+(setf (alist-get 'gud-minor-mode minor-mode-map-alist)
+ gud-minor-mode-map)
(defvar gud-mode-map
;; Will inherit from comint-mode via define-derived-mode.
diff --git a/lisp/ps-print.el b/lisp/ps-print.el
index 83f2cde4010..28682f52b0e 100644
--- a/lisp/ps-print.el
+++ b/lisp/ps-print.el
@@ -3822,6 +3822,7 @@ If `ps-prefix-quote' is nil, it's set to t after generating string."
(defun ps-get (alist-sym key)
"Return element from association list ALIST-SYM which car is `eq' to KEY."
+ (declare (obsolete alist-get "25.1"))
(assq key (symbol-value alist-sym)))
@@ -3829,6 +3830,7 @@ If `ps-prefix-quote' is nil, it's set to t after generating string."
"Store element (KEY . VALUE) into association list ALIST-SYM.
If KEY already exists in ALIST-SYM, modify cdr to VALUE.
It can be retrieved with `(ps-get ALIST-SYM KEY)'."
+ (declare (obsolete "use (setf (alist-get ..) ..) instead" "25.1"))
(let ((elt: (assq key (symbol-value alist-sym)))) ; to avoid name conflict
(if elt:
(setcdr elt: value)
@@ -3839,6 +3841,7 @@ It can be retrieved with `(ps-get ALIST-SYM KEY)'."
(defun ps-del (alist-sym key)
"Delete by side effect element KEY from association list ALIST-SYM."
+ (declare (obsolete "use (setf (alist-get k alist nil t) nil) instead" "25.1"))
(let ((a:list: (symbol-value alist-sym)) ; to avoid name conflict
old)
(while a:list:
diff --git a/lisp/register.el b/lisp/register.el
index ffa3c954ed2..24146065384 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -33,6 +33,8 @@
;;; Code:
+;; FIXME: Clean up namespace usage!
+
(cl-defstruct
(registerv (:constructor nil)
(:constructor registerv--make (&optional data print-func
@@ -98,16 +100,12 @@ If nil, do not show register previews, unless `help-char' (or a member of
(defun get-register (register)
"Return contents of Emacs register named REGISTER, or nil if none."
- (cdr (assq register register-alist)))
+ (alist-get register register-alist))
(defun set-register (register value)
"Set contents of Emacs register named REGISTER to VALUE. Returns VALUE.
See the documentation of the variable `register-alist' for possible VALUEs."
- (let ((aelt (assq register register-alist)))
- (if aelt
- (setcdr aelt value)
- (push (cons register value) register-alist))
- value))
+ (setf (alist-get register register-alist) value))
(defun register-describe-oneline (c)
"One-line description of register C."
diff --git a/lisp/ses.el b/lisp/ses.el
index ffd844d06bf..541c1e19769 100644
--- a/lisp/ses.el
+++ b/lisp/ses.el
@@ -426,33 +426,6 @@ functions refer to its value."
(ses-get-cell (car rowcol) (cdr rowcol)))))))
-(defun ses--alist-get (key alist &optional remove)
- "Get the value associated to KEY in ALIST."
- (declare
- (gv-expander
- (lambda (do)
- (macroexp-let2 macroexp-copyable-p k key
- (gv-letplace (getter setter) alist
- (macroexp-let2 nil p `(assq ,k ,getter)
- (funcall do `(cdr ,p)
- (lambda (v)
- (let ((set-exp
- `(if ,p (setcdr ,p ,v)
- ,(funcall setter
- `(cons (setq ,p (cons ,k ,v))
- ,getter)))))
- (cond
- ((null remove) set-exp)
- ((null v)
- `(if ,p ,(funcall setter `(delq ,p ,getter))))
- (t
- `(cond
- (,v ,set-exp)
- (,p ,(funcall setter
- `(delq ,p ,getter)))))))))))))))
- (ignore remove) ;;Silence byte-compiler.
- (cdr (assoc key alist)))
-
(defmacro ses--letref (vars place &rest body)
(declare (indent 2) (debug (sexp form &rest body)))
(gv-letplace (getter setter) place
@@ -467,18 +440,18 @@ When COL is omitted, CELL=ROW is a cell object. When COL is
present ROW and COL are the integer coordinates of the cell of
interest."
(declare (debug t))
- `(ses--alist-get ,property-name
- (ses-cell--properties
- ,(if col `(ses-get-cell ,row ,col) row))))
+ `(alist-get ,property-name
+ (ses-cell--properties
+ ,(if col `(ses-get-cell ,row ,col) row))))
(defmacro ses-cell-property-pop (property-name row &optional col)
"From a CELL or a pair (ROW,COL), get and remove the property value of
the corresponding cell with name PROPERTY-NAME."
`(ses--letref (pget pset)
- (ses--alist-get ,property-name
- (ses-cell--properties
- ,(if col `(ses-get-cell ,row ,col) row))
- t)
+ (alist-get ,property-name
+ (ses-cell--properties
+ ,(if col `(ses-get-cell ,row ,col) row))
+ nil t)
(prog1 (pget) (pset nil))))
(defmacro ses-cell-value (row &optional col)
diff --git a/lisp/subr.el b/lisp/subr.el
index 2bbc01d4533..581e52e8f9d 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -555,6 +555,15 @@ Elements of ALIST that are not conses are ignored."
(setq tail tail-cdr))))
alist)
+(defun alist-get (key alist &optional default remove)
+ "Get the value associated to KEY in ALIST.
+DEFAULT is the value to return if KEY is not found in ALIST.
+REMOVE, if non-nil, means that when setting this element, we should
+remove the entry if the new value is `eql' to DEFAULT."
+ (ignore remove) ;;Silence byte-compiler.
+ (let ((x (assq key alist)))
+ (if x (cdr x) default)))
+
(defun remove (elt seq)
"Return a copy of SEQ with all occurrences of ELT removed.
SEQ must be a list, vector, or string. The comparison is done with `equal'."
diff --git a/lisp/tempo.el b/lisp/tempo.el
index 9b6cd75b313..15be01dcdf9 100644
--- a/lisp/tempo.el
+++ b/lisp/tempo.el
@@ -611,11 +611,7 @@ function or string that is used by `\\[tempo-complete-tag]' to find a
string to match the tag against. It has the same definition as the
variable `tempo-match-finder'. In this version, supplying a
COMPLETION-FUNCTION just sets `tempo-match-finder' locally."
- (let ((old (assq tag-list tempo-local-tags)))
- (if old
- (setcdr old completion-function)
- (setq tempo-local-tags (cons (cons tag-list completion-function)
- tempo-local-tags))))
+ (setf (alist-get tag-list tempo-local-tags) completion-function)
(if completion-function
(setq tempo-match-finder completion-function))
(tempo-invalidate-collection))
diff --git a/lisp/tooltip.el b/lisp/tooltip.el
index 9d0954fc5dc..26cce418e45 100644
--- a/lisp/tooltip.el
+++ b/lisp/tooltip.el
@@ -215,11 +215,9 @@ This might return nil if the event did not occur over a buffer."
"Change the value of KEY in alist ALIST to VALUE.
If there's no association for KEY in ALIST, add one, otherwise
change the existing association. Value is the resulting alist."
- (let ((param (assq key alist)))
- (if (consp param)
- (setcdr param value)
- (push (cons key value) alist))
- alist))
+ (declare (obsolete "use (setf (alist-get ..) ..) instead" "25.1"))
+ (setf (alist-get key alist) value)
+ alist)
(declare-function x-show-tip "xfns.c"
(string &optional frame parms timeout dx dy))
@@ -244,10 +242,10 @@ in echo area."
(fg (face-attribute 'tooltip :foreground))
(bg (face-attribute 'tooltip :background)))
(when (stringp fg)
- (setq params (tooltip-set-param params 'foreground-color fg))
- (setq params (tooltip-set-param params 'border-color fg)))
+ (setf (alist-get 'foreground-color params) fg)
+ (setf (alist-get 'border-color params) fg))
(when (stringp bg)
- (setq params (tooltip-set-param params 'background-color bg)))
+ (setf (alist-get 'background-color params) bg))
(x-show-tip (propertize text 'face 'tooltip)
(selected-frame)
params
diff --git a/lisp/winner.el b/lisp/winner.el
index 1e32a7f4085..c202402a6e9 100644
--- a/lisp/winner.el
+++ b/lisp/winner.el
@@ -112,10 +112,7 @@ You may want to include buffer names such as *Help*, *Apropos*,
;; Save current configuration.
;; (Called below by `winner-save-old-configurations').
(defun winner-remember ()
- (let ((entry (assq (selected-frame) winner-currents)))
- (if entry (setcdr entry (winner-conf))
- (push (cons (selected-frame) (winner-conf))
- winner-currents))))
+ (setf (alist-get (selected-frame) winner-currents) (winner-conf)))
;; Consult `winner-currents'.
(defun winner-configuration (&optional frame)