Commit a464a6c7 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

More CL cleanups and reduction of use of cl.el.

* woman.el, winner.el, vc/vc-rcs.el, vc/vc-hooks.el, vc/vc-hg.el:
* vc/vc-git.el, vc/vc-dir.el, vc/vc-bzr.el, vc/vc-annotate.el:
* textmodes/tex-mode.el, textmodes/sgml-mode.el, tar-mode.el:
* strokes.el, ses.el, server.el, progmodes/js.el, progmodes/gdb-mi.el:
* progmodes/flymake.el, progmodes/ebrowse.el, progmodes/compile.el:
* play/tetris.el, play/snake.el, play/pong.el, play/landmark.el:
* play/hanoi.el, play/decipher.el, play/5x5.el, nxml/nxml-mode.el:
* net/secrets.el, net/quickurl.el, midnight.el, mail/footnote.el:
* image-dired.el, ibuffer.el, ibuf-macs.el, ibuf-ext.el, hexl.el:
* eshell/eshell.el, eshell/esh-io.el, eshell/esh-ext.el:
* eshell/esh-cmd.el, eshell/em-ls.el, eshell/em-hist.el:
* eshell/em-cmpl.el, eshell/em-banner.el:
* url/url.el, url/url-queue.el, url/url-parse.el, url/url-http.el:
* url/url-future.el, url/url-dav.el, url/url-cookie.el:
* calendar/parse-time.el, test/eshell.el: Use cl-lib.
* wid-browse.el, wdired.el, vc/vc.el, vc/vc-mtn.el, vc/vc-cvs.el:
* vc/vc-arch.el, tree-widget.el, textmodes/texinfo.el:
* textmodes/refill.el, textmodes/css-mode.el, term/tvi970.el:
* term/ns-win.el, term.el, shell.el, ps-samp.el:
* progmodes/perl-mode.el, progmodes/pascal.el, progmodes/gud.el:
* progmodes/glasses.el, progmodes/etags.el, progmodes/cwarn.el:
* play/gamegrid.el, play/bubbles.el, novice.el, notifications.el:
* net/zeroconf.el, net/xesam.el, net/snmp-mode.el, net/mairix.el:
* net/ldap.el, net/eudc.el, net/browse-url.el, man.el:
* mail/mailheader.el, mail/feedmail.el:
* url/url-util.el, url/url-privacy.el, url/url-nfs.el, url/url-misc.el:
* url/url-methods.el, url/url-gw.el, url/url-file.el, url/url-expand.el:
Dont use CL.
* ibuf-ext.el (ibuffer-mark-old-buffers): Use float-time.
* eshell/esh-opt.el (eshell-eval-using-options): Quote code with
`lambda' rather than with `quote'.
(eshell-do-opt): Adjust accordingly.
(eshell-process-option): Simplify.
* eshell/esh-var.el:
* eshell/em-script.el: Require `esh-opt' for eshell-eval-using-options.
* emacs-pcase.el (pcase--dontcare-upats, pcase--let*)
(pcase--expand, pcase--u1): Rename pcase's internal `dontcare' pattern
to `pcase--dontcare'.
* emacs-cl.el (labels): Mark obsolete.
(cl--letf, letf): Move to cl-lib.
(cl--letf*, letf*): Remove.
* emacs-cl-lib.el (cl-nth-value): Use defalias.
* emacs-cl-macs.el (cl-dolist, cl-dotimes): Add indent rule.
(cl-progv): Rewrite.
(cl--letf, cl-letf): Move from cl.el.
(cl-letf*): New macro.
* emacs-cl-extra.el (cl--progv-before, cl--progv-after): Remove.
parent c214e35e
2012-07-11 Stefan Monnier <monnier@iro.umontreal.ca>
More CL cleanups and reduction of use of cl.el.
* woman.el, winner.el, vc/vc-rcs.el, vc/vc-hooks.el, vc/vc-hg.el:
* vc/vc-git.el, vc/vc-dir.el, vc/vc-bzr.el, vc/vc-annotate.el:
* textmodes/tex-mode.el, textmodes/sgml-mode.el, tar-mode.el:
* strokes.el, ses.el, server.el, progmodes/js.el, progmodes/gdb-mi.el:
* progmodes/flymake.el, progmodes/ebrowse.el, progmodes/compile.el:
* play/tetris.el, play/snake.el, play/pong.el, play/landmark.el:
* play/hanoi.el, play/decipher.el, play/5x5.el, nxml/nxml-mode.el:
* net/secrets.el, net/quickurl.el, midnight.el, mail/footnote.el:
* image-dired.el, ibuffer.el, ibuf-macs.el, ibuf-ext.el, hexl.el:
* eshell/eshell.el, eshell/esh-io.el, eshell/esh-ext.el:
* eshell/esh-cmd.el, eshell/em-ls.el, eshell/em-hist.el:
* eshell/em-cmpl.el, eshell/em-banner.el:
* calendar/parse-time.el: Use cl-lib.
* wid-browse.el, wdired.el, vc/vc.el, vc/vc-mtn.el, vc/vc-cvs.el:
* vc/vc-arch.el, tree-widget.el, textmodes/texinfo.el:
* textmodes/refill.el, textmodes/css-mode.el, term/tvi970.el:
* term/ns-win.el, term.el, shell.el, ps-samp.el:
* progmodes/perl-mode.el, progmodes/pascal.el, progmodes/gud.el:
* progmodes/glasses.el, progmodes/etags.el, progmodes/cwarn.el:
* play/gamegrid.el, play/bubbles.el, novice.el, notifications.el:
* net/zeroconf.el, net/xesam.el, net/snmp-mode.el, net/mairix.el:
* net/ldap.el, net/eudc.el, net/browse-url.el, man.el:
* mail/mailheader.el, mail/feedmail.el: Don't use CL.
* ibuf-ext.el (ibuffer-mark-old-buffers): Use float-time.
* eshell/esh-opt.el (eshell-eval-using-options): Quote code with
`lambda' rather than with `quote'.
(eshell-do-opt): Adjust accordingly.
(eshell-process-option): Simplify.
* eshell/esh-var.el:
* eshell/em-script.el: Require `esh-opt' for eshell-eval-using-options.
* emacs-lisp/pcase.el (pcase--dontcare-upats, pcase--let*)
(pcase--expand, pcase--u1): Rename pcase's internal `dontcare' pattern
to `pcase--dontcare'.
* emacs-lisp/cl.el (labels): Mark obsolete.
(cl--letf, letf): Move to cl-lib.
(cl--letf*, letf*): Remove.
* emacs-lisp/cl-lib.el (cl-nth-value): Use defalias.
* emacs-lisp/cl-macs.el (cl-dolist, cl-dotimes): Add indent rule.
(cl-progv): Rewrite.
(cl--letf, cl-letf): Move from cl.el.
(cl-letf*): New macro.
* emacs-lisp/cl-extra.el (cl--progv-before, cl--progv-after): Remove.
2012-07-11 Michael Albinus <michael.albinus@gmx.de> 2012-07-11 Michael Albinus <michael.albinus@gmx.de>
   
* net/ange-ftp.el (ange-ftp-cf1): Update the files cache. * net/ange-ftp.el (ange-ftp-cf1): Update the files cache.
......
...@@ -34,7 +34,7 @@ ...@@ -34,7 +34,7 @@
;;; Code: ;;; Code:
(eval-when-compile (require 'cl)) ;and ah ain't kiddin' 'bout it (eval-when-compile (require 'cl-lib))
(defvar parse-time-digits (make-vector 256 nil)) (defvar parse-time-digits (make-vector 256 nil))
...@@ -43,8 +43,8 @@ ...@@ -43,8 +43,8 @@
(defvar parse-time-val) (defvar parse-time-val)
(unless (aref parse-time-digits ?0) (unless (aref parse-time-digits ?0)
(loop for i from ?0 to ?9 (cl-loop for i from ?0 to ?9
do (aset parse-time-digits i (- i ?0)))) do (aset parse-time-digits i (- i ?0))))
(defsubst digit-char-p (char) (defsubst digit-char-p (char)
(aref parse-time-digits char)) (aref parse-time-digits char))
...@@ -92,11 +92,11 @@ ...@@ -92,11 +92,11 @@
(index 0) (index 0)
(c nil)) (c nil))
(while (< index end) (while (< index end)
(while (and (< index end) ;skip invalid characters (while (and (< index end) ;Skip invalid characters.
(not (setq c (parse-time-string-chars (aref string index))))) (not (setq c (parse-time-string-chars (aref string index)))))
(incf index)) (cl-incf index))
(setq start index all-digits (eq c ?0)) (setq start index all-digits (eq c ?0))
(while (and (< (incf index) end) ;scan valid characters (while (and (< (cl-incf index) end) ;Scan valid characters.
(setq c (parse-time-string-chars (aref string index)))) (setq c (parse-time-string-chars (aref string index))))
(setq all-digits (and all-digits (eq c ?0)))) (setq all-digits (and all-digits (eq c ?0))))
(if (<= index end) (if (<= index end)
......
...@@ -313,25 +313,6 @@ If so, return the true (non-nil) value returned by PREDICATE. ...@@ -313,25 +313,6 @@ If so, return the true (non-nil) value returned by PREDICATE.
(t (make-frame-visible frame))) (t (make-frame-visible frame)))
val) 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. ;;; Numbers.
......
...@@ -230,12 +230,13 @@ one value." ...@@ -230,12 +230,13 @@ one value."
"Apply FUNCTION to ARGUMENTS, taking multiple values into account. "Apply FUNCTION to ARGUMENTS, taking multiple values into account.
This implementation only handles the case where there is only one argument.") 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. "Evaluate EXPRESSION to get multiple values and return the Nth one.
This handles multiple values in Common Lisp style, but it does not work 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 right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
one value." one value.
(nth n expression))
\(fn N EXPRESSION)")
;;; Declarations. ;;; Declarations.
......
...@@ -624,7 +624,7 @@ Key values are compared by `eql'. ...@@ -624,7 +624,7 @@ Key values are compared by `eql'.
;;;###autoload ;;;###autoload
(defmacro cl-ecase (expr &rest clauses) (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. `otherwise'-clauses are not allowed.
\n(fn EXPR (KEYLIST BODY...)...)" \n(fn EXPR (KEYLIST BODY...)...)"
(declare (indent 1) (debug cl-case)) (declare (indent 1) (debug cl-case))
...@@ -1482,7 +1482,8 @@ Then evaluate RESULT to get return value, default nil. ...@@ -1482,7 +1482,8 @@ Then evaluate RESULT to get return value, default nil.
An implicit nil block is established around the loop. An implicit nil block is established around the loop.
\(fn (VAR LIST [RESULT]) BODY...)" \(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 `(cl-block nil
(,(if (eq 'cl-dolist (symbol-function 'dolist)) 'cl--dolist 'dolist) (,(if (eq 'cl-dolist (symbol-function 'dolist)) 'cl--dolist 'dolist)
,spec ,@body))) ,spec ,@body)))
...@@ -1495,7 +1496,7 @@ to COUNT, exclusive. Then evaluate RESULT to get return value, default ...@@ -1495,7 +1496,7 @@ to COUNT, exclusive. Then evaluate RESULT to get return value, default
nil. nil.
\(fn (VAR COUNT [RESULT]) BODY...)" \(fn (VAR COUNT [RESULT]) BODY...)"
(declare (debug cl-dolist)) (declare (debug cl-dolist) (indent 1))
`(cl-block nil `(cl-block nil
(,(if (eq 'cl-dotimes (symbol-function 'dotimes)) 'cl--dotimes 'dotimes) (,(if (eq 'cl-dotimes (symbol-function 'dotimes)) 'cl--dotimes 'dotimes)
,spec ,@body))) ,spec ,@body)))
...@@ -1546,10 +1547,19 @@ second list (or made unbound if VALUES is shorter than SYMBOLS); then the ...@@ -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 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." a `let' form, except that the list of symbols can be computed at run-time."
(declare (indent 2) (debug (form form body))) (declare (indent 2) (debug (form form body)))
`(let ((cl--progv-save nil)) (let ((bodyfun (make-symbol "body"))
(unwind-protect (binds (make-symbol "binds"))
(progn (cl--progv-before ,symbols ,values) ,@body) (syms (make-symbol "syms"))
(cl--progv-after)))) (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) (defvar cl--labels-convert-cache nil)
...@@ -1600,7 +1610,7 @@ Like `cl-labels' but the definitions are not recursive. ...@@ -1600,7 +1610,7 @@ Like `cl-labels' but the definitions are not recursive.
Like `cl-flet' but the definitions can refer to previous ones. Like `cl-flet' but the definitions can refer to previous ones.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body))) (declare (indent 1) (debug cl-flet))
(cond (cond
((null bindings) (macroexp-progn body)) ((null bindings) (macroexp-progn body))
((null (cdr bindings)) `(cl-flet ,bindings ,@body)) ((null (cdr bindings)) `(cl-flet ,bindings ,@body))
...@@ -1609,7 +1619,8 @@ Like `cl-flet' but the definitions can refer to previous ones. ...@@ -1609,7 +1619,8 @@ Like `cl-flet' but the definitions can refer to previous ones.
;;;###autoload ;;;###autoload
(defmacro cl-labels (bindings &rest body) (defmacro cl-labels (bindings &rest body)
"Make temporary function bindings. "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...)" \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1) (debug cl-flet)) (declare (indent 1) (debug cl-flet))
...@@ -1911,6 +1922,86 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. ...@@ -1911,6 +1922,86 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
(macroexp-let* `((,temp ,getter)) (macroexp-let* `((,temp ,getter))
`(progn ,(funcall setter form) nil)))))) `(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 ;;;###autoload
(defmacro cl-callf (func place &rest args) (defmacro cl-callf (func place &rest args)
"Set PLACE to (FUNC PLACE ARGS...). "Set PLACE to (FUNC PLACE ARGS...).
......
...@@ -222,7 +222,7 @@ ...@@ -222,7 +222,7 @@
callf2 callf2
callf callf
letf* letf*
letf ;; letf
rotatef rotatef
shiftf shiftf
remf remf
...@@ -449,16 +449,6 @@ Common Lisp. ...@@ -449,16 +449,6 @@ Common Lisp.
(setq body (list `(lexical-let (,(pop bindings)) ,@body)))) (setq body (list `(lexical-let (,(pop bindings)) ,@body))))
(car 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. ;; This should really have some way to shadow 'byte-compile properties, etc.
(defmacro flet (bindings &rest body) (defmacro flet (bindings &rest body)
"Make temporary overriding function definitions. "Make temporary overriding function definitions.
...@@ -470,38 +460,36 @@ then the definitions are undone (the FUNCs go back to their previous ...@@ -470,38 +460,36 @@ then the definitions are undone (the FUNCs go back to their previous
definitions, or lack thereof). definitions, or lack thereof).
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1) (debug cl-flet)) (declare (indent 1) (debug cl-flet)
`(letf* ,(mapcar (obsolete "Use either `cl-flet' or `cl-letf'." "24.2"))
(lambda (x) `(letf ,(mapcar
(if (or (and (fboundp (car x)) (lambda (x)
(eq (car-safe (symbol-function (car x))) 'macro)) (if (or (and (fboundp (car x))
(cdr (assq (car x) macroexpand-all-environment))) (eq (car-safe (symbol-function (car x))) 'macro))
(error "Use `labels', not `flet', to rebind macro names")) (cdr (assq (car x) macroexpand-all-environment)))
(let ((func `(cl-function (error "Use `labels', not `flet', to rebind macro names"))
(lambda ,(cadr x) (let ((func `(cl-function
(cl-block ,(car x) ,@(cddr x)))))) (lambda ,(cadr x)
(when (cl--compiling-file) (cl-block ,(car x) ,@(cddr x))))))
;; Bug#411. It would be nice to fix this. (when (cl--compiling-file)
(and (get (car x) 'byte-compile) ;; Bug#411. It would be nice to fix this.
(error "Byte-compiling a redefinition of `%s' \ (and (get (car x) 'byte-compile)
(error "Byte-compiling a redefinition of `%s' \
will not work - use `labels' instead" (symbol-name (car x)))) will not work - use `labels' instead" (symbol-name (car x))))
;; FIXME This affects the rest of the file, when it ;; FIXME This affects the rest of the file, when it
;; should be restricted to the flet body. ;; should be restricted to the flet body.
(and (boundp 'byte-compile-function-environment) (and (boundp 'byte-compile-function-environment)
(push (cons (car x) (eval func)) (push (cons (car x) (eval func))
byte-compile-function-environment))) byte-compile-function-environment)))
(list `(symbol-function ',(car x)) func))) (list `(symbol-function ',(car x)) func)))
bindings) bindings)
,@body)) ,@body))
(make-obsolete 'flet "Use either `cl-flet' or `letf'." "24.2")
(defmacro labels (bindings &rest body) (defmacro labels (bindings &rest body)
"Make temporary function bindings. "Make temporary function bindings.
This is like `flet', except the bindings are lexical instead of dynamic. Like `cl-labels' except that the lexical scoping is handled via `lexical-let'
Unlike `flet', this macro is fully compliant with the Common Lisp standard. rather than relying on `lexical-binding'."
(declare (indent 1) (debug cl-flet) (obsolete 'cl-labels "24.2"))
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1) (debug cl-flet))
(let ((vars nil) (sets nil) (newenv macroexpand-all-environment)) (let ((vars nil) (sets nil) (newenv macroexpand-all-environment))
(dolist (binding bindings) (dolist (binding bindings)
;; It's important that (not (eq (symbol-name var1) (symbol-name var2))) ;; 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. ...@@ -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 ;; 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. ;; still need to support old users of cl.el.
;; FIXME: `letf' is unsatisfactory because it does not really "restore" the (defmacro cl--symbol-function (symbol)
;; previous state. If the getter/setter loses information, that info is "Like `symbol-function' but return `cl--unbound' if not bound."
;; not recovered. ;; (declare (gv-setter (lambda (store)
;; `(if (eq ,store 'cl--unbound)
(defun cl--letf (bindings simplebinds binds body) ;; (fmakunbound ,symbol) (fset ,symbol ,store)))))
;; It's not quite clear what the semantics of let! should be. `(if (fboundp ,symbol) (symbol-function ,symbol) 'cl--unbound))
;; E.g. in (let! ((PLACE1 VAL1) (PLACE2 VAL2)) BODY), while it's clear (gv-define-setter cl--symbol-function (store symbol)
;; that the actual assignments ("bindings") should only happen after `(if (eq ,store 'cl--unbound) (fmakunbound ,symbol) (fset ,symbol ,store)))
;; 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 letf (bindings &rest body) (defmacro letf (bindings &rest body)
"Temporarily bind to PLACEs. "Dynamically scoped let-style bindings for places.
This is the analogue of `let', but with generalized variables (in the Like `cl-letf', but with some extra backward compatibility."
sense of `setf') for the PLACEs. Each PLACE is set to the corresponding ;; Like cl-letf, but with special handling of symbol-function.
VALUE, then the BODY forms are executed. On exit, either normally or `(cl-letf ,(mapcar (lambda (x) (if (eq (car-safe (car x)) 'symbol-function)
because of a `throw' or error, the PLACEs are set back to their original `((cl--symbol-function ,@(cdar x)) ,@(cdr x))
values. Note that this macro is *not* available in Common Lisp. x))
As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', bindings)
the PLACE is not modified before executing BODY. ,@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))
(defun cl--gv-adapt (cl-gv do) (defun cl--gv-adapt (cl-gv do)
;; This function is used by all .elc files that use define-setf-expander and ;; This function is used by all .elc files that use define-setf-expander and
......
...@@ -466,6 +466,9 @@ Return nil if there are no more forms, t otherwise." ...@@ -466,6 +466,9 @@ Return nil if there are no more forms, t otherwise."
(add-to-list 'elint-features name) (add-to-list 'elint-features name)
;; cl loads cl-macs in an opaque manner. ;; cl loads cl-macs in an opaque manner.
;; Since cl-macs requires cl, we can just process cl-macs. ;; 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) (and (eq name 'cl) (not elint-doing-cl)
;; We need cl if elint-form is to be able to expand cl macros. ;; We need cl if elint-form is to be able to expand cl macros.
(require 'cl) (require 'cl)
......
...@@ -64,7 +64,7 @@ ...@@ -64,7 +64,7 @@
;; (defconst pcase--memoize-1 (make-hash-table :test 'eq)) ;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal)) ;; (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 (def-edebug-spec
pcase-UPAT pcase-UPAT
...@@ -154,11 +154,12 @@ like `(,a . ,(pred (< a))) or, with more checks: ...@@ -154,11 +154,12 @@ like `(,a . ,(pred (< a))) or, with more checks:
(pcase--expand (pcase--expand
(cadr binding) (cadr binding)
`((,(car binding) ,(pcase--let* bindings body)) `((,(car binding) ,(pcase--let* bindings body))
;; We can either signal an error here, or just use `dontcare' which ;; We can either signal an error here, or just use `pcase--dontcare'
;; generates more efficient code. In practice, if we use `dontcare' ;; which generates more efficient code. In practice, if we use
;; we will still often get an error and the few cases where we don't ;; `pcase--dontcare' we will still often get an error and the few
;; do not matter that much, so it's a better choice. ;; cases where we don't do not matter that much, so
(dontcare nil))))))) ;; it's a better choice.
(pcase--dontcare nil)))))))