Commit a57fa964 authored by Stefan Monnier's avatar Stefan Monnier

* 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.
parent 34912c0a
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
......
......@@ -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)))))
......
......@@ -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.
......
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
......
......@@ -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))))))))
......
......@@ -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,
......
......@@ -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
......@@ -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.
......
......@@ -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))
......
......@@ -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
......
......@@ -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.
......
......@@ -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:
......
......@@ -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."
......
......@@ -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)
......
......@@ -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'."
......
......@@ -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))
......
......@@ -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
......
......@@ -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)
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment