diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 20 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cconv.el | 24 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-extra.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-lib.el | 31 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-loaddefs.el | 123 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 747 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl.el | 262 | ||||
| -rw-r--r-- | lisp/emacs-lisp/ewoc.el | 50 | ||||
| -rw-r--r-- | lisp/emacs-lisp/gv.el | 430 | ||||
| -rw-r--r-- | lisp/emacs-lisp/macroexp.el | 23 | ||||
| -rw-r--r-- | lisp/emacs-lisp/pcase.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/smie.el | 10 | ||||
| -rw-r--r-- | lisp/emacs-lisp/syntax.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/timer.el | 40 |
14 files changed, 970 insertions, 802 deletions
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 934c0f01fcd..650faec6bf6 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -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)) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 6f411bdeb30..5a1d6265848 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -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 diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 53c83e73d2e..e64623ab44e 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -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)))) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index bf7f6232ab7..2422aa8fbb6 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -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) diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index ef89bf81687..220715e6a9b 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -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" "\ diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 375a974db8f..234879c9cc3 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -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)))) - -;;; 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. - -(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))))) - -(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)))) +;; 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)))))))))) + +(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)))))))) + +(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))))))))) + +(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)) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index d41b72f20d4..c7a48c500c0 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -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) diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el index 02fdbc6e77f..5de3da65174 100644 --- a/lisp/emacs-lisp/ewoc.el +++ b/lisp/emacs-lisp/ewoc.el @@ -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)))) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el new file mode 100644 index 00000000000..ed7c6ed1d9d --- /dev/null +++ b/lisp/emacs-lisp/gv.el @@ -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 diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 95fe43a34a2..6275fd1cdf8 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -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 diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index f91a1645e21..529c5ebdb67 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -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))) diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 136dff6df68..be3a9828491 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -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) diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index 51bfc05ff5f..748f31464e0 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -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) diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 1c30563c6a3..0b8480441c3 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -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. |