diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/cl-extra.el | 19 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-lib.el | 7 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 109 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl.el | 165 | ||||
| -rw-r--r-- | lisp/emacs-lisp/elint.el | 3 | ||||
| -rw-r--r-- | lisp/emacs-lisp/pcase.el | 17 |
6 files changed, 158 insertions, 162 deletions
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index b721ceba2ef..ea5e1cf9beb 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -313,25 +313,6 @@ If so, return the true (non-nil) value returned by PREDICATE. (t (make-frame-visible frame))) val) -;;; Support for `cl-progv'. -(defvar cl--progv-save) -;;;###autoload -(defun cl--progv-before (syms values) - (while syms - (push (if (boundp (car syms)) - (cons (car syms) (symbol-value (car syms))) - (car syms)) cl--progv-save) - (if values - (set (pop syms) (pop values)) - (makunbound (pop syms))))) - -(defun cl--progv-after () - (while cl--progv-save - (if (consp (car cl--progv-save)) - (set (car (car cl--progv-save)) (cdr (car cl--progv-save))) - (makunbound (car cl--progv-save))) - (pop cl--progv-save))) - ;;; Numbers. diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index b9a5d4b2fc9..aa12c709b1a 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -230,12 +230,13 @@ one value." "Apply FUNCTION to ARGUMENTS, taking multiple values into account. This implementation only handles the case where there is only one argument.") -(defsubst cl-nth-value (n expression) +(cl--defalias 'cl-nth-value #'nth "Evaluate EXPRESSION to get multiple values and return the Nth one. This handles multiple values in Common Lisp style, but it does not work right when EXPRESSION calls an ordinary Emacs Lisp function that returns just -one value." - (nth n expression)) +one value. + +\(fn N EXPRESSION)") ;;; Declarations. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 39e230cb32c..31d20f274ed 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -624,7 +624,7 @@ Key values are compared by `eql'. ;;;###autoload (defmacro cl-ecase (expr &rest clauses) - "Like `cl-case', but error if no cl-case fits. + "Like `cl-case', but error if no case fits. `otherwise'-clauses are not allowed. \n(fn EXPR (KEYLIST BODY...)...)" (declare (indent 1) (debug cl-case)) @@ -1482,7 +1482,8 @@ Then evaluate RESULT to get return value, default nil. An implicit nil block is established around the loop. \(fn (VAR LIST [RESULT]) BODY...)" - (declare (debug ((symbolp form &optional form) cl-declarations body))) + (declare (debug ((symbolp form &optional form) cl-declarations body)) + (indent 1)) `(cl-block nil (,(if (eq 'cl-dolist (symbol-function 'dolist)) 'cl--dolist 'dolist) ,spec ,@body))) @@ -1495,7 +1496,7 @@ to COUNT, exclusive. Then evaluate RESULT to get return value, default nil. \(fn (VAR COUNT [RESULT]) BODY...)" - (declare (debug cl-dolist)) + (declare (debug cl-dolist) (indent 1)) `(cl-block nil (,(if (eq 'cl-dotimes (symbol-function 'dotimes)) 'cl--dotimes 'dotimes) ,spec ,@body))) @@ -1546,10 +1547,19 @@ second list (or made unbound if VALUES is shorter than SYMBOLS); then the BODY forms are executed and their result is returned. This is much like a `let' form, except that the list of symbols can be computed at run-time." (declare (indent 2) (debug (form form body))) - `(let ((cl--progv-save nil)) - (unwind-protect - (progn (cl--progv-before ,symbols ,values) ,@body) - (cl--progv-after)))) + (let ((bodyfun (make-symbol "body")) + (binds (make-symbol "binds")) + (syms (make-symbol "syms")) + (vals (make-symbol "vals"))) + `(progn + (defvar ,bodyfun) + (let* ((,syms ,symbols) + (,vals ,values) + (,bodyfun (lambda () ,@body)) + (,binds ())) + (while ,syms + (push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds)) + (eval (list 'let ,binds '(funcall ,bodyfun))))))) (defvar cl--labels-convert-cache nil) @@ -1600,7 +1610,7 @@ Like `cl-labels' but the definitions are not recursive. Like `cl-flet' but the definitions can refer to previous ones. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - (declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body))) + (declare (indent 1) (debug cl-flet)) (cond ((null bindings) (macroexp-progn body)) ((null (cdr bindings)) `(cl-flet ,bindings ,@body)) @@ -1609,7 +1619,8 @@ Like `cl-flet' but the definitions can refer to previous ones. ;;;###autoload (defmacro cl-labels (bindings &rest body) "Make temporary function bindings. -The bindings can be recursive. Assumes the use of `lexical-binding'. +The bindings can be recursive and the scoping is lexical, but capturing them +in closures will only work if `lexical-binding' is in use. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug cl-flet)) @@ -1911,6 +1922,86 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. (macroexp-let* `((,temp ,getter)) `(progn ,(funcall setter form) nil)))))) +;; FIXME: `letf' is unsatisfactory because it does not really "restore" the +;; previous state. If the getter/setter loses information, that info is +;; not recovered. + +(defun cl--letf (bindings simplebinds binds body) + ;; It's not quite clear what the semantics of cl-letf should be. + ;; E.g. in (cl-letf ((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 + (delq nil + (mapcar (lambda (x) + (pcase x + ;; If there's no vnew, do nothing. + (`(,_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))))))) + +;;;###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 `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))) + (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) + `(let ,bindings ,@body) + (cl--letf bindings () () body))) + +;;;###autoload +(defmacro cl-letf* (bindings &rest body) + "Temporarily bind to PLACEs. +Like `cl-letf' but where the bindings are performed one at a time, +rather than all at the end (i.e. like `let*' rather than like `let')." + (declare (indent 1) (debug cl-letf)) + (dolist (binding (reverse bindings)) + (setq body (list `(cl-letf (,binding) ,@body)))) + (macroexp-progn body)) + ;;;###autoload (defmacro cl-callf (func place &rest args) "Set PLACE to (FUNC PLACE ARGS...). diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 04ff194a3bf..e1e40029491 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -222,7 +222,7 @@ callf2 callf letf* - letf + ;; letf rotatef shiftf remf @@ -449,16 +449,6 @@ Common Lisp. (setq body (list `(lexical-let (,(pop bindings)) ,@body)))) (car body))) -(defmacro cl--symbol-function (symbol) - "Like `symbol-function' but return `cl--unbound' if not bound." - ;; (declare (gv-setter (lambda (store) - ;; `(if (eq ,store 'cl--unbound) - ;; (fmakunbound ,symbol) (fset ,symbol ,store))))) - `(if (fboundp ,symbol) (symbol-function ,symbol) 'cl--unbound)) -(gv-define-setter cl--symbol-function (store symbol) - `(if (eq ,store 'cl--unbound) (fmakunbound ,symbol) (fset ,symbol ,store))) - - ;; This should really have some way to shadow 'byte-compile properties, etc. (defmacro flet (bindings &rest body) "Make temporary overriding function definitions. @@ -470,38 +460,36 @@ then the definitions are undone (the FUNCs go back to their previous definitions, or lack thereof). \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - (declare (indent 1) (debug cl-flet)) - `(letf* ,(mapcar - (lambda (x) - (if (or (and (fboundp (car x)) - (eq (car-safe (symbol-function (car x))) 'macro)) - (cdr (assq (car x) macroexpand-all-environment))) - (error "Use `labels', not `flet', to rebind macro names")) - (let ((func `(cl-function - (lambda ,(cadr x) - (cl-block ,(car x) ,@(cddr x)))))) - (when (cl--compiling-file) - ;; Bug#411. It would be nice to fix this. - (and (get (car x) 'byte-compile) - (error "Byte-compiling a redefinition of `%s' \ + (declare (indent 1) (debug cl-flet) + (obsolete "Use either `cl-flet' or `cl-letf'." "24.2")) + `(letf ,(mapcar + (lambda (x) + (if (or (and (fboundp (car x)) + (eq (car-safe (symbol-function (car x))) 'macro)) + (cdr (assq (car x) macroexpand-all-environment))) + (error "Use `labels', not `flet', to rebind macro names")) + (let ((func `(cl-function + (lambda ,(cadr x) + (cl-block ,(car x) ,@(cddr x)))))) + (when (cl--compiling-file) + ;; Bug#411. It would be nice to fix this. + (and (get (car x) 'byte-compile) + (error "Byte-compiling a redefinition of `%s' \ will not work - use `labels' instead" (symbol-name (car x)))) - ;; FIXME This affects the rest of the file, when it - ;; should be restricted to the flet body. - (and (boundp 'byte-compile-function-environment) - (push (cons (car x) (eval func)) - byte-compile-function-environment))) - (list `(symbol-function ',(car x)) func))) - bindings) + ;; FIXME This affects the rest of the file, when it + ;; should be restricted to the flet body. + (and (boundp 'byte-compile-function-environment) + (push (cons (car x) (eval func)) + byte-compile-function-environment))) + (list `(symbol-function ',(car x)) func))) + bindings) ,@body)) -(make-obsolete 'flet "Use either `cl-flet' or `letf'." "24.2") (defmacro labels (bindings &rest body) "Make temporary function bindings. -This is like `flet', except the bindings are lexical instead of dynamic. -Unlike `flet', this macro is fully compliant with the Common Lisp standard. - -\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - (declare (indent 1) (debug cl-flet)) +Like `cl-labels' except that the lexical scoping is handled via `lexical-let' +rather than relying on `lexical-binding'." + (declare (indent 1) (debug cl-flet) (obsolete 'cl-labels "24.2")) (let ((vars nil) (sets nil) (newenv macroexpand-all-environment)) (dolist (binding bindings) ;; It's important that (not (eq (symbol-name var1) (symbol-name var2))) @@ -521,93 +509,24 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard. ;; not 100% compatible: not worth the trouble to add them to cl-lib.el, but we ;; still need to support old users of cl.el. -;; FIXME: `letf' is unsatisfactory because it does not really "restore" the -;; previous state. If the getter/setter loses information, that info is -;; not recovered. - -(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))) - (if (eq (car-safe (car binding)) 'symbol-function) - (setcar (car binding) 'cl--symbol-function)) - (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 cl--symbol-function (symbol) + "Like `symbol-function' but return `cl--unbound' if not bound." + ;; (declare (gv-setter (lambda (store) + ;; `(if (eq ,store 'cl--unbound) + ;; (fmakunbound ,symbol) (fset ,symbol ,store))))) + `(if (fboundp ,symbol) (symbol-function ,symbol) 'cl--unbound)) +(gv-define-setter cl--symbol-function (store symbol) + `(if (eq ,store 'cl--unbound) (fmakunbound ,symbol) (fset ,symbol ,store))) (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)) - (if (eq (car-safe (car binding)) 'symbol-function) - (setcar (car binding) 'cl--symbol-function)) - (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)) + "Dynamically scoped let-style bindings for places. +Like `cl-letf', but with some extra backward compatibility." + ;; Like cl-letf, but with special handling of symbol-function. + `(cl-letf ,(mapcar (lambda (x) (if (eq (car-safe (car x)) 'symbol-function) + `((cl--symbol-function ,@(cdar x)) ,@(cdr x)) + x)) + bindings) + ,@body)) (defun cl--gv-adapt (cl-gv do) ;; This function is used by all .elc files that use define-setf-expander and diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index 82e958533e8..55915813877 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -466,6 +466,9 @@ Return nil if there are no more forms, t otherwise." (add-to-list 'elint-features name) ;; cl loads cl-macs in an opaque manner. ;; Since cl-macs requires cl, we can just process cl-macs. + ;; FIXME: AFAIK, `cl' now behaves properly and does not need any + ;; special treatment any more. Can someone who understands this + ;; code confirm? --Stef (and (eq name 'cl) (not elint-doing-cl) ;; We need cl if elint-form is to be able to expand cl macros. (require 'cl) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 59dccb35952..3f4ce605cb0 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -64,7 +64,7 @@ ;; (defconst pcase--memoize-1 (make-hash-table :test 'eq)) ;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal)) -(defconst pcase--dontcare-upats '(t _ dontcare)) +(defconst pcase--dontcare-upats '(t _ pcase--dontcare)) (def-edebug-spec pcase-UPAT @@ -154,11 +154,12 @@ like `(,a . ,(pred (< a))) or, with more checks: (pcase--expand (cadr binding) `((,(car binding) ,(pcase--let* bindings body)) - ;; We can either signal an error here, or just use `dontcare' which - ;; generates more efficient code. In practice, if we use `dontcare' - ;; we will still often get an error and the few cases where we don't - ;; do not matter that much, so it's a better choice. - (dontcare nil))))))) + ;; We can either signal an error here, or just use `pcase--dontcare' + ;; which generates more efficient code. In practice, if we use + ;; `pcase--dontcare' we will still often get an error and the few + ;; cases where we don't do not matter that much, so + ;; it's a better choice. + (pcase--dontcare nil))))))) ;;;###autoload (defmacro pcase-let* (bindings &rest body) @@ -275,7 +276,7 @@ of the form (UPAT EXP)." vars)))) cases)))) (dolist (case cases) - (unless (or (memq case used-cases) (eq (car case) 'dontcare)) + (unless (or (memq case used-cases) (eq (car case) 'pcase--dontcare)) (message "Redundant pcase pattern: %S" (car case)))) (macroexp-let* defs main)))) @@ -575,7 +576,7 @@ Otherwise, it defers to REST which is a list of branches of the form (upat (cdr cdrpopmatches))) (cond ((memq upat '(t _)) (pcase--u1 matches code vars rest)) - ((eq upat 'dontcare) :pcase--dontcare) + ((eq upat 'pcase--dontcare) :pcase--dontcare) ((memq (car-safe upat) '(guard pred)) (if (eq (car upat) 'pred) (put sym 'pcase-used t)) (let* ((splitrest |