;;; cl.el --- Compatibility aliases for the old CL library. -*- lexical-binding: t -*-
-;; Copyright (C) 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2012-2013 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: extensions
;; (delete-region (1- (point)) (point)))
;; (save-buffer)))))
+(defun cl-unload-function ()
+ "Stop unloading of the Common Lisp extensions."
+ (message "Cannot unload the feature `cl'")
+ ;; Stop standard unloading!
+ t)
+
;;; Aliases to cl-lib's features.
(dolist (var '(
))
(defvaralias var (intern (format "cl-%s" var))))
-;; Before overwriting subr.el's `dotimes' and `dolist', let's remember
-;; them under a different name, so we can use them in our implementation
-;; of `dotimes' and `dolist'.
-(unless (fboundp 'cl--dotimes)
- (defalias 'cl--dotimes (symbol-function 'dotimes) "The non-CL `dotimes'."))
-(unless (fboundp 'cl--dolist)
- (defalias 'cl--dolist (symbol-function 'dolist) "The non-CL `dolist'."))
-
(dolist (fun '(
(get* . cl-get)
(random* . cl-random)
remf
psetf
(define-setf-method . define-setf-expander)
- declare
the
locally
multiple-value-setq
psetq
do-all-symbols
do-symbols
- dotimes
- dolist
do*
do
loop
))
(let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun)))
(intern (format "cl-%s" fun)))))
- (defalias fun new)
- ;; If `cl-foo' is declare inline, then make `foo' inline as well, and
- ;; similarly. Same for edebug specifications, indent rules and
- ;; doc-string position.
- ;; FIXME: For most of them, we should instead follow aliases
- ;; where applicable.
- (dolist (prop '(byte-optimizer doc-string-elt edebug-form-spec
- lisp-indent-function))
- (if (get new prop)
- (put fun prop (get new prop))))))
+ (defalias fun new)))
+
+(defun cl--wrap-in-nil-block (fun &rest args)
+ `(cl-block nil ,(apply fun args)))
+(advice-add 'dolist :around #'cl--wrap-in-nil-block)
+(advice-add 'dotimes :around #'cl--wrap-in-nil-block)
+
+(defun cl--pass-args-to-cl-declare (&rest specs)
+ (macroexpand `(cl-declare ,@specs)))
+(advice-add 'declare :after #'cl--pass-args-to-cl-declare)
;;; Features provided a bit differently in Elisp.
(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.
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.3"))
+ `(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.3"))
(let ((vars nil) (sets nil) (newenv macroexpand-all-environment))
(dolist (binding bindings)
;; It's important that (not (eq (symbol-name var1) (symbol-name var2)))
;; 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 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))
-
(defun cl--gv-adapt (cl-gv do)
;; This function is used by all .elc files that use define-setf-expander and
- ;; were compiled with Emacs>=24.2.
+ ;; were compiled with Emacs>=24.3.
(let ((vars (nth 0 cl-gv))
(vals (nth 1 cl-gv))
(binds ())
(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."
+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', and `gv-define-setter' for better and
+simpler ways to define setf-methods."
(declare (debug
(&define name cl-lambda-list cl-declarations-or-string def-body)))
`(progn
(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:
+This macro is an easy-to-use substitute for `define-setf-expander'
+that works well for simple place forms.
- (cl-defsetf aref aset)
+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). For example:
-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:
+ (defsetf aref aset)
- (cl-defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v))
+You can replace this form with `gv-define-simple-setter'.
+
+Alternate form: (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.
+For example:
+
+ (defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v))
+
+You can replace this form with `gv-define-setter'.
\(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
(declare (debug
(cl-function
(lambda (,@(car args) ,@arg1) ,@(cdr args)))
do args)))
- `(gv-define-simple-setter ,name ,arg1)))
+ `(gv-define-simple-setter ,name ,arg1 ,(car args))))
;; 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.
;; `(,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")
+(make-obsolete 'get-setf-method 'gv-letplace "24.3")
(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)) +)"
+If NAME is called, it combines its PLACE argument with the other
+arguments from ARGLIST using FUNC. For example:
+
+ (define-modify-macro incf (&optional (n 1)) +)
+
+You can replace this macro with `gv-letplace'."
(declare (debug
(&define name cl-lambda-list ;; should exclude &key
symbolp &optional stringp)))
;;; Additional compatibility code.
;; For names that were clean but really aren't needed any more.
-(define-obsolete-function-alias 'cl-macroexpand 'macroexpand "24.2")
+(define-obsolete-function-alias 'cl-macroexpand 'macroexpand "24.3")
(define-obsolete-variable-alias 'cl-macro-environment
- 'macroexpand-all-environment "24.2")
-(define-obsolete-function-alias 'cl-macroexpand-all 'macroexpand-all "24.2")
+ 'macroexpand-all-environment "24.3")
+(define-obsolete-function-alias 'cl-macroexpand-all 'macroexpand-all "24.3")
;;; Hash tables.
;; This is just kept for compatibility with code byte-compiled by Emacs-20.
;; No idea if this might still be needed.
(defun cl-not-hash-table (x &optional y &rest _z)
- (declare (obsolete nil "24.2"))
+ (declare (obsolete nil "24.3"))
(signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))
(defvar cl-builtin-gethash (symbol-function 'gethash))
-(make-obsolete-variable 'cl-builtin-gethash nil "24.2")
+(make-obsolete-variable 'cl-builtin-gethash nil "24.3")
(defvar cl-builtin-remhash (symbol-function 'remhash))
-(make-obsolete-variable 'cl-builtin-remhash nil "24.2")
+(make-obsolete-variable 'cl-builtin-remhash nil "24.3")
(defvar cl-builtin-clrhash (symbol-function 'clrhash))
-(make-obsolete-variable 'cl-builtin-clrhash nil "24.2")
+(make-obsolete-variable 'cl-builtin-clrhash nil "24.3")
(defvar cl-builtin-maphash (symbol-function 'maphash))
-(make-obsolete-variable 'cl-builtin-maphash nil "24.2")
-(define-obsolete-function-alias 'cl-map-keymap 'map-keymap "24.2")
-(define-obsolete-function-alias 'cl-copy-tree 'copy-tree "24.2")
-(define-obsolete-function-alias 'cl-gethash 'gethash "24.2")
-(define-obsolete-function-alias 'cl-puthash 'puthash "24.2")
-(define-obsolete-function-alias 'cl-remhash 'remhash "24.2")
-(define-obsolete-function-alias 'cl-clrhash 'clrhash "24.2")
-(define-obsolete-function-alias 'cl-maphash 'maphash "24.2")
-(define-obsolete-function-alias 'cl-make-hash-table 'make-hash-table "24.2")
-(define-obsolete-function-alias 'cl-hash-table-p 'hash-table-p "24.2")
-(define-obsolete-function-alias 'cl-hash-table-count 'hash-table-count "24.2")
+(make-obsolete-variable 'cl-builtin-maphash nil "24.3")
+(define-obsolete-function-alias 'cl-map-keymap 'map-keymap "24.3")
+(define-obsolete-function-alias 'cl-copy-tree 'copy-tree "24.3")
+(define-obsolete-function-alias 'cl-gethash 'gethash "24.3")
+(define-obsolete-function-alias 'cl-puthash 'puthash "24.3")
+(define-obsolete-function-alias 'cl-remhash 'remhash "24.3")
+(define-obsolete-function-alias 'cl-clrhash 'clrhash "24.3")
+(define-obsolete-function-alias 'cl-maphash 'maphash "24.3")
+(define-obsolete-function-alias 'cl-make-hash-table 'make-hash-table "24.3")
+(define-obsolete-function-alias 'cl-hash-table-p 'hash-table-p "24.3")
+(define-obsolete-function-alias 'cl-hash-table-count 'hash-table-count "24.3")
+
+(define-obsolete-function-alias 'cl-map-keymap-recursively
+ 'cl--map-keymap-recursively "24.3")
+(define-obsolete-function-alias 'cl-map-intervals 'cl--map-intervals "24.3")
+(define-obsolete-function-alias 'cl-map-extents 'cl--map-overlays "24.3")
+(define-obsolete-function-alias 'cl-set-getf 'cl--set-getf "24.3")
(defun cl-maclisp-member (item list)
- (declare (obsolete member "24.2"))
+ (declare (obsolete member "24.3"))
(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"))
+ (declare (obsolete nil "24.3"))
(let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
(list (list temp) (list x) (list store)
`(progn
(list accessor temp))))
(provide 'cl)
+
+(run-hooks 'cl-load-hook)
+
;;; cl.el ends here