procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Provide generalized variables in core Elisp.

Browse source 
* lisp/emacs-lisp/gv.el: New file.
* lisp/subr.el (push, pop): Extend to generalized variables.
* lisp/loadup.el (macroexp): Unload if preloaded and uncompiled.
* lisp/emacs-lisp/cl-lib.el (cl-pop, cl-push, cl--set-nthcdr): Remove.
* lisp/emacs-lisp/cl-macs.el: Require gv.  Use gv-define-setter,
gv-define-simple-setter, and gv-define-expander.
Remove setf-methods defined in gv.  Rename cl-setf -> setf.
(cl-setf, cl-do-pop, cl-get-setf-method): Remove.
(cl-letf, cl-letf*, cl-define-modify-macro, cl-defsetf)
(cl-define-setf-expander, cl-struct-setf-expander): Move to cl.el.
(cl-remf, cl-shiftf, cl-rotatef, cl-callf, cl-callf2): Rewrite with
gv-letplace.
(cl-defstruct): Don't define setf-method any more.
* lisp/emacs-lisp/cl.el (flet): Don't autoload.
(cl--letf, letf, cl--letf*, letf*, cl--gv-adapt)
(define-setf-expander, defsetf, define-modify-macro)
(cl-struct-setf-expander): Move from cl-lib.el.
* lisp/emacs-lisp/syntax.el:
* lisp/emacs-lisp/ewoc.el:
* lisp/emacs-lisp/smie.el:
* lisp/emacs-lisp/cconv.el:
* lisp/emacs-lisp/timer.el: Rename cl-setf -> setf, cl-push -> push.
(timer--time): Use gv-define-simple-setter.
* lisp/emacs-lisp/macroexp.el (macroexp-let2): Rename from macroexp-let²
to avoid coding-system problems in subr.el.  Adjust all users.
(macroexp--maxsize, macroexp-small-p): New functions.
* lisp/emacs-lisp/bytecomp.el (byte-compile-file): Don't use cl-letf.
* lisp/scroll-bar.el (scroll-bar-mode):
* lisp/simple.el (auto-fill-mode, overwrite-mode, binary-overwrite-mode)
(normal-erase-is-backspace-mode): Don't use the `eq' place.
* lisp/winner.el (winner-configuration, winner-make-point-alist)
(winner-set-conf, winner-get-point, winner-set): Don't abuse letf.
* lisp/files.el (locate-file-completion-table): Avoid list*.

Fixes: debbugs:11657
This commit is contained in:
Stefan Monnier 2012-06-22 09:42:38 -04:00
parent 575db3f1a8
commit 2ee3d7f0aa
23 changed files with 2043 additions and 1972 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
etc/NEWS
View file

@ -434,6 +434,9 @@ still be supported for Emacs 24.x.
* Lisp changes in Emacs 24.2
** CL-style generalized variables are now in core Elisp.
`setf' is autoloaded and `push' and `pop' accept generalized variables.
** The return value of `defalias' has changed and is now undefined.
** `defun' also accepts a (declare DECLS) form, like `defmacro'.

40
lisp/ChangeLog
View file

