diff options
| author | Stefan Monnier <monnier@iro.umontreal.ca> | 2012-07-11 19:13:41 -0400 |
|---|---|---|
| committer | Stefan Monnier <monnier@iro.umontreal.ca> | 2012-07-11 19:13:41 -0400 |
| commit | a464a6c73acf27b0d633d428919a36bc16a9d442 (patch) | |
| tree | bcba70ce0242bfd5987356c750ba4eb6b58820b1 /lisp/emacs-lisp/cl.el | |
| parent | c214e35e489145bd3a8ab7a353671f947368a7ae (diff) | |
| download | emacs-a464a6c73acf27b0d633d428919a36bc16a9d442.tar.gz emacs-a464a6c73acf27b0d633d428919a36bc16a9d442.tar.bz2 emacs-a464a6c73acf27b0d633d428919a36bc16a9d442.zip | |
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.
Diffstat (limited to 'lisp/emacs-lisp/cl.el')
| -rw-r--r-- | lisp/emacs-lisp/cl.el | 165 |
1 files changed, 42 insertions, 123 deletions
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 |