[Emacs-diffs] trunk r118000: * lisp/subr.el (alist-get): New accessor.

[Stefan Monnier]

------------------------------------------------------------
revno: 118000
revision-id: address@hidden
parent: address@hidden
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Wed 2014-10-01 13:23:42 -0400
message:
  * 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.
modified:
  admin/ChangeLog                changelog-20091113204419-o5vbwnq5f7feedwu-2226
  admin/unidata/unidata-gen.el   
unidatagen.el-20091113204419-o5vbwnq5f7feedwu-8382
  etc/NEWS                       news-20100311060928-aoit31wvzf25yr1z-1
  lisp/ChangeLog                 changelog-20091113204419-o5vbwnq5f7feedwu-1432
  lisp/calc/calc-prog.el         
calcprog.el-20091113204419-o5vbwnq5f7feedwu-2294
  lisp/calc/calc-yank.el         
calcyank.el-20091113204419-o5vbwnq5f7feedwu-2305
  lisp/emacs-lisp/gv.el          setf.el-20120531120738-6w8114hk2anryyud-1
  lisp/files.el                  files.el-20091113204419-o5vbwnq5f7feedwu-265
  lisp/frameset.el               frameset.el-20130802043218-tfwraxv1c2zlibpw-1
  lisp/international/mule-cmds.el 
mulecmds.el-20091113204419-o5vbwnq5f7feedwu-1043
  lisp/progmodes/gud.el          gud.el-20091113204419-o5vbwnq5f7feedwu-2927
  lisp/ps-print.el               psprint.el-20091113204419-o5vbwnq5f7feedwu-767
  lisp/register.el               register.el-20091113204419-o5vbwnq5f7feedwu-104
  lisp/ses.el                    ses.el-20091113204419-o5vbwnq5f7feedwu-2447
  lisp/subr.el                   subr.el-20091113204419-o5vbwnq5f7feedwu-151
  lisp/tempo.el                  tempo.el-20091113204419-o5vbwnq5f7feedwu-774
  lisp/tooltip.el                tooltip.el-20091113204419-o5vbwnq5f7feedwu-1322
  lisp/winner.el                 winner.el-20091113204419-o5vbwnq5f7feedwu-1104

=== modified file 'admin/ChangeLog'
--- a/admin/ChangeLog   2014-09-08 06:00:58 +0000
+++ b/admin/ChangeLog   2014-10-01 17:23:42 +0000
@@ -1,3 +1,8 @@
+2014-10-01  Stefan Monnier  <address@hidden>
+
+       * unidata/unidata-gen.el (unidata-gen-table-word-list): Use alist-get
+       and cl-incf.
+
 2014-09-08  Eli Zaretskii  <address@hidden>
 
        * unidata/unidata-gen.el (unidata-check): Bring this function up

=== modified file 'admin/unidata/unidata-gen.el'
--- a/admin/unidata/unidata-gen.el      2014-09-03 16:03:34 +0000
+++ b/admin/unidata/unidata-gen.el      2014-10-01 17:23:42 +0000
@@ -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 @@
              (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)))))

=== modified file 'etc/NEWS'
--- a/etc/NEWS  2014-09-30 23:19:31 +0000
+++ b/etc/NEWS  2014-10-01 17:23:42 +0000
@@ -245,6 +245,8 @@
 *** 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.

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2014-10-01 17:20:00 +0000
+++ b/lisp/ChangeLog    2014-10-01 17:23:42 +0000
@@ -1,3 +1,20 @@
+2014-10-01  Stefan Monnier  <address@hidden>
+
+       * 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  <address@hidden>
 
        * 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

=== modified file 'lisp/calc/calc-prog.el'
--- a/lisp/calc/calc-prog.el    2014-01-01 07:43:34 +0000
+++ b/lisp/calc/calc-prog.el    2014-10-01 17:23:42 +0000
@@ -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))))))))

=== modified file 'lisp/calc/calc-yank.el'
--- a/lisp/calc/calc-yank.el    2014-02-03 00:40:49 +0000
+++ b/lisp/calc/calc-yank.el    2014-10-01 17:23:42 +0000
@@ -143,10 +143,7 @@
   "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,

=== modified file 'lisp/emacs-lisp/gv.el'
--- a/lisp/emacs-lisp/gv.el     2014-05-31 15:43:43 +0000
+++ b/lisp/emacs-lisp/gv.el     2014-10-01 17:23:42 +0000
@@ -357,6 +357,34 @@
   (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 @@
 ;;  … => (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

=== modified file 'lisp/files.el'
--- a/lisp/files.el     2014-09-29 18:14:08 +0000
+++ b/lisp/files.el     2014-10-01 17:23:42 +0000
@@ -3649,10 +3649,7 @@
 * 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.

=== modified file 'lisp/frameset.el'
--- a/lisp/frameset.el  2014-03-27 17:34:22 +0000
+++ b/lisp/frameset.el  2014-10-01 17:23:42 +0000
@@ -664,10 +664,7 @@
     ;; 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))
 
 

=== modified file 'lisp/international/mule-cmds.el'
--- a/lisp/international/mule-cmds.el   2014-06-12 01:47:28 +0000
+++ b/lisp/international/mule-cmds.el   2014-10-01 17:23:42 +0000
@@ -2776,11 +2776,7 @@
     (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

=== modified file 'lisp/progmodes/gud.el'
--- a/lisp/progmodes/gud.el     2014-09-03 04:21:40 +0000
+++ b/lisp/progmodes/gud.el     2014-10-01 17:23:42 +0000
@@ -256,9 +256,8 @@
        ([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.

=== modified file 'lisp/ps-print.el'
--- a/lisp/ps-print.el  2014-05-10 21:41:12 +0000
+++ b/lisp/ps-print.el  2014-10-01 17:23:42 +0000
@@ -3822,6 +3822,7 @@
 
 (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 @@
   "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 @@
 
 (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:

=== modified file 'lisp/register.el'
--- a/lisp/register.el  2014-09-14 23:11:52 +0000
+++ b/lisp/register.el  2014-10-01 17:23:42 +0000
@@ -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 @@
 
 (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."

=== modified file 'lisp/ses.el'
--- a/lisp/ses.el       2014-09-30 17:52:11 +0000
+++ b/lisp/ses.el       2014-10-01 17:23:42 +0000
@@ -426,33 +426,6 @@
                       (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 @@
 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)

=== modified file 'lisp/subr.el'
--- a/lisp/subr.el      2014-09-27 15:52:28 +0000
+++ b/lisp/subr.el      2014-10-01 17:23:42 +0000
@@ -555,6 +555,15 @@
        (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'."

=== modified file 'lisp/tempo.el'
--- a/lisp/tempo.el     2014-03-01 02:31:05 +0000
+++ b/lisp/tempo.el     2014-10-01 17:23:42 +0000
@@ -611,11 +611,7 @@
 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))

=== modified file 'lisp/tooltip.el'
--- a/lisp/tooltip.el   2014-04-24 15:02:56 +0000
+++ b/lisp/tooltip.el   2014-10-01 17:23:42 +0000
@@ -215,11 +215,9 @@
   "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 @@
              (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

=== modified file 'lisp/winner.el'
--- a/lisp/winner.el    2014-01-01 07:43:34 +0000
+++ b/lisp/winner.el    2014-10-01 17:23:42 +0000
@@ -112,10 +112,7 @@
 ;; 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)