Commit 2ee3d7f0 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

Provide generalized variables in core Elisp.

* 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
parent 575db3f1
......@@ -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'.
......
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.
......
......@@ -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))
......
......@@ -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
......@@ -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))))
......
......@@ -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)
......
......@@ -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" "\
......
This diff is collapsed.
......@@ -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))