1 ;;; cl.el --- Compatibility aliases for the old CL library. -*- lexical-binding: t -*-
3 ;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
6 ;; Keywords: extensions
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;; This is a compatibility file which provides the old names provided by CL
26 ;; before we cleaned up its namespace usage.
34 ;; (defun cl--rename ()
37 ;; (case-fold-search nil)
38 ;; (files '("cl.el" "cl-macs.el" "cl-seq.el" "cl-extra.el")))
39 ;; (dolist (file files)
40 ;; (with-current-buffer (find-file-noselect file)
41 ;; (goto-char (point-min))
42 ;; (while (re-search-forward
43 ;; "^(\\(def[^ \t\n]*\\) +'?\\(\\(\\sw\\|\\s_\\)+\\)" nil t)
44 ;; (let ((name (match-string-no-properties 2))
45 ;; (type (match-string-no-properties 1)))
46 ;; (unless (string-match-p "\\`cl-" name)
48 ;; ((member type '("defvar" "defconst"))
49 ;; (unless (member name vdefs) (push name vdefs)))
50 ;; ((member type '("defun" "defsubst" "defalias" "defmacro"))
51 ;; (unless (member name fdefs) (push name fdefs)))
52 ;; ((member type '("def-edebug-spec" "defsetf" "define-setf-method"
53 ;; "define-compiler-macro"))
55 ;; (t (error "Unknown type %S" type))))))))
56 ;; (let ((re (concat "\\_<" (regexp-opt (append vdefs fdefs)) "\\_>"))
58 ;; (dolist (file files)
59 ;; (with-current-buffer (find-file-noselect file)
60 ;; (goto-char (point-min))
61 ;; (while (re-search-forward re nil t)
62 ;; (replace-match "cl-\\&"))
64 ;; (with-current-buffer (find-file-noselect "cl-rename.el")
65 ;; (dolist (def vdefs)
66 ;; (insert (format "(defvaralias '%s 'cl-%s)\n" def def)))
67 ;; (dolist (def fdefs)
68 ;; (insert (format "(defalias '%s 'cl-%s)\n" def def)))
71 ;; (defun cl--unrename ()
72 ;; ;; Taken from "Naming Conventions" node of the doc.
73 ;; (let* ((names '(defun* defsubst* defmacro* function* member*
74 ;; assoc* rassoc* get* remove* delete*
75 ;; mapcar* sort* floor* ceiling* truncate*
76 ;; round* mod* rem* random*))
77 ;; (files '("cl.el" "cl-lib.el" "cl-macs.el" "cl-seq.el" "cl-extra.el"))
78 ;; (re (concat "\\_<cl-" (regexp-opt (mapcar #'symbol-name names))
80 ;; (dolist (file files)
81 ;; (with-current-buffer (find-file-noselect file)
82 ;; (goto-char (point-min))
83 ;; (while (re-search-forward re nil t)
84 ;; (delete-region (1- (point)) (point)))
87 (defun cl-unload-function ()
88 "Stop unloading of the Common Lisp extensions."
89 (message "Cannot unload the feature `cl'")
90 ;; Stop standard unloading!
93 ;;; Aliases to cl-lib's features.
104 ;; lambda-list-keywords
105 float-negative-epsilon
107 least-negative-normalized-float
108 least-positive-normalized-float
113 ;; custom-print-functions
115 (defvaralias var
(intern (format "cl-%s" var
))))
119 (random* . cl-random
)
123 (truncate* . cl-truncate
)
124 (ceiling* . cl-ceiling
)
126 (rassoc* . cl-rassoc
)
128 (member* . cl-member
)
129 (delete* . cl-delete
)
130 (remove* . cl-remove
)
131 (defsubst* . cl-defsubst
)
133 (function* . cl-function
)
134 (defmacro* . cl-defmacro
)
136 (mapcar* . cl-mapcar
)
214 define-compiler-macro
228 (define-setf-method . define-setf-expander
)
316 (let ((new (if (consp fun
) (prog1 (cdr fun
) (setq fun
(car fun
)))
317 (intern (format "cl-%s" fun
)))))
320 (defun cl--wrap-in-nil-block (fun &rest args
)
321 `(cl-block nil
,(apply fun args
)))
322 (advice-add 'dolist
:around
#'cl--wrap-in-nil-block
)
323 (advice-add 'dotimes
:around
#'cl--wrap-in-nil-block
)
325 (defun cl--pass-args-to-cl-declare (&rest specs
)
326 (macroexpand `(cl-declare ,@specs
)))
327 (advice-add 'declare
:after
#'cl--pass-args-to-cl-declare
)
329 ;;; Features provided a bit differently in Elisp.
331 ;; First, the old lexical-let is now better served by `lexical-binding', tho
332 ;; it's not 100% compatible.
334 (defvar cl-closure-vars nil
)
335 (defvar cl--function-convert-cache nil
)
337 (defun cl--function-convert (f)
338 "Special macro-expander for special cases of (function F).
339 The two cases that are handled are:
340 - closure-conversion of lambda expressions for `lexical-let'.
341 - renaming of F when it's a function defined via `cl-labels' or `labels'."
343 (declare-function cl--expr-contains-any
"cl-macs" (x y
))
344 (declare-function cl--labels-convert
"cl-macs" (f))
345 (defvar cl--labels-convert-cache
)
347 ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked
348 ;; *after* handling `function', but we want to stop macroexpansion from
349 ;; being applied infinitely, so we use a cache to return the exact `form'
350 ;; being expanded even though we don't receive it.
351 ((eq f
(car cl--function-convert-cache
)) (cdr cl--function-convert-cache
))
352 ((eq (car-safe f
) 'lambda
)
353 (let ((body (mapcar (lambda (f)
354 (macroexpand-all f macroexpand-all-environment
))
356 (if (and cl-closure-vars
357 (cl--expr-contains-any body cl-closure-vars
))
358 (let* ((new (mapcar 'cl-gensym cl-closure-vars
))
359 (sub (cl-pairlis cl-closure-vars new
)) (decls nil
))
360 (while (or (stringp (car body
))
361 (eq (car-safe (car body
)) 'interactive
))
362 (push (list 'quote
(pop body
)) decls
))
363 (put (car (last cl-closure-vars
)) 'used t
)
364 `(list 'lambda
'(&rest --cl-rest--
)
365 ,@(cl-sublis sub
(nreverse decls
))
368 #'(lambda ,(append new
(cadr f
))
369 ,@(cl-sublis sub body
)))
370 ,@(nconc (mapcar (lambda (x) `(list 'quote
,x
))
372 '((quote --cl-rest--
))))))
373 (let* ((newf `(lambda ,(cadr f
) ,@body
))
374 (res `(function ,newf
)))
375 (setq cl--function-convert-cache
(cons newf res
))
378 (cl--labels-convert f
))))
380 (defmacro lexical-let
(bindings &rest body
)
381 "Like `let', but lexically scoped.
382 The main visible difference is that lambdas inside BODY will create
383 lexical closures as in Common Lisp.
384 \n(fn BINDINGS BODY)"
385 (declare (indent 1) (debug let
))
386 (let* ((cl-closure-vars cl-closure-vars
)
387 (vars (mapcar (function
389 (or (consp x
) (setq x
(list x
)))
390 (push (make-symbol (format "--cl-%s--" (car x
)))
392 (set (car cl-closure-vars
) [bad-lexical-ref
])
393 (list (car x
) (cadr x
) (car cl-closure-vars
))))
399 `(,(car x
) (symbol-value ,(nth 2 x
))))
402 (cons (cons 'function
#'cl--function-convert
)
403 macroexpand-all-environment
))))
404 (if (not (get (car (last cl-closure-vars
)) 'used
))
405 ;; Turn (let ((foo (cl-gensym)))
406 ;; (set foo <val>) ...(symbol-value foo)...)
407 ;; into (let ((foo <val>)) ...(symbol-value 'foo)...).
408 ;; This is good because it's more efficient but it only works with
409 ;; dynamic scoping, since with lexical scoping we'd need
410 ;; (let ((foo <val>)) ...foo...).
412 ,@(mapcar (lambda (x) `(defvar ,(nth 2 x
))) vars
)
413 (let ,(mapcar (lambda (x) (list (nth 2 x
) (nth 1 x
))) vars
)
414 ,(cl-sublis (mapcar (lambda (x)
419 `(let ,(mapcar (lambda (x)
421 `(make-symbol ,(format "--%s--" (car x
)))))
423 (setf ,@(apply #'append
425 (list `(symbol-value ,(nth 2 x
)) (nth 1 x
)))
429 (defmacro lexical-let
* (bindings &rest body
)
430 "Like `let*', but lexically scoped.
431 The main visible difference is that lambdas inside BODY, and in
432 successive bindings within BINDINGS, will create lexical closures
433 as in Common Lisp. This is similar to the behavior of `let*' in
435 \n(fn BINDINGS BODY)"
436 (declare (indent 1) (debug let
))
437 (if (null bindings
) (cons 'progn body
)
438 (setq bindings
(reverse bindings
))
440 (setq body
(list `(lexical-let (,(pop bindings
)) ,@body
))))
443 ;; This should really have some way to shadow 'byte-compile properties, etc.
444 (defmacro flet
(bindings &rest body
)
445 "Make temporary overriding function definitions.
446 This is an analogue of a dynamically scoped `let' that operates on the function
447 cell of FUNCs rather than their value cell.
448 If you want the Common-Lisp style of `flet', you should use `cl-flet'.
449 The FORMs are evaluated with the specified function definitions in place,
450 then the definitions are undone (the FUNCs go back to their previous
451 definitions, or lack thereof).
453 \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
454 (declare (indent 1) (debug cl-flet
)
455 (obsolete "use either `cl-flet' or `cl-letf'." "24.3"))
458 (if (or (and (fboundp (car x
))
459 (eq (car-safe (symbol-function (car x
))) 'macro
))
460 (cdr (assq (car x
) macroexpand-all-environment
)))
461 (error "Use `labels', not `flet', to rebind macro names"))
462 (let ((func `(cl-function
464 (cl-block ,(car x
) ,@(cddr x
))))))
465 (when (cl--compiling-file)
466 ;; Bug#411. It would be nice to fix this.
467 (and (get (car x
) 'byte-compile
)
468 (error "Byte-compiling a redefinition of `%s' \
469 will not work - use `labels' instead" (symbol-name (car x
))))
470 ;; FIXME This affects the rest of the file, when it
471 ;; should be restricted to the flet body.
472 (and (boundp 'byte-compile-function-environment
)
473 (push (cons (car x
) (eval func
))
474 byte-compile-function-environment
)))
475 (list `(symbol-function ',(car x
)) func
)))
479 (defmacro labels
(bindings &rest body
)
480 "Make temporary function bindings.
481 Like `cl-labels' except that the lexical scoping is handled via `lexical-let'
482 rather than relying on `lexical-binding'."
483 (declare (indent 1) (debug cl-flet
) (obsolete cl-labels
"24.3"))
484 (let ((vars nil
) (sets nil
) (newenv macroexpand-all-environment
))
485 (dolist (binding bindings
)
486 ;; It's important that (not (eq (symbol-name var1) (symbol-name var2)))
487 ;; because these var's *names* get added to the macro-environment.
488 (let ((var (make-symbol (format "--cl-%s--" (car binding
)))))
490 (push `(cl-function (lambda .
,(cdr binding
))) sets
)
492 (push (cons (car binding
)
493 `(lambda (&rest cl-labels-args
)
494 (cl-list* 'funcall
',var
497 (macroexpand-all `(lexical-let ,vars
(setq ,@sets
) ,@body
) newenv
)))
499 ;; Generalized variables are provided by gv.el, but some details are
500 ;; not 100% compatible: not worth the trouble to add them to cl-lib.el, but we
501 ;; still need to support old users of cl.el.
503 (defun cl--gv-adapt (cl-gv do
)
504 ;; This function is used by all .elc files that use define-setf-expander and
505 ;; were compiled with Emacs>=24.3.
506 (let ((vars (nth 0 cl-gv
))
510 ;; Use cl-sublis as was done in cl-setf-do-modify.
512 (if (macroexp-copyable-p (car vals
))
513 (push (cons (pop vars
) (pop vals
)) substs
)
514 (push (list (pop vars
) (pop vals
)) binds
)))
517 (funcall do
(cl-sublis substs
(nth 4 cl-gv
))
518 ;; We'd like to do something like
519 ;; (lambda ,(nth 2 cl-gv) ,(nth 3 cl-gv)).
521 (macroexp-let2 macroexp-copyable-p v exp
522 (cl-sublis (cons (cons (car (nth 2 cl-gv
)) v
)
526 (defmacro define-setf-expander
(name arglist
&rest body
)
527 "Define a `setf' method.
528 This method shows how to handle `setf's to places of the form
529 \(NAME ARGS...). The argument forms ARGS are bound according to
530 ARGLIST, as if NAME were going to be expanded as a macro, then
531 the BODY forms are executed and must return a list of five elements:
532 a temporary-variables list, a value-forms list, a store-variables list
533 \(of length one), a store-form, and an access- form.
535 See `gv-define-expander', and `gv-define-setter' for better and
536 simpler ways to define setf-methods."
538 (&define name cl-lambda-list cl-declarations-or-string def-body
)))
540 ,@(if (stringp (car body
))
541 (list `(put ',name
'setf-documentation
,(pop body
))))
542 (gv-define-expander ,name
544 (lambda (do ,@arglist
)
545 (cl--gv-adapt (progn ,@body
) do
))))))
547 (defmacro defsetf
(name arg1
&rest args
)
548 "Define a `setf' method.
549 This macro is an easy-to-use substitute for `define-setf-expander'
550 that works well for simple place forms.
552 In the simple `defsetf' form, `setf's of the form (setf (NAME
553 ARGS...) VAL) are transformed to function or macro calls of the
554 form (FUNC ARGS... VAL). For example:
558 You can replace this form with `gv-define-simple-setter'.
560 Alternate form: (defsetf NAME ARGLIST (STORE) BODY...).
562 Here, the above `setf' call is expanded by binding the argument
563 forms ARGS according to ARGLIST, binding the value form VAL to
564 STORE, then executing BODY, which must return a Lisp form that
565 does the necessary `setf' operation. Actually, ARGLIST and STORE
566 may be bound to temporary variables which are introduced
567 automatically to preserve proper execution order of the arguments.
570 (defsetf nth (n x) (v) \\=`(setcar (nthcdr ,n ,x) ,v))
572 You can replace this form with `gv-define-setter'.
574 \(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
577 [&or
[symbolp
&optional stringp
]
578 [cl-lambda-list
(symbolp)]]
579 cl-declarations-or-string def-body
)))
580 (if (and (listp arg1
) (consp args
))
581 ;; Like `gv-define-setter' but with `cl-function'.
582 `(gv-define-expander ,name
583 (lambda (do &rest args
)
584 (gv--defsetter ',name
586 (lambda (,@(car args
) ,@arg1
) ,@(cdr args
)))
588 `(gv-define-simple-setter ,name
,arg1
,(car args
))))
590 ;; FIXME: CL used to provide a setf method for `apply', but I haven't been able
591 ;; to find a case where it worked. The code below tries to handle it as well.
592 ;; (defun cl--setf-apply (form last-witness last)
594 ;; ((not (consp form)) form)
595 ;; ((eq (ignore-errors (car (last form))) last-witness)
596 ;; `(apply #',(car form) ,@(butlast (cdr form)) ,last))
597 ;; ((and (memq (car form) '(let let*))
598 ;; (rassoc (list last-witness) (cadr form)))
599 ;; (let ((rebind (rassoc (list last-witness) (cadr form))))
600 ;; `(,(car form) ,(remq rebind (cadr form))
601 ;; ,@(mapcar (lambda (form) (cl--setf-apply form (car rebind) last))
603 ;; (t (mapcar (lambda (form) (cl--setf-apply form last-witness last)) form))))
604 ;; (gv-define-setter apply (val fun &rest args)
605 ;; (pcase fun (`#',(and (pred symbolp) f) (setq fun f))
606 ;; (_ (error "First arg to apply in setf is not #'SYM: %S" fun)))
607 ;; (let* ((butlast (butlast args))
608 ;; (last (car (last args)))
609 ;; (last-witness (make-symbol "--cl-tailarg--"))
610 ;; (setter (macroexpand `(setf (,fun ,@butlast ,last-witness) ,val)
611 ;; macroexpand-all-environment)))
612 ;; (cl--setf-apply setter last-witness last)))
615 ;; FIXME: CL used to provide get-setf-method, which was used by some
616 ;; setf-expanders, but now that we use gv.el, it is a lot more difficult
617 ;; and in general impossible to provide get-setf-method. Hopefully, it
618 ;; won't be needed. If needed, we'll have to do something nasty along the
620 ;; (defun get-setf-method (place &optional env)
621 ;; (let* ((witness (list 'cl-gsm))
622 ;; (expansion (gv-letplace (getter setter) place
623 ;; `(,witness ,getter ,(funcall setter witness)))))
624 ;; ...find "let prefix" of expansion, extract getter and setter from
625 ;; ...the rest, and build the 5-tuple))
626 (make-obsolete 'get-setf-method
'gv-letplace
"24.3")
628 (declare-function cl--arglist-args
"cl-macs" (args))
630 (defmacro define-modify-macro
(name arglist func
&optional doc
)
631 "Define a `setf'-like modify macro.
632 If NAME is called, it combines its PLACE argument with the other
633 arguments from ARGLIST using FUNC. For example:
635 (define-modify-macro incf (&optional (n 1)) +)
637 You can replace this macro with `gv-letplace'."
639 (&define name cl-lambda-list
;; should exclude &key
640 symbolp
&optional stringp
)))
641 (if (memq '&key arglist
)
642 (error "&key not allowed in define-modify-macro"))
643 (require 'cl-macs
) ;For cl--arglist-args.
644 (let ((place (make-symbol "--cl-place--")))
645 `(cl-defmacro ,name
(,place
,@arglist
)
647 (,(if (memq '&rest arglist
) #'cl-list
* #'list
)
648 #'cl-callf
',func
,place
649 ,@(cl--arglist-args arglist
)))))
651 ;;; Additional compatibility code.
652 ;; For names that were clean but really aren't needed any more.
654 (define-obsolete-function-alias 'cl-macroexpand
'macroexpand
"24.3")
655 (define-obsolete-variable-alias 'cl-macro-environment
656 'macroexpand-all-environment
"24.3")
657 (define-obsolete-function-alias 'cl-macroexpand-all
'macroexpand-all
"24.3")
660 ;; This is just kept for compatibility with code byte-compiled by Emacs-20.
662 ;; No idea if this might still be needed.
663 (defun cl-not-hash-table (x &optional y
&rest _z
)
664 (declare (obsolete nil
"24.3"))
665 (signal 'wrong-type-argument
(list 'cl-hash-table-p
(or y x
))))
667 (defvar cl-builtin-gethash
(symbol-function 'gethash
))
668 (make-obsolete-variable 'cl-builtin-gethash nil
"24.3")
669 (defvar cl-builtin-remhash
(symbol-function 'remhash
))
670 (make-obsolete-variable 'cl-builtin-remhash nil
"24.3")
671 (defvar cl-builtin-clrhash
(symbol-function 'clrhash
))
672 (make-obsolete-variable 'cl-builtin-clrhash nil
"24.3")
673 (defvar cl-builtin-maphash
(symbol-function 'maphash
))
675 (make-obsolete-variable 'cl-builtin-maphash nil
"24.3")
676 (define-obsolete-function-alias 'cl-map-keymap
'map-keymap
"24.3")
677 (define-obsolete-function-alias 'cl-copy-tree
'copy-tree
"24.3")
678 (define-obsolete-function-alias 'cl-gethash
'gethash
"24.3")
679 (define-obsolete-function-alias 'cl-puthash
'puthash
"24.3")
680 (define-obsolete-function-alias 'cl-remhash
'remhash
"24.3")
681 (define-obsolete-function-alias 'cl-clrhash
'clrhash
"24.3")
682 (define-obsolete-function-alias 'cl-maphash
'maphash
"24.3")
683 (define-obsolete-function-alias 'cl-make-hash-table
'make-hash-table
"24.3")
684 (define-obsolete-function-alias 'cl-hash-table-p
'hash-table-p
"24.3")
685 (define-obsolete-function-alias 'cl-hash-table-count
'hash-table-count
"24.3")
687 (define-obsolete-function-alias 'cl-map-keymap-recursively
688 'cl--map-keymap-recursively
"24.3")
689 (define-obsolete-function-alias 'cl-map-intervals
'cl--map-intervals
"24.3")
690 (define-obsolete-function-alias 'cl-map-extents
'cl--map-overlays
"24.3")
691 (define-obsolete-function-alias 'cl-set-getf
'cl--set-getf
"24.3")
693 (defun cl-maclisp-member (item list
)
694 (declare (obsolete member
"24.3"))
695 (while (and list
(not (equal item
(car list
)))) (setq list
(cdr list
)))
698 ;; Used in the expansion of the old `defstruct'.
699 (defun cl-struct-setf-expander (x name accessor pred-form pos
)
700 (declare (obsolete nil
"24.3"))
701 (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
702 (list (list temp
) (list x
) (list store
)
705 (list `(or ,(cl-subst temp
'cl-x pred-form
)
707 "%s storing a non-%s"
709 ,(if (eq (car (get name
'cl-struct-type
)) 'vector
)
710 `(aset ,temp
,pos
,store
)
714 (while (>= (setq pos
(1- pos
)) 0)
715 (setq xx
`(cdr ,xx
)))
717 `(nthcdr ,pos
,temp
))
719 (list accessor temp
))))
723 (run-hooks 'cl-load-hook
)