@ -1,3 +1,39 @@
2012-06-22 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/gv.el: New file.
* subr.el (push, pop): Extend to generalized variables.
* loadup.el (macroexp): Unload if preloaded and uncompiled (bug#11657).
* emacs-lisp/cl-lib.el (cl-pop, cl-push, cl--set-nthcdr): Remove.
* emacs-lisp/cl-macs.el: Require gv. Use gv-define-setter,
gv-define-simple-setter, and gv-define-expander.
Remove setf-methods defined in gv. Rename cl-setf -> setf.
(cl-setf, cl-do-pop, cl-get-setf-method): Remove.
(cl-letf, cl-letf*, cl-define-modify-macro, cl-defsetf)
(cl-define-setf-expander, cl-struct-setf-expander): Move to cl.el.
(cl-remf, cl-shiftf, cl-rotatef, cl-callf, cl-callf2): Rewrite with
gv-letplace.
(cl-defstruct): Don't define setf-method any more.
* emacs-lisp/cl.el (flet): Don't autoload.
(cl--letf, letf, cl--letf*, letf*, cl--gv-adapt)
(define-setf-expander, defsetf, define-modify-macro)
(cl-struct-setf-expander): Move from cl-lib.el.
* emacs-lisp/syntax.el:
* emacs-lisp/ewoc.el:
* emacs-lisp/smie.el:
* emacs-lisp/cconv.el:
* emacs-lisp/timer.el: Rename cl-setf -> setf, cl-push -> push.
(timer--time): Use gv-define-simple-setter.
* emacs-lisp/macroexp.el (macroexp-let2): Rename from macroexp-let²
to avoid coding-system problems in subr.el. Adjust all users.
(macroexp--maxsize, macroexp-small-p): New functions.
* emacs-lisp/bytecomp.el (byte-compile-file): Don't use cl-letf.
* scroll-bar.el (scroll-bar-mode):
* simple.el (auto-fill-mode, overwrite-mode, binary-overwrite-mode)
(normal-erase-is-backspace-mode): Don't use the `eq' place.
* winner.el (winner-configuration, winner-make-point-alist)
(winner-set-conf, winner-get-point, winner-set): Don't abuse letf.
* files.el (locate-file-completion-table): Avoid list*.
2012-06-22 Chong Yidong <cyd@gnu.org>
* dired-aux.el (dired-do-create-files): Doc fix (Bug#11327).
@ -5,8 +41,8 @@
(dired-do-copy): Doc fix (Bug#11334).
(dired-mark-read-string): Doc fix (Bug#11553).
* dired.el (dired-recursive-copies, dired-recursive-deletes): Doc
fix (Bug#11326).
* dired.el (dired-recursive-copies, dired-recursive-deletes):
Doc fix (Bug#11326).
(dired-make-relative): Doc fix (Bug#11332). Remove unused arg.
(dired-dwim-target): Doc fix.

20
lisp/emacs-lisp/bytecomp.el
View file

@ -1725,14 +1725,18 @@ The value is non-nil if there were no errors, nil if errors."
(set-buffer-multibyte nil))
;; Run hooks including the uncompression hook.
;; If they change the file name, then change it for the output also.
(cl-letf ((buffer-file-name filename)
((default-value 'major-mode) 'emacs-lisp-mode)
;; Ignore unsafe local variables.
;; We only care about a few of them for our purposes.
(enable-local-variables :safe)
(enable-local-eval nil))
;; Arg of t means don't alter enable-local-variables.
(normal-mode t)
(let ((buffer-file-name filename)
(dmm (default-value 'major-mode))
;; Ignore unsafe local variables.
;; We only care about a few of them for our purposes.
(enable-local-variables :safe)
(enable-local-eval nil))
(unwind-protect
(progn
(setq-default major-mode 'emacs-lisp-mode)
;; Arg of t means don't alter enable-local-variables.
(normal-mode t))
(setq-default major-mode dmm))
;; There may be a file local variable setting (bug#10419).
(setq buffer-read-only nil
filename buffer-file-name))

24
lisp/emacs-lisp/cconv.el
View file

@ -346,13 +346,13 @@ places where they originally did not directly appear."
(if (not (eq (cadr mapping) 'apply-partially))
mapping
(cl-assert (eq (car mapping) (nth 2 mapping)))
(cl-list* (car mapping)
'apply-partially
(car mapping)
(mapcar (lambda (arg)
(if (eq var arg)
closedsym arg))
(nthcdr 3 mapping)))))
`(,(car mapping)
apply-partially
,(car mapping)
,@(mapcar (lambda (arg)
(if (eq var arg)
closedsym arg))
(nthcdr 3 mapping)))))
new-env))
(setq new-extend (remq var new-extend))
(push closedsym new-extend)
@ -559,8 +559,8 @@ FORM is the parent form that binds this var."
(when (car y) (setcar x t) (setq free t))
(setq x (cdr x) y (cdr y)))
(when free
(cl-push (caar env) (cdr freevars))
(cl-setf (nth 3 (car env)) t))
(push (caar env) (cdr freevars))
(setf (nth 3 (car env)) t))
(setq env (cdr env) envcopy (cdr envcopy))))))
(defun cconv-analyse-form (form env)
@ -610,7 +610,7 @@ and updates the data stored in ENV."
;; it is a mutated variable.
(while forms
(let ((v (assq (car forms) env))) ; v = non nil if visible
(when v (cl-setf (nth 2 v) t)))
(when v (setf (nth 2 v) t)))
(cconv-analyse-form (cadr forms) env)
(setq forms (cddr forms))))
@ -656,7 +656,7 @@ and updates the data stored in ENV."
;; lambda candidate list.
(let ((fdata (and (symbolp fun) (assq fun env))))
(if fdata
(cl-setf (nth 4 fdata) t)
(setf (nth 4 fdata) t)
(cconv-analyse-form fun env)))
(dolist (form args) (cconv-analyse-form form env)))
@ -676,7 +676,7 @@ and updates the data stored in ENV."
((pred symbolp)
(let ((dv (assq form env))) ; dv = declared and visible
(when dv
(cl-setf (nth 1 dv) t))))))
(setf (nth 1 dv) t))))))
(provide 'cconv)
;;; cconv.el ends here

4
lisp/emacs-lisp/cl-extra.el
View file

@ -305,7 +305,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
(setq cl-ovl (cdr cl-ovl))))
(set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))))
;;; Support for `cl-setf'.
;;; Support for `setf'.
;;;###autoload
(defun cl--set-frame-visible-p (frame val)
(cond ((null val) (make-frame-invisible frame))
@ -590,6 +590,7 @@ If START or END is negative, it counts from the end."
(declare (compiler-macro cl--compiler-macro-get))
(or (get sym tag)
(and def
;; Make sure `def' is really absent as opposed to set to nil.
(let ((plist (symbol-plist sym)))
(while (and plist (not (eq (car plist) tag)))
(setq plist (cdr (cdr plist))))
@ -607,6 +608,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
;; but that fails, because cl-get has a compiler macro
;; definition that uses getf!
(when def
;; Make sure `def' is really absent as opposed to set to nil.
(while (and plist (not (eq (car plist) tag)))
(setq plist (cdr (cdr plist))))
(if plist (car (cdr plist)) def))))

31
lisp/emacs-lisp/cl-lib.el
View file

@ -123,7 +123,7 @@ a future Emacs interpreter will be able to use it.")
(defmacro cl-incf (place &optional x)
"Increment PLACE by X (1 by default).
PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
PLACE may be a symbol, or any generalized variable allowed by `setf'.
The return value is the incremented value of PLACE."
(declare (debug (place &optional form)))
(if (symbolp place)
@ -132,38 +132,16 @@ The return value is the incremented value of PLACE."
(defmacro cl-decf (place &optional x)
"Decrement PLACE by X (1 by default).
PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
PLACE may be a symbol, or any generalized variable allowed by `setf'.
The return value is the decremented value of PLACE."
(declare (debug cl-incf))
(if (symbolp place)
(list 'setq place (if x (list '- place x) (list '1- place)))
(list 'cl-callf '- place (or x 1))))
;; Autoloaded, but we haven't loaded cl-loaddefs yet.
(declare-function cl-do-pop "cl-macs" (place))
(defmacro cl-pop (place)
"Remove and return the head of the list stored in PLACE.
Analogous to (prog1 (car PLACE) (cl-setf PLACE (cdr PLACE))), though more
careful about evaluating each argument only once and in the right order.
PLACE may be a symbol, or any generalized variable allowed by `cl-setf'."
(declare (debug (place)))
(if (symbolp place)
(list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))
(cl-do-pop place)))
(defmacro cl-push (x place)
"Insert X at the head of the list stored in PLACE.
Analogous to (cl-setf PLACE (cons X PLACE)), though more careful about
evaluating each argument only once and in the right order. PLACE may
be a symbol, or any generalized variable allowed by `cl-setf'."
(declare (debug (form place)))
(if (symbolp place) (list 'setq place (list 'cons x place))
(list 'cl-callf2 'cons x place)))
(defmacro cl-pushnew (x place &rest keys)
"(cl-pushnew X PLACE): insert X at the head of the list if not already there.
Like (cl-push X PLACE), except that the list is unmodified if X is `eql' to
Like (push X PLACE), except that the list is unmodified if X is `eql' to
an element already on the list.
\nKeywords supported: :test :test-not :key
\n(fn X PLACE [KEYWORD VALUE]...)"
@ -188,9 +166,6 @@ an element already on the list.
(defun cl--set-elt (seq n val)
(if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val)))
(defsubst cl--set-nthcdr (n list x)
(if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list))
(defun cl--set-buffer-substring (start end val)
(save-excursion (delete-region start end)
(goto-char start)

123
lisp/emacs-lisp/cl-loaddefs.el
View file

@ -11,7 +11,7 @@
;;;;;; cl--set-frame-visible-p cl--map-overlays cl--map-intervals
;;;;;; cl--map-keymap-recursively cl-notevery cl-notany cl-every
;;;;;; cl-some cl-mapcon cl-mapcan cl-mapl cl-maplist cl-map cl--mapcar-many
;;;;;; cl-equalp cl-coerce) "cl-extra" "cl-extra.el" "1f486111e93d119ceb6e95c434e3fd4b")
;;;;;; cl-equalp cl-coerce) "cl-extra" "cl-extra.el" "edc8a08741d81c74be36b27664d3555a")
;;; Generated autoloads from cl-extra.el
(autoload 'cl-coerce "cl-extra" "\
@ -257,17 +257,15 @@ Remove from SYMBOL's plist the property PROPNAME and its value.
;;;### (autoloads (cl--compiler-macro-cXXr cl--compiler-macro-list*
;;;;;; cl--compiler-macro-adjoin cl-defsubst cl-compiler-macroexpand
;;;;;; cl-define-compiler-macro cl-assert cl-check-type cl-typep
;;;;;; cl-deftype cl-struct-setf-expander cl-defstruct cl-define-modify-macro
;;;;;; cl-callf2 cl-callf cl-letf* cl-letf cl-rotatef cl-shiftf
;;;;;; cl-remf cl-do-pop cl-psetf cl-setf cl-get-setf-method cl-defsetf
;;;;;; cl-define-setf-expander cl-declare cl-the cl-locally cl-multiple-value-setq
;;;;;; cl-deftype cl-defstruct cl-callf2 cl-callf cl-rotatef cl-shiftf
;;;;;; cl-remf cl-psetf cl-declare cl-the cl-locally cl-multiple-value-setq
;;;;;; cl-multiple-value-bind cl-symbol-macrolet cl-macrolet cl-labels
;;;;;; cl-flet cl-progv cl-psetq cl-do-all-symbols cl-do-symbols
;;;;;; cl-dotimes cl-dolist cl-do* cl-do cl-loop cl-return-from
;;;;;; cl-return cl-block cl-etypecase cl-typecase cl-ecase cl-case
;;;;;; cl-load-time-value cl-eval-when cl-destructuring-bind cl-function
;;;;;; cl-defmacro cl-defun cl-gentemp cl-gensym) "cl-macs" "cl-macs.el"
;;;;;; "57801d8e4d72553371d59eca7b44292f")
;;;;;; "e37cb1001378ce1d677b67760fb6994b")
;;; Generated autoloads from cl-macs.el
(autoload 'cl-gensym "cl-macs" "\
@ -513,7 +511,7 @@ This is like `cl-flet', but for macros instead of functions.
(autoload 'cl-symbol-macrolet "cl-macs" "\
Make symbol macro definitions.
Within the body FORMs, references to the variable NAME will be replaced
by EXPANSION, and (setq NAME ...) will act like (cl-setf EXPANSION ...).
by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
\(fn ((NAME EXPANSION) ...) FORM...)" nil t)
@ -565,69 +563,16 @@ See Info node `(cl)Declarations' for details.
\(fn &rest SPECS)" nil t)
(autoload 'cl-define-setf-expander "cl-macs" "\
Define a `cl-setf' method.
This method shows how to handle `cl-setf's to places of the form (NAME ARGS...).
The argument forms ARGS are bound according to ARGLIST, as if NAME were
going to be expanded as a macro, then the BODY forms are executed and must
return a list of five elements: a temporary-variables list, a value-forms
list, a store-variables list (of length one), a store-form, and an access-
form. See `cl-defsetf' for a simpler way to define most setf-methods.
\(fn NAME ARGLIST BODY...)" nil t)
(autoload 'cl-defsetf "cl-macs" "\
Define a `cl-setf' method.
This macro is an easy-to-use substitute for `cl-define-setf-expander' that works
well for simple place forms. In the simple `cl-defsetf' form, `cl-setf's of
the form (cl-setf (NAME ARGS...) VAL) are transformed to function or macro
calls of the form (FUNC ARGS... VAL). Example:
(cl-defsetf aref aset)
Alternate form: (cl-defsetf NAME ARGLIST (STORE) BODY...).
Here, the above `cl-setf' call is expanded by binding the argument forms ARGS
according to ARGLIST, binding the value form VAL to STORE, then executing
BODY, which must return a Lisp form that does the necessary `cl-setf' operation.
Actually, ARGLIST and STORE may be bound to temporary variables which are
introduced automatically to preserve proper execution order of the arguments.
Example:
(cl-defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v))
\(fn NAME [FUNC | ARGLIST (STORE) BODY...])" nil t)
(autoload 'cl-get-setf-method "cl-macs" "\
Return a list of five values describing the setf-method for PLACE.
PLACE may be any Lisp form which can appear as the PLACE argument to
a macro like `cl-setf' or `cl-incf'.
\(fn PLACE &optional ENV)" nil nil)
(autoload 'cl-setf "cl-macs" "\
Set each PLACE to the value of its VAL.
This is a generalized version of `setq'; the PLACEs may be symbolic
references such as (car x) or (aref x i), as well as plain symbols.
For example, (cl-setf (cl-cadar x) y) is equivalent to (setcar (cdar x) y).
The return value is the last VAL in the list.
\(fn PLACE VAL PLACE VAL ...)" nil t)
(autoload 'cl-psetf "cl-macs" "\
Set PLACEs to the values VALs in parallel.
This is like `cl-setf', except that all VAL forms are evaluated (in order)
This is like `setf', except that all VAL forms are evaluated (in order)
before assigning any PLACEs to the corresponding values.
\(fn PLACE VAL PLACE VAL ...)" nil t)
(autoload 'cl-do-pop "cl-macs" "\
\(fn PLACE)" nil nil)
(autoload 'cl-remf "cl-macs" "\
Remove TAG from property list PLACE.
PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
PLACE may be a symbol, or any generalized variable allowed by `setf'.
The form returns true if TAG was found and removed, nil otherwise.
\(fn PLACE TAG)" nil t)
@ -635,51 +580,23 @@ The form returns true if TAG was found and removed, nil otherwise.
(autoload 'cl-shiftf "cl-macs" "\
Shift left among PLACEs.
Example: (cl-shiftf A B C) sets A to B, B to C, and returns the old A.
Each PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
\(fn PLACE... VAL)" nil t)
(autoload 'cl-rotatef "cl-macs" "\
Rotate left among PLACEs.
Example: (cl-rotatef A B C) sets A to B, B to C, and C to A. It returns nil.
Each PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
\(fn PLACE...)" nil t)
(autoload 'cl-letf "cl-macs" "\
Temporarily bind to PLACEs.
This is the analogue of `let', but with generalized variables (in the
sense of `cl-setf') for the PLACEs. Each PLACE is set to the corresponding
VALUE, then the BODY forms are executed. On exit, either normally or
because of a `throw' or error, the PLACEs are set back to their original
values. Note that this macro is *not* available in Common Lisp.
As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
the PLACE is not modified before executing BODY.
\(fn ((PLACE VALUE) ...) BODY...)" nil t)
(put 'cl-letf 'lisp-indent-function '1)
(autoload 'cl-letf* "cl-macs" "\
Temporarily bind to PLACEs.
This is the analogue of `let*', but with generalized variables (in the
sense of `cl-setf') for the PLACEs. Each PLACE is set to the corresponding
VALUE, then the BODY forms are executed. On exit, either normally or
because of a `throw' or error, the PLACEs are set back to their original
values. Note that this macro is *not* available in Common Lisp.
As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
the PLACE is not modified before executing BODY.
\(fn ((PLACE VALUE) ...) BODY...)" nil t)
(put 'cl-letf* 'lisp-indent-function '1)
(autoload 'cl-callf "cl-macs" "\
Set PLACE to (FUNC PLACE ARGS...).
FUNC should be an unquoted function name. PLACE may be a symbol,
or any generalized variable allowed by `cl-setf'.
or any generalized variable allowed by `setf'.
\(fn FUNC PLACE ARGS...)" nil t)
\(fn FUNC PLACE &rest ARGS)" nil t)
(put 'cl-callf 'lisp-indent-function '2)
@ -691,19 +608,12 @@ Like `cl-callf', but PLACE is the second argument of FUNC, not the first.
(put 'cl-callf2 'lisp-indent-function '3)
(autoload 'cl-define-modify-macro "cl-macs" "\
Define a `cl-setf'-like modify macro.
If NAME is called, it combines its PLACE argument with the other arguments
from ARGLIST using FUNC: (cl-define-modify-macro cl-incf (&optional (n 1)) +)
\(fn NAME ARGLIST FUNC &optional DOC)" nil t)
(autoload 'cl-defstruct "cl-macs" "\
Define a struct type.
This macro defines a new data type called NAME that stores data
in SLOTs. It defines a `make-NAME' constructor, a `copy-NAME'
copier, a `NAME-p' predicate, and slot accessors named `NAME-SLOT'.
You can use the accessors to set the corresponding slots, via `cl-setf'.
You can use the accessors to set the corresponding slots, via `setf'.
NAME may instead take the form (NAME OPTIONS...), where each
OPTION is either a single keyword or (KEYWORD VALUE).
@ -712,17 +622,12 @@ See Info node `(cl)Structures' for a list of valid keywords.
Each SLOT may instead take the form (SLOT SLOT-OPTS...), where
SLOT-OPTS are keyword-value pairs for that slot. Currently, only
one keyword is supported, `:read-only'. If this has a non-nil
value, that slot cannot be set via `cl-setf'.
value, that slot cannot be set via `setf'.
\(fn NAME SLOTS...)" nil t)
(put 'cl-defstruct 'doc-string-elt '2)
(autoload 'cl-struct-setf-expander "cl-macs" "\
\(fn X NAME ACCESSOR PRED-FORM POS)" nil nil)
(autoload 'cl-deftype "cl-macs" "\
Define NAME as a new data type.
The type name can then be used in `cl-typecase', `cl-check-type', etc.
@ -779,6 +684,8 @@ surrounded by (cl-block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)" nil t)
(put 'cl-defsubst 'lisp-indent-function '2)
(autoload 'cl--compiler-macro-adjoin "cl-macs" "\

741
lisp/emacs-lisp/cl-macs.el
View file

@ -45,6 +45,8 @@
(require 'cl-lib)
(require 'macroexp)
;; `gv' is required here because cl-macs can be loaded before loaddefs.el.
(require 'gv)
(defmacro cl-pop2 (place)
(declare (debug edebug-sexps))
@ -262,7 +264,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(declare (debug
;; Same as defun but use cl-lambda-list.
(&define [&or name ("cl-setf" :name cl-setf name)]
(&define [&or name ("setf" :name setf name)]
cl-lambda-list
cl-declarations-or-string
[&optional ("interactive" interactive)]
@ -1707,12 +1709,12 @@ except that it additionally expands symbol macros."
(when (cdr (assq (symbol-name cl-macro) cl-env))
(setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))))
((eq 'setq (car-safe cl-macro))
;; Convert setq to cl-setf if required by symbol-macro expansion.
;; Convert setq to setf if required by symbol-macro expansion.
(let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f cl-env))
(cdr cl-macro)))
(p args))
(while (and p (symbolp (car p))) (setq p (cddr p)))
(if p (setq cl-macro (cons 'cl-setf args))
(if p (setq cl-macro (cons 'setf args))
(setq cl-macro (cons 'setq args))
;; Don't loop further.
nil))))))
@ -1722,7 +1724,7 @@ except that it additionally expands symbol macros."
(defmacro cl-symbol-macrolet (bindings &rest body)
"Make symbol macro definitions.
Within the body FORMs, references to the variable NAME will be replaced
by EXPANSION, and (setq NAME ...) will act like (cl-setf EXPANSION ...).
by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
\(fn ((NAME EXPANSION) ...) FORM...)"
(declare (indent 1) (debug ((&rest (symbol sexp)) cl-declarations body)))
@ -1864,406 +1866,140 @@ See Info node `(cl)Declarations' for details."
;;; Generalized variables.
;;;###autoload
(defmacro cl-define-setf-expander (func args &rest body)
"Define a `cl-setf' method.
This method shows how to handle `cl-setf's to places of the form (NAME ARGS...).
The argument forms ARGS are bound according to ARGLIST, as if NAME were
going to be expanded as a macro, then the BODY forms are executed and must
return a list of five elements: a temporary-variables list, a value-forms
list, a store-variables list (of length one), a store-form, and an access-
form. See `cl-defsetf' for a simpler way to define most setf-methods.
\(fn NAME ARGLIST BODY...)"
(declare (debug
(&define name cl-lambda-list cl-declarations-or-string def-body)))
`(cl-eval-when (compile load eval)
,@(if (stringp (car body))
(list `(put ',func 'setf-documentation ,(pop body))))
(put ',func 'setf-method (cl-function (lambda ,args ,@body)))))
;;;###autoload
(defmacro cl-defsetf (func arg1 &rest args)
"Define a `cl-setf' method.
This macro is an easy-to-use substitute for `cl-define-setf-expander' that works
well for simple place forms. In the simple `cl-defsetf' form, `cl-setf's of
the form (cl-setf (NAME ARGS...) VAL) are transformed to function or macro
calls of the form (FUNC ARGS... VAL). Example:
(cl-defsetf aref aset)
Alternate form: (cl-defsetf NAME ARGLIST (STORE) BODY...).
Here, the above `cl-setf' call is expanded by binding the argument forms ARGS
according to ARGLIST, binding the value form VAL to STORE, then executing
BODY, which must return a Lisp form that does the necessary `cl-setf' operation.
Actually, ARGLIST and STORE may be bound to temporary variables which are
introduced automatically to preserve proper execution order of the arguments.
Example:
(cl-defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v))
\(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
(declare (debug
(&define name
[&or [symbolp &optional stringp]
[cl-lambda-list (symbolp)]]
cl-declarations-or-string def-body)))
(if (and (listp arg1) (consp args))
(let* ((largs nil) (largsr nil)
(temps nil) (tempsr nil)
(restarg nil) (rest-temps nil)
(store-var (car (prog1 (car args) (setq args (cdr args)))))
(store-temp (intern (format "--%s--temp--" store-var)))
(lets1 nil) (lets2 nil)
(docstr nil) (p arg1))
(if (stringp (car args))
(setq docstr (prog1 (car args) (setq args (cdr args)))))
(while (and p (not (eq (car p) '&aux)))
(if (eq (car p) '&rest)
(setq p (cdr p) restarg (car p))
(or (memq (car p) '(&optional &key &allow-other-keys))
(setq largs (cons (if (consp (car p)) (car (car p)) (car p))
largs)
temps (cons (intern (format "--%s--temp--" (car largs)))
temps))))
(setq p (cdr p)))
(setq largs (nreverse largs) temps (nreverse temps))
(if restarg
(setq largsr (append largs (list restarg))
rest-temps (intern (format "--%s--temp--" restarg))
tempsr (append temps (list rest-temps)))
(setq largsr largs tempsr temps))
(let ((p1 largs) (p2 temps))
(while p1
(setq lets1 (cons `(,(car p2)
(make-symbol ,(format "--cl-%s--" (car p1))))
lets1)
lets2 (cons (list (car p1) (car p2)) lets2)
p1 (cdr p1) p2 (cdr p2))))
(if restarg (setq lets2 (cons (list restarg rest-temps) lets2)))
`(cl-define-setf-expander ,func ,arg1
,@(and docstr (list docstr))
(let*
,(nreverse
(cons `(,store-temp
(make-symbol ,(format "--cl-%s--" store-var)))
(if restarg
`((,rest-temps
(mapcar (lambda (_) (make-symbol "--cl-var--"))
,restarg))
,@lets1)
lets1)))
(list ; 'values
(,(if restarg 'cl-list* 'list) ,@tempsr)
(,(if restarg 'cl-list* 'list) ,@largsr)
(list ,store-temp)
(let*
,(nreverse
(cons (list store-var store-temp)
lets2))
,@args)
(,(if restarg 'cl-list* 'list)
,@(cons `',func tempsr))))))
`(cl-defsetf ,func (&rest args) (store)
,(let ((call `(cons ',arg1
(append args (list store)))))
(if (car args)
`(list 'progn ,call store)
call)))))
;;; Some standard place types from Common Lisp.
(cl-defsetf aref aset)
(cl-defsetf car setcar)
(cl-defsetf cdr setcdr)
(cl-defsetf caar (x) (val) `(setcar (car ,x) ,val))
(cl-defsetf cadr (x) (val) `(setcar (cdr ,x) ,val))
(cl-defsetf cdar (x) (val) `(setcdr (car ,x) ,val))
(cl-defsetf cddr (x) (val) `(setcdr (cdr ,x) ,val))
(cl-defsetf elt (seq n) (store)
`(if (listp ,seq) (setcar (nthcdr ,n ,seq) ,store)
(aset ,seq ,n ,store)))
(cl-defsetf get put)
(cl-defsetf cl-get (x y &optional d) (store) `(put ,x ,y ,store))
(cl-defsetf gethash (x h &optional d) (store) `(puthash ,x ,store ,h))
(cl-defsetf nth (n x) (store) `(setcar (nthcdr ,n ,x) ,store))
(cl-defsetf cl-subseq (seq start &optional end) (new)
(gv-define-setter cl-get (store x y &optional d) `(put ,x ,y ,store))
(gv-define-setter cl-subseq (new seq start &optional end)
`(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) ,new))
(cl-defsetf symbol-function fset)
(cl-defsetf symbol-plist setplist)
(cl-defsetf symbol-value set)
;;; Various car/cdr aliases. Note that `cadr' is handled specially.
(cl-defsetf cl-first setcar)
(cl-defsetf cl-second (x) (store) `(setcar (cdr ,x) ,store))
(cl-defsetf cl-third (x) (store) `(setcar (cddr ,x) ,store))
(cl-defsetf cl-fourth (x) (store) `(setcar (cl-cdddr ,x) ,store))
(cl-defsetf cl-fifth (x) (store) `(setcar (nthcdr 4 ,x) ,store))
(cl-defsetf cl-sixth (x) (store) `(setcar (nthcdr 5 ,x) ,store))
(cl-defsetf cl-seventh (x) (store) `(setcar (nthcdr 6 ,x) ,store))
(cl-defsetf cl-eighth (x) (store) `(setcar (nthcdr 7 ,x) ,store))
(cl-defsetf cl-ninth (x) (store) `(setcar (nthcdr 8 ,x) ,store))
(cl-defsetf cl-tenth (x) (store) `(setcar (nthcdr 9 ,x) ,store))
(cl-defsetf cl-rest setcdr)
(gv-define-setter cl-fourth (store x) `(setcar (cl-cdddr ,x) ,store))
(gv-define-setter cl-fifth (store x) `(setcar (nthcdr 4 ,x) ,store))
(gv-define-setter cl-sixth (store x) `(setcar (nthcdr 5 ,x) ,store))
(gv-define-setter cl-seventh (store x) `(setcar (nthcdr 6 ,x) ,store))
(gv-define-setter cl-eighth (store x) `(setcar (nthcdr 7 ,x) ,store))
(gv-define-setter cl-ninth (store x) `(setcar (nthcdr 8 ,x) ,store))
(gv-define-setter cl-tenth (store x) `(setcar (nthcdr 9 ,x) ,store))
;;; Some more Emacs-related place types.
(cl-defsetf buffer-file-name set-visited-file-name t)
(cl-defsetf buffer-modified-p (&optional buf) (flag)
(gv-define-simple-setter buffer-file-name set-visited-file-name t)
(gv-define-setter buffer-modified-p (flag &optional buf)
`(with-current-buffer ,buf
(set-buffer-modified-p ,flag)))
(cl-defsetf buffer-name rename-buffer t)
(cl-defsetf buffer-string () (store)
(gv-define-simple-setter buffer-name rename-buffer t)
(gv-define-setter buffer-string (store)
`(progn (erase-buffer) (insert ,store)))
(cl-defsetf buffer-substring cl--set-buffer-substring)
(cl-defsetf current-buffer set-buffer)
(cl-defsetf current-case-table set-case-table)
(cl-defsetf current-column move-to-column t)
(cl-defsetf current-global-map use-global-map t)
(cl-defsetf current-input-mode () (store)
(gv-define-simple-setter buffer-substring cl--set-buffer-substring)
(gv-define-simple-setter current-buffer set-buffer)
(gv-define-simple-setter current-case-table set-case-table)
(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))
(cl-defsetf current-local-map use-local-map t)
(cl-defsetf current-window-configuration set-window-configuration t)
(cl-defsetf default-file-modes set-default-file-modes t)
(cl-defsetf default-value set-default)
(cl-defsetf documentation-property put)
(cl-defsetf face-background (f &optional s) (x) `(set-face-background ,f ,x ,s))
(cl-defsetf face-background-pixmap (f &optional s) (x)
(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))
(cl-defsetf face-font (f &optional s) (x) `(set-face-font ,f ,x ,s))
(cl-defsetf face-foreground (f &optional s) (x) `(set-face-foreground ,f ,x ,s))
(cl-defsetf face-underline-p (f &optional s) (x)
(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-p ,f ,x ,s))
(cl-defsetf file-modes set-file-modes t)
(cl-defsetf frame-height set-screen-height t)
(cl-defsetf frame-parameters modify-frame-parameters t)
(cl-defsetf frame-visible-p cl--set-frame-visible-p)
(cl-defsetf frame-width set-screen-width t)
(cl-defsetf frame-parameter set-frame-parameter t)
(cl-defsetf terminal-parameter set-terminal-parameter)
(cl-defsetf getenv setenv t)
(cl-defsetf get-register set-register)
(cl-defsetf global-key-binding global-set-key)
(cl-defsetf keymap-parent set-keymap-parent)
(cl-defsetf local-key-binding local-set-key)
(cl-defsetf mark set-mark t)
(cl-defsetf mark-marker set-mark t)
(cl-defsetf marker-position set-marker t)
(cl-defsetf match-data set-match-data t)
(cl-defsetf mouse-position (scr) (store)
(gv-define-simple-setter file-modes set-file-modes t)
(gv-define-simple-setter frame-height set-screen-height t)
(gv-define-simple-setter frame-parameters modify-frame-parameters t)
(gv-define-simple-setter frame-visible-p cl--set-frame-visible-p)
(gv-define-simple-setter frame-width set-screen-width t)
(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)))
(cl-defsetf overlay-get overlay-put)
(cl-defsetf overlay-start (ov) (store)
`(progn (move-overlay ,ov ,store (overlay-end ,ov)) ,store))
(cl-defsetf overlay-end (ov) (store)
`(progn (move-overlay ,ov (overlay-start ,ov) ,store) ,store))
(cl-defsetf point goto-char)
(cl-defsetf point-marker goto-char t)
(cl-defsetf point-max () (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))
(cl-defsetf point-min () (store)
(gv-define-setter point-min (store)
`(progn (narrow-to-region ,store (point-max)) ,store))
(cl-defsetf process-buffer set-process-buffer)
(cl-defsetf process-filter set-process-filter)
(cl-defsetf process-sentinel set-process-sentinel)
(cl-defsetf process-get process-put)
(cl-defsetf read-mouse-position (scr) (store)
(gv-define-setter read-mouse-position (store scr)
`(set-mouse-position ,scr (car ,store) (cdr ,store)))
(cl-defsetf screen-height set-screen-height t)
(cl-defsetf screen-width set-screen-width t)
(cl-defsetf selected-window select-window)
(cl-defsetf selected-screen select-screen)
(cl-defsetf selected-frame select-frame)
(cl-defsetf standard-case-table set-standard-case-table)
(cl-defsetf syntax-table set-syntax-table)
(cl-defsetf visited-file-modtime set-visited-file-modtime t)
(cl-defsetf window-buffer set-window-buffer t)
(cl-defsetf window-display-table set-window-display-table t)
(cl-defsetf window-dedicated-p set-window-dedicated-p t)
(cl-defsetf window-height () (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))
(cl-defsetf window-hscroll set-window-hscroll)
(cl-defsetf window-parameter set-window-parameter)
(cl-defsetf window-point set-window-point)
(cl-defsetf window-start set-window-start)
(cl-defsetf window-width () (store)
(gv-define-setter window-width (store)
`(progn (enlarge-window (- ,store (window-width)) t) ,store))
(cl-defsetf x-get-secondary-selection x-own-secondary-selection t)
(cl-defsetf x-get-selection x-own-selection t)
(gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t)
(gv-define-simple-setter x-get-selection x-own-selection t)
;; This is a hack that allows (cl-setf (eq a 7) B) to mean either
;;; 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.
(cl-define-setf-expander eq (place val)
(let ((method (cl-get-setf-method place macroexpand-all-environment))
(val-temp (make-symbol "--eq-val--"))
(store-temp (make-symbol "--eq-store--")))
(list (append (nth 0 method) (list val-temp))
(append (nth 1 method) (list val))
(list store-temp)
`(let ((,(car (nth 2 method))
(if ,store-temp ,val-temp (not ,val-temp))))
,(nth 3 method) ,store-temp)
`(eq ,(nth 4 method) ,val-temp))))
;; 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))))))))))
;;; More complex setf-methods.
;; These should take &environment arguments, but since full arglists aren't
;; available while compiling cl-macs, we fake it by referring to the global
;; variable macroexpand-all-environment directly.
(gv-define-expander nthcdr
(lambda (do n place)
(macroexp-let2 nil idx n
(gv-letplace (getter setter) place
(funcall do `(nthcdr ,idx ,getter)
(lambda (v) `(if (<= ,idx 0) ,(funcall setter v)
(setcdr (nthcdr (1- ,idx) ,getter) ,v))))))))
(cl-define-setf-expander apply (func arg1 &rest rest)
(or (and (memq (car-safe func) '(quote function cl-function))
(symbolp (car-safe (cdr-safe func))))
(error "First arg to apply in cl-setf is not (function SYM): %s" func))
(let* ((form (cons (nth 1 func) (cons arg1 rest)))
(method (cl-get-setf-method form macroexpand-all-environment)))
(list (car method) (nth 1 method) (nth 2 method)
(cl-setf-make-apply (nth 3 method) (cadr func) (car method))
(cl-setf-make-apply (nth 4 method) (cadr func) (car method)))))
(gv-define-expander cl-getf
(lambda (do place tag &optional def)
(gv-letplace (getter setter) place
(macroexp-let2 nil k tag
(macroexp-let2 nil d def
(funcall do `(cl-getf ,getter ,k ,d)
(lambda (v) (funcall setter `(cl--set-getf ,getter ,k ,v)))))))))
(defun cl-setf-make-apply (form func temps)
(if (eq (car form) 'progn)
`(progn ,(cl-setf-make-apply (cadr form) func temps) ,@(cddr form))
(or (equal (last form) (last temps))
(error "%s is not suitable for use with setf-of-apply" func))
`(apply ',(car form) ,@(cdr form))))
(cl-define-setf-expander nthcdr (n place)
(let ((method (cl-get-setf-method place macroexpand-all-environment))
(n-temp (make-symbol "--cl-nthcdr-n--"))
(store-temp (make-symbol "--cl-nthcdr-store--")))
(list (cons n-temp (car method))
(cons n (nth 1 method))
(list store-temp)
`(let ((,(car (nth 2 method))
(cl--set-nthcdr ,n-temp ,(nth 4 method)
,store-temp)))
,(nth 3 method) ,store-temp)
`(nthcdr ,n-temp ,(nth 4 method)))))
(cl-define-setf-expander cl-getf (place tag &optional def)
(let ((method (cl-get-setf-method place macroexpand-all-environment))
(tag-temp (make-symbol "--cl-getf-tag--"))
(def-temp (make-symbol "--cl-getf-def--"))
(store-temp (make-symbol "--cl-getf-store--")))
(list (append (car method) (list tag-temp def-temp))
(append (nth 1 method) (list tag def))
(list store-temp)
`(let ((,(car (nth 2 method))
(cl--set-getf ,(nth 4 method) ,tag-temp ,store-temp)))
,(nth 3 method) ,store-temp)
`(cl-getf ,(nth 4 method) ,tag-temp ,def-temp))))
(cl-define-setf-expander substring (place from &optional to)
(let ((method (cl-get-setf-method place macroexpand-all-environment))
(from-temp (make-symbol "--cl-substring-from--"))
(to-temp (make-symbol "--cl-substring-to--"))
(store-temp (make-symbol "--cl-substring-store--")))
(list (append (car method) (list from-temp to-temp))
(append (nth 1 method) (list from to))
(list store-temp)
`(let ((,(car (nth 2 method))
(cl--set-substring ,(nth 4 method)
,from-temp ,to-temp ,store-temp)))
,(nth 3 method) ,store-temp)
`(substring ,(nth 4 method) ,from-temp ,to-temp))))
;;; Getting and optimizing setf-methods.
;;;###autoload
(defun cl-get-setf-method (place &optional env)
"Return a list of five values describing the setf-method for PLACE.
PLACE may be any Lisp form which can appear as the PLACE argument to
a macro like `cl-setf' or `cl-incf'."
(if (symbolp place)
(let ((temp (make-symbol "--cl-setf--")))
(list nil nil (list temp) `(setq ,place ,temp) place))
(or (and (symbolp (car place))
(let* ((func (car place))
(name (symbol-name func))
(method (get func 'setf-method))
(case-fold-search nil))
(or (and method
(let ((macroexpand-all-environment env))
(setq method (apply method (cdr place))))
(if (and (consp method) (= (length method) 5))
method
(error "Setf-method for %s returns malformed method"
func)))
(and (string-match-p "\\`c[ad][ad][ad]?[ad]?r\\'" name)
(cl-get-setf-method (cl-compiler-macroexpand place)))
(and (eq func 'edebug-after)
(cl-get-setf-method (nth (1- (length place)) place)
env)))))
(if (eq place (setq place (macroexpand place env)))
(if (and (symbolp (car place)) (fboundp (car place))
(symbolp (symbol-function (car place))))
(cl-get-setf-method (cons (symbol-function (car place))
(cdr place)) env)
(error "No setf-method known for %s" (car place)))
(cl-get-setf-method place env)))))
(defun cl-setf-do-modify (place opt-expr)
(let* ((method (cl-get-setf-method place macroexpand-all-environment))
(temps (car method)) (values (nth 1 method))
(lets nil) (subs nil)
(optimize (and (not (eq opt-expr 'no-opt))
(or (and (not (eq opt-expr 'unsafe))
(cl--safe-expr-p opt-expr))
(cl-setf-simple-store-p (car (nth 2 method))
(nth 3 method)))))
(simple (and optimize (consp place) (cl--simple-exprs-p (cdr place)))))
(while values
(if (or simple (macroexp-const-p (car values)))
(push (cons (pop temps) (pop values)) subs)
(push (list (pop temps) (pop values)) lets)))
(list (nreverse lets)
(cons (car (nth 2 method)) (cl-sublis subs (nth 3 method)))
(cl-sublis subs (nth 4 method)))))
(defun cl-setf-do-store (spec val)
(let ((sym (car spec))
(form (cdr spec)))
(if (or (macroexp-const-p val)
(and (cl--simple-expr-p val) (eq (cl--expr-contains form sym) 1))
(cl-setf-simple-store-p sym form))
(cl-subst val sym form)
`(let ((,sym ,val)) ,form))))
(defun cl-setf-simple-store-p (sym form)
(and (consp form) (eq (cl--expr-contains form sym) 1)
(eq (nth (1- (length form)) form) sym)
(symbolp (car form)) (fboundp (car form))
(not (eq (car-safe (symbol-function (car form))) 'macro))))
(gv-define-expander substring
(lambda (do place from &optional to)
(gv-letplace (getter setter) place
(macroexp-let2 nil start from
(macroexp-let2 nil end to
(funcall do `(substring ,getter ,start ,end)
(lambda (v)
(funcall setter `(cl--set-substring
,getter ,start ,end ,v)))))))))
;;; The standard modify macros.
;;;###autoload
(defmacro cl-setf (&rest args)
"Set each PLACE to the value of its VAL.
This is a generalized version of `setq'; the PLACEs may be symbolic
references such as (car x) or (aref x i), as well as plain symbols.
For example, (cl-setf (cl-cadar x) y) is equivalent to (setcar (cdar x) y).
The return value is the last VAL in the list.
\(fn PLACE VAL PLACE VAL ...)"
(declare (debug (&rest [place form])))
(if (cdr (cdr args))
(let ((sets nil))
(while args (push `(cl-setf ,(pop args) ,(pop args)) sets))
(cons 'progn (nreverse sets)))
(if (symbolp (car args))
(and args (cons 'setq args))
(let* ((method (cl-setf-do-modify (car args) (nth 1 args)))
(store (cl-setf-do-store (nth 1 method) (nth 1 args))))
(if (car method) `(let* ,(car method) ,store) store)))))
;; `setf' is now part of core Elisp, defined in gv.el.
;;;###autoload
(defmacro cl-psetf (&rest args)
"Set PLACEs to the values VALs in parallel.
This is like `cl-setf', except that all VAL forms are evaluated (in order)
This is like `setf', except that all VAL forms are evaluated (in order)
before assigning any PLACEs to the corresponding values.
\(fn PLACE VAL PLACE VAL ...)"
(declare (debug cl-setf))
(declare (debug setf))
(let ((p args) (simple t) (vars nil))
(while p
(if (or (not (symbolp (car p))) (cl--expr-depends-p (nth 1 p) vars))
@ -2274,41 +2010,23 @@ before assigning any PLACEs to the corresponding values.
(or p (error "Odd number of arguments to cl-psetf"))
(pop p))
(if simple
`(progn (cl-setf ,@args) nil)
`(progn (setf ,@args) nil)
(setq args (reverse args))
(let ((expr `(cl-setf ,(cadr args) ,(car args))))
(let ((expr `(setf ,(cadr args) ,(car args))))
(while (setq args (cddr args))
(setq expr `(cl-setf ,(cadr args) (prog1 ,(car args) ,expr))))
(setq expr `(setf ,(cadr args) (prog1 ,(car args) ,expr))))
`(progn ,expr nil)))))
;;;###autoload
(defun cl-do-pop (place)
(if (cl--simple-expr-p place)
`(prog1 (car ,place) (cl-setf ,place (cdr ,place)))
(let* ((method (cl-setf-do-modify place t))
(temp (make-symbol "--cl-pop--")))
`(let* (,@(car method)
(,temp ,(nth 2 method)))
(prog1 (car ,temp)
,(cl-setf-do-store (nth 1 method) `(cdr ,temp)))))))
;;;###autoload
(defmacro cl-remf (place tag)
"Remove TAG from property list PLACE.
PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
PLACE may be a symbol, or any generalized variable allowed by `setf'.
The form returns true if TAG was found and removed, nil otherwise."
(declare (debug (place form)))
(let* ((method (cl-setf-do-modify place t))
(tag-temp (and (not (macroexp-const-p tag)) (make-symbol "--cl-remf-tag--")))
(val-temp (and (not (cl--simple-expr-p place))
(make-symbol "--cl-remf-place--")))
(ttag (or tag-temp tag))
(tval (or val-temp (nth 2 method))))
`(let* (,@(car method)
,@(and val-temp `((,val-temp ,(nth 2 method))))
,@(and tag-temp `((,tag-temp ,tag))))
(if (eq ,ttag (car ,tval))
(progn ,(cl-setf-do-store (nth 1 method) `(cddr ,tval))
(gv-letplace (tval setter) place
(macroexp-let2 macroexp-copyable-p ttag tag
`(if (eq ,ttag (car ,tval))
(progn ,(funcall setter `(cddr ,tval))
t)
(cl--do-remf ,tval ,ttag)))))
@ -2316,7 +2034,7 @@ The form returns true if TAG was found and removed, nil otherwise."
(defmacro cl-shiftf (place &rest args)
"Shift left among PLACEs.
Example: (cl-shiftf A B C) sets A to B, B to C, and returns the old A.
Each PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
\(fn PLACE... VAL)"
(declare (debug (&rest place)))
@ -2324,16 +2042,15 @@ Each PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
((null args) place)
((symbolp place) `(prog1 ,place (setq ,place (cl-shiftf ,@args))))
(t
(let ((method (cl-setf-do-modify place 'unsafe)))
`(let* ,(car method)
(prog1 ,(nth 2 method)
,(cl-setf-do-store (nth 1 method) `(cl-shiftf ,@args))))))))
(gv-letplace (getter setter) place
`(prog1 ,getter
,(funcall setter `(cl-shiftf ,@args)))))))
;;;###autoload
(defmacro cl-rotatef (&rest args)
"Rotate left among PLACEs.
Example: (cl-rotatef A B C) sets A to B, B to C, and C to A. It returns nil.
Each PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
\(fn PLACE...)"
(declare (debug (&rest place)))
@ -2348,107 +2065,24 @@ Each PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
(temp (make-symbol "--cl-rotatef--"))
(form temp))
(while (cdr places)
(let ((method (cl-setf-do-modify (pop places) 'unsafe)))
(setq form `(let* ,(car method)
(prog1 ,(nth 2 method)
,(cl-setf-do-store (nth 1 method) form))))))
(let ((method (cl-setf-do-modify (car places) 'unsafe)))
`(let* (,@(car method) (,temp ,(nth 2 method)))
,(cl-setf-do-store (nth 1 method) form) nil)))))
;;;###autoload
(defmacro cl-letf (bindings &rest body)
"Temporarily bind to PLACEs.
This is the analogue of `let', but with generalized variables (in the
sense of `cl-setf') for the PLACEs. Each PLACE is set to the corresponding
VALUE, then the BODY forms are executed. On exit, either normally or
because of a `throw' or error, the PLACEs are set back to their original
values. Note that this macro is *not* available in Common Lisp.
As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
the PLACE is not modified before executing BODY.
\(fn ((PLACE VALUE) ...) BODY...)"
(declare (indent 1) (debug ((&rest (gate place &optional form)) body)))
(if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)))
`(let ,bindings ,@body)
(let ((lets nil)
(rev (reverse bindings)))
(while rev
(let* ((place (if (symbolp (caar rev))
`(symbol-value ',(caar rev))
(caar rev)))
(value (cl-cadar rev))
(method (cl-setf-do-modify place 'no-opt))
(save (make-symbol "--cl-letf-save--"))
(bound (and (memq (car place) '(symbol-value symbol-function))
(make-symbol "--cl-letf-bound--")))
(temp (and (not (macroexp-const-p value)) (cdr bindings)
(make-symbol "--cl-letf-val--"))))
(setq lets (nconc (car method)
(if bound
(list (list bound
(list (if (eq (car place)
'symbol-value)
'boundp 'fboundp)
(nth 1 (nth 2 method))))
(list save `(and ,bound
,(nth 2 method))))
(list (list save (nth 2 method))))
(and temp (list (list temp value)))
lets)
body (list
`(unwind-protect
(progn
,@(if (cdr (car rev))
(cons (cl-setf-do-store (nth 1 method)
(or temp value))
body)
body))
,(if bound
`(if ,bound
,(cl-setf-do-store (nth 1 method) save)
(,(if (eq (car place) 'symbol-value)
#'makunbound #'fmakunbound)
,(nth 1 (nth 2 method))))
(cl-setf-do-store (nth 1 method) save))))
rev (cdr rev))))
`(let* ,lets ,@body))))
;;;###autoload
(defmacro cl-letf* (bindings &rest body)
"Temporarily bind to PLACEs.
This is the analogue of `let*', but with generalized variables (in the
sense of `cl-setf') for the PLACEs. Each PLACE is set to the corresponding
VALUE, then the BODY forms are executed. On exit, either normally or
because of a `throw' or error, the PLACEs are set back to their original
values. Note that this macro is *not* available in Common Lisp.
As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
the PLACE is not modified before executing BODY.
\(fn ((PLACE VALUE) ...) BODY...)"
(declare (indent 1) (debug cl-letf))
(if (null bindings)
(cons 'progn body)
(setq bindings (reverse bindings))
(while bindings
(setq body (list `(cl-letf (,(pop bindings)) ,@body))))
(car body)))
(setq form
(gv-letplace (getter setter) (pop places)
`(prog1 ,getter ,(funcall setter form)))))
(gv-letplace (getter setter) (car places)
(macroexp-let* `((,temp ,getter))
`(progn ,(funcall setter form) nil))))))
;;;###autoload
(defmacro cl-callf (func place &rest args)
"Set PLACE to (FUNC PLACE ARGS...).
FUNC should be an unquoted function name. PLACE may be a symbol,
or any generalized variable allowed by `cl-setf'.
\(fn FUNC PLACE ARGS...)"
or any generalized variable allowed by `setf'."
(declare (indent 2) (debug (cl-function place &rest form)))
(let* ((method (cl-setf-do-modify place (cons 'list args)))
(rargs (cons (nth 2 method) args)))
`(let* ,(car method)
,(cl-setf-do-store (nth 1 method)
(if (symbolp func) (cons func rargs)
`(funcall #',func ,@rargs))))))
(gv-letplace (getter setter) place
(let* ((rargs (cons getter args)))
(funcall setter
(if (symbolp func) (cons func rargs)
`(funcall #',func ,@rargs))))))
;;;###autoload
(defmacro cl-callf2 (func arg1 place &rest args)
@ -2458,31 +2092,13 @@ Like `cl-callf', but PLACE is the second argument of FUNC, not the first.
\(fn FUNC ARG1 PLACE ARGS...)"
(declare (indent 3) (debug (cl-function form place &rest form)))
(if (and (cl--safe-expr-p arg1) (cl--simple-expr-p place) (symbolp func))
`(cl-setf ,place (,func ,arg1 ,place ,@args))
(let* ((method (cl-setf-do-modify place (cons 'list args)))
(temp (and (not (macroexp-const-p arg1)) (make-symbol "--cl-arg1--")))
(rargs (cl-list* (or temp arg1) (nth 2 method) args)))
`(let* (,@(and temp (list (list temp arg1))) ,@(car method))
,(cl-setf-do-store (nth 1 method)
(if (symbolp func) (cons func rargs)
`(funcall #',func ,@rargs)))))))
;;;###autoload
(defmacro cl-define-modify-macro (name arglist func &optional doc)
"Define a `cl-setf'-like modify macro.
If NAME is called, it combines its PLACE argument with the other arguments
from ARGLIST using FUNC: (cl-define-modify-macro cl-incf (&optional (n 1)) +)"
(declare (debug
(&define name cl-lambda-list ;; should exclude &key
symbolp &optional stringp)))
(if (memq '&key arglist) (error "&key not allowed in cl-define-modify-macro"))
(let ((place (make-symbol "--cl-place--")))
`(cl-defmacro ,name (,place ,@arglist)
,doc
(,(if (memq '&rest arglist) #'cl-list* #'list)
#'cl-callf ',func ,place
,@(cl--arglist-args arglist)))))
`(setf ,place (,func ,arg1 ,place ,@args))
(macroexp-let2 nil a1 arg1
(gv-letplace (getter setter) place
(let* ((rargs (cl-list* a1 getter args)))
(funcall setter
(if (symbolp func) (cons func rargs)
`(funcall #',func ,@rargs))))))))
;;; Structures.
@ -2492,7 +2108,7 @@ from ARGLIST using FUNC: (cl-define-modify-macro cl-incf (&optional (n 1)) +)"
This macro defines a new data type called NAME that stores data
in SLOTs. It defines a `make-NAME' constructor, a `copy-NAME'
copier, a `NAME-p' predicate, and slot accessors named `NAME-SLOT'.
You can use the accessors to set the corresponding slots, via `cl-setf'.
You can use the accessors to set the corresponding slots, via `setf'.
NAME may instead take the form (NAME OPTIONS...), where each
OPTION is either a single keyword or (KEYWORD VALUE).
@ -2501,7 +2117,7 @@ See Info node `(cl)Structures' for a list of valid keywords.
Each SLOT may instead take the form (SLOT SLOT-OPTS...), where
SLOT-OPTS are keyword-value pairs for that slot. Currently, only
one keyword is supported, `:read-only'. If this has a non-nil
value, that slot cannot be set via `cl-setf'.
value, that slot cannot be set via `setf'.
\(fn NAME SLOTS...)"
(declare (doc-string 2)
@ -2655,35 +2271,35 @@ value, that slot cannot be set via `cl-setf'.
(let ((accessor (intern (format "%s%s" conc-name slot))))
(push slot slots)
(push (nth 1 desc) defaults)
(push (cl-list*
'cl-defsubst accessor '(cl-x)
(append
(and pred-check
(push `(cl-defsubst ,accessor (cl-x)
,@(and pred-check
(list `(or ,pred-check
(error "%s accessing a non-%s"
',accessor ',name))))
(list (if (eq type 'vector) `(aref cl-x ,pos)
(if (= pos 0) '(car cl-x)
`(nth ,pos cl-x)))))) forms)
,(if (eq type 'vector) `(aref cl-x ,pos)
(if (= pos 0) '(car cl-x)
`(nth ,pos cl-x)))) forms)
(push (cons accessor t) side-eff)
(push `(cl-define-setf-expander ,accessor (cl-x)
,(if (cadr (memq :read-only (cddr desc)))
`(progn (ignore cl-x)
(error "%s is a read-only slot"
',accessor))
;; If cl is loaded only for compilation,
;; the call to cl-struct-setf-expander would
;; cause a warning because it may not be
;; defined at run time. Suppress that warning.
`(progn
(declare-function
cl-struct-setf-expander "cl-macs"
(x name accessor pred-form pos))
(cl-struct-setf-expander
cl-x ',name ',accessor
,(and pred-check `',pred-check)
,pos))))
forms)
;; Don't bother defining a setf-expander, since gv-get can use
;; the compiler macro to get the same result.
;;(push `(gv-define-setter ,accessor (cl-val cl-x)
;; ,(if (cadr (memq :read-only (cddr desc)))
;; `(progn (ignore cl-x cl-val)
;; (error "%s is a read-only slot"
;; ',accessor))
;; ;; If cl is loaded only for compilation,
;; ;; the call to cl--struct-setf-expander would
;; ;; cause a warning because it may not be
;; ;; defined at run time. Suppress that warning.
;; `(progn
;; (declare-function
;; cl--struct-setf-expander "cl-macs"
;; (x name accessor pred-form pos))
;; (cl--struct-setf-expander
;; cl-val cl-x ',name ',accessor
;; ,(and pred-check `',pred-check)
;; ,pos))))
;; forms)
(if print-auto
(nconc print-func
(list `(princ ,(format " %s" slot) cl-s)
@ -2739,29 +2355,6 @@ value, that slot cannot be set via `cl-setf'.
forms)
`(progn ,@(nreverse (cons `',name forms)))))
;;;###autoload
(defun cl-struct-setf-expander (x name accessor pred-form pos)
(let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
(list (list temp) (list x) (list store)
`(progn
,@(and pred-form
(list `(or ,(cl-subst temp 'cl-x pred-form)
(error ,(format
"%s storing a non-%s"
accessor name)))))
,(if (eq (car (get name 'cl-struct-type)) 'vector)
`(aset ,temp ,pos ,store)
`(setcar
,(if (<= pos 5)
(let ((xx temp))
(while (>= (setq pos (1- pos)) 0)
(setq xx `(cdr ,xx)))
xx)
`(nthcdr ,pos ,temp))
,store)))
(list accessor temp))))
;;; Types and assertions.
;;;###autoload
@ -2932,7 +2525,7 @@ ARGLIST allows full Common Lisp conventions, and BODY is implicitly
surrounded by (cl-block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(declare (debug cl-defun))
(declare (debug cl-defun) (indent 2))
(let* ((argns (cl--arglist-args args)) (p argns)
(pbody (cons 'progn body))
(unsafe (not (cl--safe-expr-p pbody))))
@ -3021,7 +2614,7 @@ surrounded by (cl-block NAME ...).
(cl-define-compiler-macro cl-typep (&whole form val type)
(if (macroexp-const-p type)
(macroexp-let² macroexp-copyable-p temp val
(macroexp-let2 macroexp-copyable-p temp val
(cl--make-type-test temp (cl--const-expr-val type)))
form))
@ -3055,8 +2648,8 @@ surrounded by (cl-block NAME ...).
(put y 'side-effect-free t))
;;; Things that are inline.
(cl-proclaim '(inline cl-floatp-safe cl-acons cl-map cl-concatenate cl-notany cl-notevery
cl--set-elt cl-revappend cl-nreconc gethash))
(cl-proclaim '(inline cl-floatp-safe cl-acons cl-map cl-concatenate cl-notany
cl-notevery cl--set-elt cl-revappend cl-nreconc gethash))
;;; Things that are side-effect-free.
(mapc (lambda (x) (put x 'side-effect-free t))

262
lisp/emacs-lisp/cl.el
View file

@ -82,6 +82,9 @@
;; (while (re-search-forward re nil t)
;; (delete-region (1- (point)) (point)))
;; (save-buffer)))))
;;; Aliases to cl-lib's features.
(dolist (var '(
;; loop-result-var
;; loop-result
@ -208,7 +211,6 @@
typep
deftype
defstruct
define-modify-macro
callf2
callf
letf*
@ -217,11 +219,7 @@
shiftf
remf
psetf
setf
get-setf-method
defsetf
(define-setf-method . cl-define-setf-expander)
define-setf-expander
(define-setf-method . define-setf-expander)
declare
the
locally
@ -310,8 +308,6 @@
values-list
values
pushnew
push
pop
decf
incf
))
@ -328,6 +324,11 @@
(if (get new prop)
(put fun prop (get new prop))))))
;;; Features provided a bit differently in Elisp.
;; First, the old lexical-let is now better served by `lexical-binding', tho
;; it's not 100% compatible.
(defvar cl-closure-vars nil)
(defvar cl--function-convert-cache nil)
@ -421,7 +422,7 @@ lexical closures as in Common Lisp.
(list (cl-caddr x)
`(make-symbol ,(format "--%s--" (car x)))))
vars)
(cl-setf ,@(apply #'append
(setf ,@(apply #'append
(mapcar (lambda (x)
(list `(symbol-value ,(cl-caddr x)) (cadr x)))
vars)))
@ -442,7 +443,6 @@ Common Lisp.
(car body)))
;; This should really have some way to shadow 'byte-compile properties, etc.
;;;###autoload
(defmacro flet (bindings &rest body)
"Make temporary function definitions.
This is an analogue of `let' that operates on the function cell of FUNC
@ -452,7 +452,7 @@ go back to their previous definitions, or lack thereof).
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1) (debug cl-flet))
`(cl-letf* ,(mapcar
`(letf* ,(mapcar
(lambda (x)
(if (or (and (fboundp (car x))
(eq (car-safe (symbol-function (car x))) 'macro))
@ -497,7 +497,220 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard.
newenv)))
(macroexpand-all `(lexical-let ,vars (setq ,@sets) ,@body) newenv)))
;;; Additional compatibility code
;; Generalized variables are provided by gv.el, but some details are
;; not 100% compatible: not worth the trouble to add them to cl-lib.el, but we
;; still to support old users of cl.el.
(defun cl--letf (bindings simplebinds binds body)
;; It's not quite clear what the semantics of let! should be.
;; E.g. in (let! ((PLACE1 VAL1) (PLACE2 VAL2)) BODY), while it's clear
;; that the actual assignments ("bindings") should only happen after
;; evaluating VAL1 and VAL2, it's not clear when the sub-expressions of
;; PLACE1 and PLACE2 should be evaluated. Should we have
;; PLACE1; VAL1; PLACE2; VAL2; bind1; bind2
;; or
;; VAL1; VAL2; PLACE1; PLACE2; bind1; bind2
;; or
;; VAL1; VAL2; PLACE1; bind1; PLACE2; bind2
;; Common-Lisp's `psetf' does the first, so we'll do the same.
(if (null bindings)
(if (and (null binds) (null simplebinds)) (macroexp-progn body)
`(let* (,@(mapcar (lambda (x)
(pcase-let ((`(,vold ,getter ,_setter ,_vnew) x))
(list vold getter)))
binds)
,@simplebinds)
(unwind-protect
,(macroexp-progn (append
(mapcar (lambda (x) (pcase x
(`(,_vold ,_getter ,setter ,vnew)
(funcall setter vnew))))
binds)
body))
,@(mapcar (lambda (x) (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x))
(funcall setter vold)))
binds))))
(let ((binding (car bindings)))
(gv-letplace (getter setter) (car binding)
(macroexp-let2 nil vnew (cadr binding)
(if (symbolp (car binding))
;; Special-case for simple variables.
(cl--letf (cdr bindings)
(cons `(,getter ,(if (cdr binding) vnew getter))
simplebinds)
binds body)
(cl--letf (cdr bindings) simplebinds
(cons `(,(make-symbol "old") ,getter ,setter
,@(if (cdr binding) (list vnew)))
binds)
body)))))))
(defmacro letf (bindings &rest body)
"Temporarily bind to PLACEs.
This is the analogue of `let', but with generalized variables (in the
sense of `setf') for the PLACEs. Each PLACE is set to the corresponding
VALUE, then the BODY forms are executed. On exit, either normally or
because of a `throw' or error, the PLACEs are set back to their original
values. Note that this macro is *not* available in Common Lisp.
As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
the PLACE is not modified before executing BODY.
\(fn ((PLACE VALUE) ...) BODY...)"
(declare (indent 1) (debug ((&rest (gate gv-place &optional form)) body)))
(cl--letf bindings () () body))
(defun cl--letf* (bindings body)
(if (null bindings)
(macroexp-progn body)
(let ((binding (car bindings)))
(if (symbolp (car binding))
;; Special-case for simple variables.
(macroexp-let* (list (if (cdr binding) binding
(list (car binding) (car binding))))
(cl--letf* (cdr bindings) body))
(gv-letplace (getter setter) (car binding)
(macroexp-let2 macroexp-copyable-p vnew (cadr binding)
(macroexp-let2 nil vold getter
`(unwind-protect
(progn
,(if (cdr binding) (funcall setter vnew))
,(cl--letf* (cdr bindings) body))
,(funcall setter vold)))))))))
(defmacro letf* (bindings &rest body)
(declare (indent 1) (debug letf))
(cl--letf* bindings body))
(defun cl--gv-adapt (cl-gv do) ;FIXME: needed during setf expansion!
(let ((vars (nth 0 cl-gv))
(vals (nth 1 cl-gv))
(binds ())
(substs ()))
;; Use cl-sublis as was done in cl-setf-do-modify.
(while vars
(if (macroexp-copyable-p (car vals))
(push (cons (pop vars) (pop vals)) substs)
(push (list (pop vars) (pop vals)) binds)))
(macroexp-let*
binds
(funcall do (cl-sublis substs (nth 4 cl-gv))
;; We'd like to do something like
;; (lambda ,(nth 2 cl-gv) ,(nth 3 cl-gv)).
(lambda (exp)
(macroexp-let2 macroexp-copyable-p v exp
(cl-sublis (cons (cons (car (nth 2 cl-gv)) v)
substs)
(nth 3 cl-gv))))))))
(defmacro define-setf-expander (name arglist &rest body)
"Define a `setf' method.
This method shows how to handle `setf's to places of the form (NAME ARGS...).
The argument forms ARGS are bound according to ARGLIST, as if NAME were
going to be expanded as a macro, then the BODY forms are executed and must
return a list of five elements: a temporary-variables list, a value-forms
list, a store-variables list (of length one), a store-form, and an access-
form. See `gv-define-expander', `gv-define-setter', and `gv-define-expander'
for a better and simpler ways to define setf-methods."
(declare (debug
(&define name cl-lambda-list cl-declarations-or-string def-body)))
`(progn
,@(if (stringp (car body))
(list `(put ',name 'setf-documentation ,(pop body))))
(gv-define-expander ,name
(cl-function
(lambda (do ,@arglist)
(cl--gv-adapt (progn ,@body) do))))))
(defmacro defsetf (name arg1 &rest args)
"Define a `setf' method.
This macro is an easy-to-use substitute for `define-setf-expander' that works
well for simple place forms. In the simple `defsetf' form, `setf's of
the form (setf (NAME ARGS...) VAL) are transformed to function or macro
calls of the form (FUNC ARGS... VAL). Example:
(cl-defsetf aref aset)
Alternate form: (cl-defsetf NAME ARGLIST (STORE) BODY...).
Here, the above `setf' call is expanded by binding the argument forms ARGS
according to ARGLIST, binding the value form VAL to STORE, then executing
BODY, which must return a Lisp form that does the necessary `setf' operation.
Actually, ARGLIST and STORE may be bound to temporary variables which are
introduced automatically to preserve proper execution order of the arguments.
Example:
(cl-defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v))
\(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
(declare (debug
(&define name
[&or [symbolp &optional stringp]
[cl-lambda-list (symbolp)]]
cl-declarations-or-string def-body)))
(if (and (listp arg1) (consp args))
;; Like `gv-define-setter' but with `cl-function'.
`(gv-define-expander ,name
(lambda (do &rest args)
(gv--defsetter ',name
(cl-function
(lambda (,@(car args) ,@arg1) ,@(cdr args)))
do args)))
`(gv-define-simple-setter ,name ,arg1)))
;; FIXME: CL used to provide a setf method for `apply', but I haven't been able
;; to find a case where it worked. The code below tries to handle it as well.
;; (defun cl--setf-apply (form last-witness last)
;; (cond
;; ((not (consp form)) form)
;; ((eq (ignore-errors (car (last form))) last-witness)
;; `(apply #',(car form) ,@(butlast (cdr form)) ,last))
;; ((and (memq (car form) '(let let*))
;; (rassoc (list last-witness) (cadr form)))
;; (let ((rebind (rassoc (list last-witness) (cadr form))))
;; `(,(car form) ,(remq rebind (cadr form))
;; ,@(mapcar (lambda (form) (cl--setf-apply form (car rebind) last))
;; (cddr form)))))
;; (t (mapcar (lambda (form) (cl--setf-apply form last-witness last)) form))))
;; (gv-define-setter apply (val fun &rest args)
;; (pcase fun (`#',(and (pred symbolp) f) (setq fun f))
;; (_ (error "First arg to apply in setf is not #'SYM: %S" fun)))
;; (let* ((butlast (butlast args))
;; (last (car (last args)))
;; (last-witness (make-symbol "--cl-tailarg--"))
;; (setter (macroexpand `(setf (,fun ,@butlast ,last-witness) ,val)
;; macroexpand-all-environment)))
;; (cl--setf-apply setter last-witness last)))
;; FIXME: CL used to provide get-setf-method, which was used by some
;; setf-expanders, but now that we use gv.el, it is a lot more difficult
;; and in general impossible to provide get-setf-method. Hopefully, it
;; won't be needed. If needed, we'll have to do something nasty along the
;; lines of
;; (defun get-setf-method (place &optional env)
;; (let* ((witness (list 'cl-gsm))
;; (expansion (gv-letplace (getter setter) place
;; `(,witness ,getter ,(funcall setter witness)))))
;; ...find "let prefix" of expansion, extract getter and setter from
;; ...the rest, and build the 5-tuple))
(make-obsolete 'get-setf-method 'gv-letplace "24.2")
(defmacro define-modify-macro (name arglist func &optional doc)
"Define a `setf'-like modify macro.
If NAME is called, it combines its PLACE argument with the other arguments
from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)"
(declare (debug
(&define name cl-lambda-list ;; should exclude &key
symbolp &optional stringp)))
(if (memq '&key arglist)
(error "&key not allowed in define-modify-macro"))
(let ((place (make-symbol "--cl-place--")))
`(cl-defmacro ,name (,place ,@arglist)
,doc
(,(if (memq '&rest arglist) #'cl-list* #'list)
#'cl-callf ',func ,place
,@(cl--arglist-args arglist)))))
;;; Additional compatibility code.
;; For names that were clean but really aren't needed any more.
(define-obsolete-function-alias 'cl-macroexpand 'macroexpand "24.2")
@ -510,8 +723,8 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard.
;; No idea if this might still be needed.
(defun cl-not-hash-table (x &optional y &rest z)
(declare (obsolete nil "24.2"))
(signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))
(make-obsolete 'cl-not-hash-table nil "24.2")
(defvar cl-builtin-gethash (symbol-function 'gethash))
(make-obsolete-variable 'cl-builtin-gethash nil "24.2")
@ -538,6 +751,29 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard.
(while (and list (not (equal item (car list)))) (setq list (cdr list)))
list)
;; Used in the expansion of the old `defstruct'.
(defun cl-struct-setf-expander (x name accessor pred-form pos)
(declare (obsolete nil "24.2"))
(let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
(list (list temp) (list x) (list store)
`(progn
,@(and pred-form
(list `(or ,(cl-subst temp 'cl-x pred-form)
(error ,(format
"%s storing a non-%s"
accessor name)))))
,(if (eq (car (get name 'cl-struct-type)) 'vector)
`(aset ,temp ,pos ,store)
`(setcar
,(if (<= pos 5)
(let ((xx temp))
(while (>= (setq pos (1- pos)) 0)
(setq xx `(cdr ,xx)))
xx)
`(nthcdr ,pos ,temp))
,store)))
(list accessor temp))))
;; FIXME: More candidates: define-modify-macro, define-setf-expander.
(provide 'cl)

50
lisp/emacs-lisp/ewoc.el
View file

@ -196,10 +196,10 @@ NODE and leaving the new node's start there. Return the new node."
(save-excursion
(let ((elemnode (ewoc--node-create
(copy-marker (ewoc--node-start-marker node)) data)))
(cl-setf (ewoc--node-left elemnode) (ewoc--node-left node)
(ewoc--node-right elemnode) node
(ewoc--node-right (ewoc--node-left node)) elemnode
(ewoc--node-left node) elemnode)
(setf (ewoc--node-left elemnode) (ewoc--node-left node)
(ewoc--node-right elemnode) node
(ewoc--node-right (ewoc--node-left node)) elemnode
(ewoc--node-left node) elemnode)
(ewoc--refresh-node pretty-printer elemnode dll)
elemnode)))
@ -244,8 +244,8 @@ Normally, a newline is automatically inserted after the header,
the footer and every node's printed representation. Optional
fourth arg NOSEP non-nil inhibits this."
(let* ((dummy-node (ewoc--node-create 'DL-LIST 'DL-LIST))
(dll (progn (cl-setf (ewoc--node-right dummy-node) dummy-node)
(cl-setf (ewoc--node-left dummy-node) dummy-node)
(dll (progn (setf (ewoc--node-right dummy-node) dummy-node)
(setf (ewoc--node-left dummy-node) dummy-node)
dummy-node))
(wrap (if nosep 'identity 'ewoc--wrap))
(new-ewoc (ewoc--create (current-buffer)
@ -258,12 +258,12 @@ fourth arg NOSEP non-nil inhibits this."
;; Set default values
(unless header (setq header ""))
(unless footer (setq footer ""))
(cl-setf (ewoc--node-start-marker dll) (copy-marker pos)
foot (ewoc--insert-new-node dll footer hf-pp dll)
head (ewoc--insert-new-node foot header hf-pp dll)
(ewoc--hf-pp new-ewoc) hf-pp
(ewoc--footer new-ewoc) foot
(ewoc--header new-ewoc) head))
(setf (ewoc--node-start-marker dll) (copy-marker pos)
foot (ewoc--insert-new-node dll footer hf-pp dll)
head (ewoc--insert-new-node foot header hf-pp dll)
(ewoc--hf-pp new-ewoc) hf-pp
(ewoc--footer new-ewoc) foot
(ewoc--header new-ewoc) head))
;; Return the ewoc
new-ewoc))
@ -274,7 +274,7 @@ fourth arg NOSEP non-nil inhibits this."
(defun ewoc-set-data (node data)
"Set NODE to encapsulate DATA."
(cl-setf (ewoc--node-data node) data))
(setf (ewoc--node-data node) data))
(defun ewoc-enter-first (ewoc data)
"Enter DATA first in EWOC.
@ -356,18 +356,18 @@ arguments will be passed to MAP-FUNCTION."
;; If we are about to delete the node pointed at by last-node,
;; set last-node to nil.
(when (eq last node)
(cl-setf last nil (ewoc--last-node ewoc) nil))
(setf last nil (ewoc--last-node ewoc) nil))
(delete-region (ewoc--node-start-marker node)
(ewoc--node-start-marker (ewoc--node-next dll node)))
(set-marker (ewoc--node-start-marker node) nil)
(cl-setf L (ewoc--node-left node)
R (ewoc--node-right node)
;; Link neighbors to each other.
(ewoc--node-right L) R
(ewoc--node-left R) L
;; Forget neighbors.
(ewoc--node-left node) nil
(ewoc--node-right node) nil))))
(setf L (ewoc--node-left node)
R (ewoc--node-right node)
;; Link neighbors to each other.
(ewoc--node-right L) R
(ewoc--node-left R) L
;; Forget neighbors.
(ewoc--node-left node) nil
(ewoc--node-right node) nil))))
(defun ewoc-filter (ewoc predicate &rest args)
"Remove all elements in EWOC for which PREDICATE returns nil.
@ -503,7 +503,7 @@ Return the node (or nil if we just passed the last node)."
(ewoc--set-buffer-bind-dll ewoc
(goto-char (ewoc--node-start-marker node))
(if goal-column (move-to-column goal-column))
(cl-setf (ewoc--last-node ewoc) node)))
(setf (ewoc--last-node ewoc) node)))
(defun ewoc-refresh (ewoc)
"Refresh all data in EWOC.
@ -564,8 +564,8 @@ Return nil if the buffer has been deleted."
((head (ewoc--header ewoc))
(foot (ewoc--footer ewoc))
(hf-pp (ewoc--hf-pp ewoc)))
(cl-setf (ewoc--node-data head) header
(ewoc--node-data foot) footer)
(setf (ewoc--node-data head) header
(ewoc--node-data foot) footer)
(save-excursion
(ewoc--refresh-node hf-pp head dll)
(ewoc--refresh-node hf-pp foot dll))))

430
lisp/emacs-lisp/gv.el Normal file
View file

@ -0,0 +1,430 @@
;;; gv.el --- Generalized variables -*- lexical-binding: t -*-
;; Copyright (C) 2012 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: extensions
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This is a re-implementation of the setf machinery using a different
;; underlying approach than the one used earlier in CL, which was based on
;; define-setf-expander.
;; `define-setf-expander' makes every "place-expander" return a 5-tuple
;; (VARS VALUES STORES GETTER SETTER)
;; where STORES is a list with a single variable (Common-Lisp allows multiple
;; variables for use with multiple-return-values, but this is rarely used and
;; not applicable to Elisp).
;; It basically says that GETTER is an expression that returns the place's
;; value, and (lambda STORES SETTER) is an expression that assigns the value(s)
;; passed to that function to the place, and that you need to wrap the whole
;; thing within a `(let* ,(zip VARS VALUES) ...).
;;
;; Instead, we use here a higher-order approach: instead
;; of a 5-tuple, a place-expander returns a function.
;; If you think about types, the old approach return things of type
;; {vars: List Var, values: List Exp,
;; stores: List Var, getter: Exp, setter: Exp}
;; whereas the new approach returns a function of type
;; (do: ((getter: Exp, setter: ((store: Exp) -> Exp)) -> Exp)) -> Exp.
;; You can get the new function from the old 5-tuple with something like:
;; (lambda (do)
;; `(let* ,(zip VARS VALUES)
;; (funcall do GETTER (lambda ,STORES ,SETTER))))
;; You can't easily do the reverse, because this new approach is more
;; expressive than the old one, so we can't provide a backward-compatible
;; get-setf-method.
;;
;; While it may seem intimidating for people not used to higher-order
;; functions, you will quickly see that its use (especially with the
;; `gv-letplace' macro) is actually much easier and more elegant than the old
;; approach which is clunky and often leads to unreadable code.
;; FIXME: `let!' is unsatisfactory because it does not really "restore" the
;; previous state. If the getter/setter loses information, that info is
;; not recovered.
;; FIXME: Add to defun-declarations-alist.
;; Food for thought: the syntax of places does not actually conflict with the
;; pcase patterns. The `cons' gv works just like a `(,a . ,b) pcase
;; pattern, and actually the `logand' gv is even closer since it should
;; arguably fail when trying to set a value outside of the mask.
;; Generally, places are used for destructors (gethash, aref, car, ...)
;; whereas pcase patterns are used for constructors (backquote, constants,
;; vectors, ...).
;;; Code:
(require 'macroexp)
;; What we call a "gvar" is basically a function of type "(getter * setter ->
;; code) -> code", where "getter" is code and setter is "code -> code".
;; (defvar gv--macro-environment nil
;; "Macro expanders for generalized variables.")
;;;###autoload
(defun gv-get (place do)
"Build the code that applies DO to PLACE.
PLACE must be a valid generalized variable.
DO must be a function; it will be called with 2 arguments: GETTER and SETTER,
where GETTER is a (copyable) Elisp expression that returns the value of PLACE,
and SETTER is a function which returns the code to set PLACE when called
with a (not necessarily copyable) Elisp expression that returns the value to
set it to.
DO must return an Elisp expression."
(if (symbolp place)
(funcall do place (lambda (v) `(setq ,place ,v)))
(let* ((head (car place))
(gf (get head 'gv-expander)))
(if gf (apply gf do (cdr place))
(let ((me (macroexpand place ;FIXME: expand one step at a time!
;; (append macroexpand-all-environment
;; gv--macro-environment)
macroexpand-all-environment)))
(if (and (eq me place) (get head 'compiler-macro))
;; Expand compiler macros: this takes care of all the accessors
;; defined via cl-defsubst, such as cXXXr and defstruct slots.
(setq me (apply (get head 'compiler-macro) place (cdr place))))
(if (and (eq me place) (fboundp head)
(symbolp (symbol-function head)))
;; Follow aliases.
(setq me (cons (symbol-function head) (cdr place))))
(if (eq me place)
(error "%S is not a valid place expression" place)
(gv-get me do)))))))
;;;###autoload
(defmacro gv-letplace (vars place &rest body)
"Build the code manipulating the generalized variable PLACE.
GETTER will be bound to a copyable expression that returns the value
of PLACE.
SETTER will be bound to a function that takes an expression V and returns
and new expression that sets PLACE to V.
BODY should return some Elisp expression E manipulating PLACE via GETTER
and SETTER.
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)))
`(gv-get ,place (lambda ,vars ,@body)))
;; Different ways to declare a generalized variable.
;;;###autoload
(defmacro gv-define-expander (name handler)
"Use HANDLER to handle NAME as a generalized var.
NAME is a symbol: the name of a function, macro, or special form.
HANDLER is a function which takes an argument DO followed by the same
arguments as NAME. DO is a function as defined in `gv-get'."
(declare (indent 1) (debug (sexp form)))
;; Use eval-and-compile so the method can be used in the same file as it
;; is defined.
;; FIXME: Just like byte-compile-macro-environment, we should have something
;; like byte-compile-symbolprop-environment so as to handle these things
;; cleanly without affecting the running Emacs.
`(eval-and-compile (put ',name 'gv-expander ,handler)))
;; (eval-and-compile
;; (defun gv--defun-declaration (name args handler)
;; (pcase handler
;; (`(lambda (,do) . ,body)
;; `(gv-define-expander ,name (lambda (,do ,@args) ,@body)))
;; ;; (`(expand ,expander) `(gv-define-expand ,name ,expander))
;; ;; FIXME: If `setter' is a lambda, give it a name rather
;; ;; than duplicate it at each setf use.
;; (`(setter ,setter) `(gv-define-simple-setter ,name ,setter))
;; (`(setter (,arg) . ,body)
;; `(gv-define-setter ,name (,arg ,@args) ,@body))
;; ;; FIXME: Should we prefer gv-define-simple-setter in this case?
;; ;;((pred symbolp) `(gv-define-expander ,name #',handler))
;; (_ (message "Unknown gv-expander declaration %S" handler) nil)))
;; (push `(gv-expander ,#'gv--defun-declaration) defun-declarations-alist)
;; )
;; (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.
;; EXPANDER is a function that will be called as a macro-expander to reduce
;; uses of NAME to some other generalized variable."
;; (declare (debug (sexp form)))
;; `(eval-and-compile
;; (if (not (boundp 'gv--macro-environment))
;; (setq gv--macro-environment nil))
;; (push (cons ',name ,expander) gv--macro-environment)))
(defun gv--defsetter (name setter do args &optional vars)
"Helper function used by code generated by `gv-define-setter'.
NAME is the name of the getter function.
SETTER is a function that generates the code for the setter.
NAME accept ARGS as arguments and SETTER accepts (NEWVAL . ARGS).
VARS is used internally for recursive calls."
(if (null args)
(let ((vars (nreverse vars)))
(funcall do `(,name ,@vars) (lambda (v) (apply setter v vars))))
;; FIXME: Often it would be OK to skip this `let', but in general,
;; `do' may have all kinds of side-effects.
(macroexp-let2 nil v (car args)
(gv--defsetter name setter do (cdr args) (cons v vars)))))
;;;###autoload
(defmacro gv-define-setter (name arglist &rest body)
"Define a setter method for generalized variable NAME.
This macro is an easy-to-use substitute for `gv-define-expander' that works
well for simple place forms.
Assignments of VAL to (NAME ARGS...) are expanded by binding the argument
forms (VAL ARGS...) according to ARGLIST, then executing BODY, which must
return a Lisp form that does the assignment.
Actually, ARGLIST may be bound to temporary variables which are introduced
automatically to preserve proper execution order of the arguments. Example:
(gv-define-setter aref (v a i) `(aset ,a ,i ,v))"
(declare (indent 2) (debug (&define name sexp body)))
`(gv-define-expander ,name
(lambda (do &rest args)
(gv--defsetter ',name (lambda ,arglist ,@body) do args))))
;;;###autoload
(defmacro gv-define-simple-setter (name setter &optional fix-return)
"Define a simple setter method for generalized variable NAME.
This macro is an easy-to-use substitute for `gv-define-expander' that works
well for simple place forms. Assignments of VAL to (NAME ARGS...) are
turned into calls of the form (SETTER ARGS... VAL).
If FIX-RETURN is non-nil, then SETTER is not assumed to return VAL and
instead the assignment is turned into (prog1 VAL (SETTER ARGS... VAL))
so as to preserve the semantics of `setf'."
(declare (debug (sexp (&or symbolp lambda-expr) &optional sexp)))
(let ((set-call `(cons ',setter (append args (list val)))))
`(gv-define-setter ,name (val &rest args)
,(if fix-return `(list 'prog1 val ,set-call) set-call))))
;;; CL compatibility.
(defmacro gv-define-modify-macro (name arglist func &optional doc)
(let* ((args (copy-sequence arglist))
(rest (memq '&rest args)))
(setq args (delq '&optional (delq '&rest args)))
`(defmacro ,name (place ,@arglist)
,doc
(gv-letplace (getter setter) place
(macroexp-let2 nil v
,(list '\`
(append (list func ',getter)
(mapcar (lambda (arg) (list '\, arg)) args)
(if rest (list (list '\,@ (cadr rest))))))
(funcall setter v))))))
(gv-define-simple-setter gv--tree-get gv--tree-set)
;;; Typical operations on generalized variables.
;;;###autoload
(defmacro setf (&rest args)
"Set each PLACE to the value of its VAL.
This is a generalized version of `setq'; the PLACEs may be symbolic
references such as (car x) or (aref x i), as well as plain symbols.
For example, (setf (cadr x) y) is equivalent to (setcar (cdr x) y).
The return value is the last VAL in the list.
\(fn PLACE VAL PLACE VAL ...)"
(declare (debug (gv-place form)))
(if (and args (null (cddr args)))
(let ((place (pop args))
(val (car args)))
(gv-letplace (_getter setter) place
(funcall setter val)))
(let ((sets nil))
(while args (push `(setf ,(pop args) ,(pop args)) sets))
(cons 'progn (nreverse sets)))))
(defmacro gv-pushnew! (val place)
"Like `gv-push!' but only adds VAL if it's not yet in PLACE.
Presence is checked with `member'.
The return value is unspecified."
(declare (debug (form gv-place)))
(macroexp-let2 macroexp-copyable-p v val
(gv-letplace (getter setter) place
`(if (member ,v ,getter) nil
,(funcall setter `(cons ,v ,getter))))))
(defmacro gv-inc! (place &optional val)
"Increment PLACE by VAL (default to 1)."
(declare (debug (gv-place &optional form)))
(gv-letplace (getter setter) place
(funcall setter `(+ ,getter ,(or val 1)))))
(defmacro gv-dec! (place &optional val)
"Decrement PLACE by VAL (default to 1)."
(declare (debug (gv-place &optional form)))
(gv-letplace (getter setter) place
(funcall setter `(- ,getter ,(or val 1)))))
;; For Edebug, the idea is to let Edebug instrument gv-places just like it does
;; for normal expressions, and then give it a gv-expander to DTRT.
;; Maybe this should really be in edebug.el rather than here.
(put 'gv-place 'edebug-form-spec 'edebug-match-form)
;; CL did the equivalent of:
;;(gv-define-expand edebug-after (lambda (before index place) place))
(put 'edebug-after 'gv-expander
(lambda (do before index place)
(gv-letplace (getter setter) place
(funcall do `(edebug-after ,before ,index ,getter)
setter))))
;;; The common generalized variables.
(gv-define-simple-setter aref aset)
(gv-define-simple-setter car setcar)
(gv-define-simple-setter cdr setcdr)
;; FIXME: add compiler-macros for `cXXr' instead!
(gv-define-setter caar (val x) `(setcar (car ,x) ,val))
(gv-define-setter cadr (val x) `(setcar (cdr ,x) ,val))
(gv-define-setter cdar (val x) `(setcdr (car ,x) ,val))
(gv-define-setter cddr (val x) `(setcdr (cdr ,x) ,val))
(gv-define-setter elt (store seq n)
`(if (listp ,seq) (setcar (nthcdr ,n ,seq) ,store)
(aset ,seq ,n ,store)))
(gv-define-simple-setter get put)
(gv-define-setter gethash (val k h &optional _d) `(puthash ,k ,val ,h))
;; (gv-define-expand nth (lambda (idx list) `(car (nthcdr ,idx ,list))))
(put 'nth 'gv-expander
(lambda (do idx list)
(macroexp-let2 nil c `(nthcdr ,idx ,list)
(funcall do `(car ,c) (lambda (v) `(setcar ,c ,v))))))
(gv-define-simple-setter symbol-function fset)
(gv-define-simple-setter symbol-plist setplist)
(gv-define-simple-setter symbol-value set)
(put 'nthcdr 'gv-expander
(lambda (do n place)
(macroexp-let2 nil idx n
(gv-letplace (getter setter) place
(funcall do `(nthcdr ,idx ,getter)
(lambda (v) `(if (<= ,idx 0) ,(funcall setter v)
(setcdr (nthcdr (1- ,idx) ,getter) ,v))))))))
;;; Elisp-specific generalized variables.
(gv-define-simple-setter default-value set-default)
(gv-define-simple-setter frame-parameter set-frame-parameter 'fix)
(gv-define-simple-setter terminal-parameter set-terminal-parameter)
(gv-define-simple-setter keymap-parent set-keymap-parent)
(gv-define-simple-setter match-data set-match-data 'fix)
(gv-define-simple-setter overlay-get overlay-put)
(gv-define-setter overlay-start (store ov)
`(progn (move-overlay ,ov ,store (overlay-end ,ov)) ,store))
(gv-define-setter overlay-end (store ov)
`(progn (move-overlay ,ov (overlay-start ,ov) ,store) ,store))
(gv-define-simple-setter process-buffer set-process-buffer)
(gv-define-simple-setter process-filter set-process-filter)
(gv-define-simple-setter process-sentinel set-process-sentinel)
(gv-define-simple-setter process-get process-put)
(gv-define-simple-setter window-buffer set-window-buffer)
(gv-define-simple-setter window-display-table set-window-display-table 'fix)
(gv-define-simple-setter window-dedicated-p set-window-dedicated-p)
(gv-define-simple-setter window-hscroll set-window-hscroll)
(gv-define-simple-setter window-parameter set-window-parameter)
(gv-define-simple-setter window-point set-window-point)
(gv-define-simple-setter window-start set-window-start)
;;; Some occasionally handy extensions.
;; While several of the "places" below are not terribly useful for direct use,
;; they can show up as the output of the macro expansion of reasonable places,
;; such as struct-accessors.
(put 'progn 'gv-expander
(lambda (do &rest exps)
(let ((start (butlast exps))
(end (car (last exps))))
(if (null start) (gv-get end do)
`(progn ,@start ,(gv-get end do))))))
(let ((let-expander
(lambda (letsym)
(lambda (do bindings &rest body)
`(,letsym ,bindings
,@(macroexp-unprogn
(gv-get (macroexp-progn body) do)))))))
(put 'let 'gv-expander (funcall let-expander 'let))
(put 'let* 'gv-expander (funcall let-expander 'let*)))
(put 'if 'gv-expander
(lambda (do test then &rest else)
(let ((v (make-symbol "v")))
(if (macroexp-small-p (funcall do 'dummy (lambda (_) 'dummy)))
;; This duplicates the `do' code, which is a problem if that
;; code is large, but otherwise results in more efficient code.
`(if ,test ,(gv-get then do)
,@(macroexp-unprogn (gv-get (macroexp-progn else) do)))
(macroexp-let2 nil b test
(macroexp-let2 nil
gv `(if ,b ,(gv-letplace (getter setter) then
`(cons (lambda () ,getter)
(lambda (,v) ,(funcall setter v))))
,(gv-letplace (getter setter) (macroexp-progn else)
`(cons (lambda () ,getter)
(lambda (,v) ,(funcall setter v)))))
(funcall do `(funcall (car ,gv))
(lambda (v) `(funcall (cdr ,gv) ,v)))))))))
;;; Even more debatable extensions.
(put 'cons 'gv-expander
(lambda (do a d)
(gv-letplace (agetter asetter) a
(gv-letplace (dgetter dsetter) d
(funcall do
`(cons ,agetter ,dgetter)
(lambda (v) `(progn
,(funcall asetter `(car ,v))
,(funcall dsetter `(cdr ,v)))))))))
(put 'logand 'gv-expander
(lambda (do place &rest masks)
(gv-letplace (getter setter) place
(macroexp-let2 macroexp-copyable-p
mask (if (cdr masks) `(logand ,@masks) (car masks))
(funcall
do `(logand ,getter ,mask)
(lambda (v)
(funcall setter
`(logior (logand ,v ,mask)
(logand ,getter (lognot ,mask))))))))))
;;; 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)))
(provide 'gv)
;;; gv.el ends here

23
lisp/emacs-lisp/macroexp.el
View file

@ -263,7 +263,7 @@ definitions to shadow the loaded ones for use in file byte-compilation."
((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then))
(t `(if ,test ,then ,else))))
(defmacro macroexp-let² (test var exp &rest exps)
(defmacro macroexp-let2 (test var exp &rest exps)
"Bind VAR to a copyable expression that returns the value of EXP.
This is like `(let ((v ,EXP)) ,EXPS) except that `v' is a new generated
symbol which EXPS can find in VAR.
@ -280,6 +280,27 @@ be skipped; if nil, as is usual, `macroexp-const-p' is used."
(macroexp-let* (list (list ,var ,expsym))
,bodysym)))))
(defun macroexp--maxsize (exp size)
(cond ((< size 0) size)
((symbolp exp) (1- size))
((stringp exp) (- size (/ (length exp) 16)))
((vectorp exp)
(dotimes (i (length exp))
(setq size (macroexp--maxsize (aref exp i) size)))
(1- size))
((consp exp)
;; We could try to be more clever with quote&function,
;; but it is difficult to do so correctly, and it's not obvious that
;; it would be worth the effort.
(dolist (e exp)
(setq size (macroexp--maxsize e size)))
(1- size))
(t -1)))
(defun macroexp-small-p (exp)
"Return non-nil if EXP can be considered small."
(> (macroexp--maxsize exp 10) 0))
(defsubst macroexp--const-symbol-p (symbol &optional any-value)
"Non-nil if SYMBOL is constant.
If ANY-VALUE is nil, only return non-nil if the value of the symbol is the

4
lisp/emacs-lisp/pcase.el
View file

@ -210,7 +210,7 @@ of the form (UPAT EXP)."
(defun pcase--expand (exp cases)
;; (message "pid=%S (pcase--expand %S ...hash=%S)"
;; (emacs-pid) exp (sxhash cases))
(macroexp-let² macroexp-copyable-p val exp
(macroexp-let2 macroexp-copyable-p val exp
(let* ((defs ())
(seen '())
(codegen
@ -617,7 +617,7 @@ Otherwise, it defers to REST which is a list of branches of the form
;; A upat of the form (let VAR EXP).
;; (pcase--u1 matches code
;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
(macroexp-let²
(macroexp-let2
macroexp-copyable-p sym
(let* ((exp (nth 2 upat))
(found (assq exp vars)))

10
lisp/emacs-lisp/smie.el
View file

@ -307,7 +307,7 @@ be either:
(dolist (op (cdr (assoc first-nt first-ops-table)))
(unless (member op first-ops)
(setq again t)
(cl-push op (cdr first-ops))))))))
(push op (cdr first-ops))))))))
;; Same thing for last-ops.
(setq again t)
(while (prog1 again (setq again nil))
@ -318,7 +318,7 @@ be either:
(dolist (op (cdr (assoc last-nt last-ops-table)))
(unless (member op last-ops)
(setq again t)
(cl-push op (cdr last-ops))))))))
(push op (cdr last-ops))))))))
;; Now generate the 2D precedence table.
(dolist (rules bnf)
(dolist (rhs (cdr rules))
@ -601,10 +601,10 @@ PREC2 is a table as returned by `smie-precs->prec2' or
;; left side of any < constraint).
(dolist (x table)
(unless (nth 1 x)
(cl-setf (nth 1 x) i)
(setf (nth 1 x) i)
(cl-incf i)) ;See other (cl-incf i) above.
(unless (nth 2 x)
(cl-setf (nth 2 x) i)
(setf (nth 2 x) i)
(cl-incf i)))) ;See other (cl-incf i) above.
;; Mark closers and openers.
(dolist (x (gethash :smie-open/close-alist prec2))
@ -613,7 +613,7 @@ PREC2 is a table as returned by `smie-precs->prec2' or
(`closer (cddr (assoc token table)))
(`opener (cdr (assoc token table))))))
(cl-assert (numberp (car cons)))
(cl-setf (car cons) (list (car cons)))))
(setf (car cons) (list (car cons)))))
(let ((ca (gethash :smie-closer-alist prec2)))
(when ca (push (cons :smie-closer-alist ca) table)))
;; (smie-check-grammar table prec2 'step3)

4
lisp/emacs-lisp/syntax.el
View file

@ -513,7 +513,7 @@ Point is at POS when this function returns."
nil nil ppss))
(let ((pair (cons pt-min ppss)))
(if cache-pred
(cl-push pair (cdr cache-pred))
(push pair (cdr cache-pred))
(push pair syntax-ppss-cache))))
;; Compute the actual return value.
@ -533,7 +533,7 @@ Point is at POS when this function returns."
(let ((pair (cons pos ppss)))
(if cache-pred
(if (> (- (caar cache-pred) pos) syntax-ppss-max-span)
(cl-push pair (cdr cache-pred))
(push pair (cdr cache-pred))
(setcar cache-pred pair))
(if (or (null syntax-ppss-cache)
(> (- (caar syntax-ppss-cache) pos)

40
lisp/emacs-lisp/timer.el
View file

@ -54,13 +54,13 @@
(timer--low-seconds timer)
(timer--usecs timer)))
(cl-defsetf timer--time
(gv-define-simple-setter timer--time
(lambda (timer time)
(or (timerp timer) (error "Invalid timer"))
(cl-setf (timer--high-seconds timer) (pop time))
(cl-setf (timer--low-seconds timer)
(if (consp time) (car time) time))
(cl-setf (timer--usecs timer) (or (and (consp time) (consp (cdr time))
(setf (timer--high-seconds timer) (pop time))
(setf (timer--low-seconds timer)
(if (consp time) (car time) time))
(setf (timer--usecs timer) (or (and (consp time) (consp (cdr time))
(cadr time))
0))))
@ -70,8 +70,8 @@
TIME must be in the internal format returned by, e.g., `current-time'.
If optional third argument DELTA is a positive number, make the timer
fire repeatedly that many seconds apart."
(cl-setf (timer--time timer) time)
(cl-setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta))
(setf (timer--time timer) time)
(setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta))
timer)
(defun timer-set-idle-time (timer secs &optional repeat)
@ -81,10 +81,10 @@ time format (HIGH LOW USECS) returned by, e.g., `current-idle-time'.
If optional third argument REPEAT is non-nil, make the timer
fire each time Emacs is idle for that many seconds."
(if (consp secs)
(cl-setf (timer--time timer) secs)
(cl-setf (timer--time timer) '(0 0 0))
(setf (timer--time timer) secs)
(setf (timer--time timer) '(0 0 0))
(timer-inc-time timer secs))
(cl-setf (timer--repeat-delay timer) repeat)
(setf (timer--repeat-delay timer) repeat)
timer)
(defun timer-next-integral-multiple-of-time (time secs)
@ -124,8 +124,8 @@ SECS may be either an integer or a floating point number."
(defun timer-inc-time (timer secs &optional usecs)
"Increment the time set in TIMER by SECS seconds and USECS microseconds.
SECS may be a fraction. If USECS is omitted, that means it is zero."
(cl-setf (timer--time timer)
(timer-relative-time (timer--time timer) secs usecs)))
(setf (timer--time timer)
(timer-relative-time (timer--time timer) secs usecs)))
(defun timer-set-time-with-usecs (timer time usecs &optional delta)
"Set the trigger time of TIMER to TIME plus USECS.
@ -133,9 +133,9 @@ TIME must be in the internal format returned by, e.g., `current-time'.
The microsecond count from TIME is ignored, and USECS is used instead.
If optional fourth argument DELTA is a positive number, make the timer
fire repeatedly that many seconds apart."
(cl-setf (timer--time timer) time)
(cl-setf (timer--usecs timer) usecs)
(cl-setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta))
(setf (timer--time timer) time)
(setf (timer--usecs timer) usecs)
(setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta))
timer)
(make-obsolete 'timer-set-time-with-usecs
"use `timer-set-time' and `timer-inc-time' instead."
@ -145,8 +145,8 @@ fire repeatedly that many seconds apart."
"Make TIMER call FUNCTION with optional ARGS when triggering."
(or (timerp timer)
(error "Invalid timer"))
(cl-setf (timer--function timer) function)
(cl-setf (timer--args timer) args)
(setf (timer--function timer) function)
(setf (timer--args timer) args)
timer)
(defun timer--activate (timer &optional triggered-p reuse-cell idle)
@ -170,8 +170,8 @@ fire repeatedly that many seconds apart."
(cond (last (setcdr last reuse-cell))
(idle (setq timer-idle-list reuse-cell))
(t (setq timer-list reuse-cell)))
(cl-setf (timer--triggered timer) triggered-p)
(cl-setf (timer--idle-delay timer) idle)
(setf (timer--triggered timer) triggered-p)
(setf (timer--idle-delay timer) idle)
nil)
(error "Invalid or uninitialized timer")))
@ -294,7 +294,7 @@ This function is called, by name, directly by the C code."
(apply (timer--function timer) (timer--args timer)))
(error nil))
(if retrigger
(cl-setf (timer--triggered timer) nil)))
(setf (timer--triggered timer) nil)))
(error "Bogus timer event"))))
;; This function is incompatible with the one in levents.el.

8
lisp/files.el
View file

@ -782,10 +782,10 @@ one or more of those symbols."
(read-file-name-internal string pred action))
((eq (car-safe action) 'boundaries)
(let ((suffix (cdr action)))
(list* 'boundaries
(length (file-name-directory string))
(let ((x (file-name-directory suffix)))
(if x (1- (length x)) (length suffix))))))
`(boundaries
,(length (file-name-directory string))
,@(let ((x (file-name-directory suffix)))
(if x (1- (length x)) (length suffix))))))
(t
(let ((names '())
;; If we have files like "foo.el" and "foo.elc", we could load one of

2100
lisp/ldefs-boot.el
View file

File diff suppressed because it is too large Load diff

15
lisp/loadup.el
View file

@ -252,6 +252,21 @@
;For other systems, you must edit ../src/Makefile.in.
(load "site-load" t)
;; ¡¡¡ Big Ugly Hack !!!
;; src/boostrap-emacs is mostly used to compile .el files, so it needs
;; macroexp, bytecomp, cconv, and byte-opt to be fast. Generally this is done
;; by compiling those files first, but this only makes a difference if those
;; files are not preloaded. As it so happens, macroexp.el tends to be
;; accidentally preloaded in src/boostrap-emacs because cl.el and cl-macs.el
;; require it. So lets unload it here, if needed, to make sure the
;; byte-compiled version is used.
(if (or (not (fboundp 'macroexpand-all))
(byte-code-function-p (symbol-function 'macroexpand-all)))
nil
(fmakunbound 'macroexpand-all)
(setq features (delq 'macroexp features))
(autoload 'macroexpand-all "macroexp"))
;; Determine which last version number to use
;; based on the executables that now exist.
(if (and (or (equal (nth 3 command-line-args) "dump")

7
lisp/scroll-bar.el
View file

@ -123,9 +123,10 @@ the mode if ARG is omitted or nil.
This command applies to all frames that exist and frames to be
created in the future."
:variable (eq (get-scroll-bar-mode)
(or previous-scroll-bar-mode
default-frame-scroll-bars)))
:variable ((get-scroll-bar-mode)
. (lambda (v) (set-scroll-bar-mode
(if v (or previous-scroll-bar-mode
default-frame-scroll-bars))))))
(defun toggle-scroll-bar (arg)
"Toggle whether or not the selected frame has vertical scroll bars.

16
lisp/simple.el
View file

@ -5425,7 +5425,9 @@ non-`nil'.
The value of `normal-auto-fill-function' specifies the function to use
for `auto-fill-function' when turning Auto Fill mode on."
:variable (eq auto-fill-function normal-auto-fill-function))
:variable (auto-fill-function
. (lambda (v) (setq auto-fill-function
(if v normal-auto-fill-function)))))
;; This holds a document string used to document auto-fill-mode.
(defun auto-fill-function ()
@ -5538,7 +5540,8 @@ the line. Before a tab, such characters insert until the tab is
filled in. \\[quoted-insert] still inserts characters in
overwrite mode; this is supposed to make it easier to insert
characters when necessary."
:variable (eq overwrite-mode 'overwrite-mode-textual))
:variable (overwrite-mode
. (lambda (v) (setq overwrite-mode (if v 'overwrite-mode-textual)))))
(define-minor-mode binary-overwrite-mode
"Toggle Binary Overwrite mode.
@ -5557,7 +5560,8 @@ ordinary typing characters do.
Note that Binary Overwrite mode is not its own minor mode; it is
a specialization of overwrite mode, entered by setting the
`overwrite-mode' variable to `overwrite-mode-binary'."
:variable (eq overwrite-mode 'overwrite-mode-binary))
:variable (overwrite-mode
. (lambda (v) (setq overwrite-mode (if v 'overwrite-mode-binary)))))
(define-minor-mode line-number-mode
"Toggle line number display in the mode line (Line Number mode).
@ -6780,8 +6784,10 @@ probably not turn on this mode on a text-only terminal if you don't
have both Backspace, Delete and F1 keys.
See also `normal-erase-is-backspace'."
:variable (eq (terminal-parameter
nil 'normal-erase-is-backspace) 1)
:variable ((eq (terminal-parameter nil 'normal-erase-is-backspace) 1)
. (lambda (v)
(setf (terminal-parameter nil 'normal-erase-is-backspace)
(if v 1 0))))
(let ((enabled (eq 1 (terminal-parameter
nil 'normal-erase-is-backspace))))

48
lisp/subr.el
View file

@ -26,6 +26,9 @@
;;; Code:
;; Beware: while this file has tag `utf-8', before it's compiled, it gets
;; loaded as "raw-text", so non-ASCII chars won't work right during bootstrap.
(defvar custom-declare-variable-list nil
"Record `defcustom' calls made before `custom.el' is loaded to handle them.
Each element of this list holds the arguments to one call to `defcustom'.")
@ -144,29 +147,33 @@ was called."
`(closure (t) (&rest args)
(apply ',fun ,@(mapcar (lambda (arg) `',arg) args) args)))
(if (null (featurep 'cl))
(progn
;; If we reload subr.el after having loaded CL, be careful not to
;; overwrite CL's extended definition of `dolist', `dotimes',
;; `declare', `push' and `pop'.
(defmacro push (newelt listname)
"Add NEWELT to the list stored in the symbol LISTNAME.
This is equivalent to (setq LISTNAME (cons NEWELT LISTNAME)).
LISTNAME must be a symbol."
(declare (debug (form sexp)))
(list 'setq listname
(list 'cons newelt listname)))
(defmacro push (newelt place)
"Add NEWELT to the list stored in the generalized variable PLACE.
This is morally equivalent to (setf PLACE (cons NEWELT PLACE)),
except that PLACE is only evaluated once (after NEWELT)."
(declare (debug (form gv-place)))
(if (symbolp place)
;; Important special case, to avoid triggering GV too early in
;; the bootstrap.
(list 'setq place
(list 'cons newelt place))
(require 'macroexp)
(macroexp-let2 macroexp-copyable-p v newelt
(gv-letplace (getter setter) place
(funcall setter `(cons ,v ,getter))))))
(defmacro pop (listname)
"Return the first element of LISTNAME's value, and remove it from the list.
LISTNAME must be a symbol whose value is a list.
(defmacro pop (place)
"Return the first element of PLACE's value, and remove it from the list.
PLACE must be a generalized variable whose value is a list.
If the value is nil, `pop' returns nil but does not actually
change the list."
(declare (debug (sexp)))
(declare (debug (gv-place)))
(list 'car
(list 'prog1 listname
(list 'setq listname (list 'cdr listname)))))
))
(if (symbolp place)
;; So we can use `pop' in the bootstrap before `gv' can be used.
(list 'prog1 place (list 'setq place (list 'cdr place)))
(gv-letplace (getter setter) place
`(prog1 ,getter ,(funcall setter `(cdr ,getter)))))))
(defmacro when (cond &rest body)
"If COND yields non-nil, do BODY, else return nil.
@ -189,8 +196,7 @@ value of last one, or nil if there are none.
(if (null (featurep 'cl))
(progn
;; If we reload subr.el after having loaded CL, be careful not to
;; overwrite CL's extended definition of `dolist', `dotimes',
;; `declare', `push' and `pop'.
;; overwrite CL's extended definition of `dolist', `dotimes', `declare'.
(defmacro dolist (spec &rest body)
"Loop over a list.

12
lisp/winner.el
View file

@ -138,7 +138,7 @@ You may want to include buffer names such as *Help*, *Apropos*,
;; Consult `winner-currents'.
(defun winner-configuration (&optional frame)
(or (cdr (assq (or frame (selected-frame)) winner-currents))
(letf (((selected-frame) frame))
(with-selected-frame frame
(winner-conf))))
@ -248,7 +248,7 @@ You may want to include buffer names such as *Help*, *Apropos*,
((window-minibuffer-p (selected-window))
(other-window 1)))
(when (/= minisize (window-height miniwin))
(letf (((selected-window) miniwin) )
(with-selected-window miniwin
(setf (window-height) minisize)))))
@ -261,7 +261,7 @@ You may want to include buffer names such as *Help*, *Apropos*,
;; Format of entries: (buffer (mark . mark-active) (window . point) ..)
(defun winner-make-point-alist ()
(letf (((current-buffer)))
(save-current-buffer
(loop with alist
for win in (winner-window-list)
for entry =
@ -282,10 +282,10 @@ You may want to include buffer names such as *Help*, *Apropos*,
(entry
(or (cdr (assq win (cddr entry)))
(cdr (assq nil (cddr entry)))
(letf (((current-buffer) buf))
(with-current-buffer buf
(push (cons nil (point)) (cddr entry))
(point))))
(t (letf (((current-buffer) buf))
(t (with-current-buffer buf
(push (list buf
(cons (mark t) (winner-active-region))
(cons nil (point)))
@ -320,7 +320,7 @@ You may want to include buffer names such as *Help*, *Apropos*,
(push win xwins))) ; delete this window
;; Restore marks
(letf (((current-buffer)))
(save-current-buffer
(loop for buf in buffers
for entry = (cadr (assq buf winner-point-alist))
do (progn (set-buffer buf)