mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-22 18:35:09 +00:00
Code Issues Releases Activity

* lisp/subr.el (alist-get): New accessor.

Browse Source 
* 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.
This commit is contained in:
Stefan Monnier 2014-10-01 13:23:42 -04:00
parent 34912c0a2b
commit a57fa9642d
18 changed files with 104 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
admin/ChangeLog
View File

@ -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

8
admin/unidata/unidata-gen.el
View File

@ -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)))))

2
etc/NEWS
View File

@ -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.

21
lisp/ChangeLog
View File

@ -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

3
lisp/calc/calc-prog.el
View File

@ -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))))))))

5
lisp/calc/calc-yank.el
View File

@ -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,

51
lisp/emacs-lisp/gv.el
View File

@ -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

5
lisp/files.el
View File

@ -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.

5
lisp/frameset.el
View File

@ -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))

6
lisp/international/mule-cmds.el
View File

@ -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

5
lisp/progmodes/gud.el
View File

@ -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.

3
lisp/ps-print.el
View File

@ -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:

10
lisp/register.el
View File

@ -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."

41
lisp/ses.el
View File

@ -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)

9
lisp/subr.el
View File

@ -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'."

6
lisp/tempo.el
View File

@ -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))

14
lisp/tooltip.el
View File

@ -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

5
lisp/winner.el
View File

@ -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)