1 ;;; cl.el --- Compatibility aliases for the old CL library.
3 ;; Copyright (C) 2012 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.
33 ;; (defun cl--rename ()
36 ;; (case-fold-search nil)
37 ;; (files '("cl.el" "cl-macs.el" "cl-seq.el" "cl-extra.el")))
38 ;; (dolist (file files)
39 ;; (with-current-buffer (find-file-noselect file)
40 ;; (goto-char (point-min))
41 ;; (while (re-search-forward
42 ;; "^(\\(def[^ \t\n]*\\) +'?\\(\\(\\sw\\|\\s_\\)+\\)" nil t)
43 ;; (let ((name (match-string-no-properties 2))
44 ;; (type (match-string-no-properties 1)))
45 ;; (unless (string-match-p "\\`cl-" name)
47 ;; ((member type '("defvar" "defconst"))
48 ;; (unless (member name vdefs) (push name vdefs)))
49 ;; ((member type '("defun" "defsubst" "defalias" "defmacro"))
50 ;; (unless (member name fdefs) (push name fdefs)))
51 ;; ((member type '("def-edebug-spec" "defsetf" "define-setf-method"
52 ;; "define-compiler-macro"))
54 ;; (t (error "Unknown type %S" type))))))))
55 ;; (let ((re (concat "\\_<" (regexp-opt (append vdefs fdefs)) "\\_>"))
57 ;; (dolist (file files)
58 ;; (with-current-buffer (find-file-noselect file)
59 ;; (goto-char (point-min))
60 ;; (while (re-search-forward re nil t)
61 ;; (replace-match "cl-\\&"))
63 ;; (with-current-buffer (find-file-noselect "cl-rename.el")
64 ;; (dolist (def vdefs)
65 ;; (insert (format "(defvaralias '%s 'cl-%s)\n" def def)))
66 ;; (dolist (def fdefs)
67 ;; (insert (format "(defalias '%s 'cl-%s)\n" def def)))
70 ;; (defun cl--unrename ()
71 ;; ;; Taken from "Naming Conventions" node of the doc.
72 ;; (let* ((names '(defun* defsubst* defmacro* function* member*
73 ;; assoc* rassoc* get* remove* delete*
74 ;; mapcar* sort* floor* ceiling* truncate*
75 ;; round* mod* rem* random*))
76 ;; (files '("cl.el" "cl-lib.el" "cl-macs.el" "cl-seq.el" "cl-extra.el"))
77 ;; (re (concat "\\_<cl-" (regexp-opt (mapcar #'symbol-name names))
79 ;; (dolist (file files)
80 ;; (with-current-buffer (find-file-noselect file)
81 ;; (goto-char (point-min))
82 ;; (while (re-search-forward re nil t)
83 ;; (delete-region (1- (point)) (point)))
94 ;; lambda-list-keywords
95 float-negative-epsilon
97 least-negative-normalized-float
98 least-positive-normalized-float
103 ;; custom-print-functions
105 (defvaralias var
(intern (format "cl-%s" var
))))
109 (random* . cl-random
)
113 (truncate* . cl-truncate
)
114 (ceiling* . cl-ceiling
)
116 (rassoc* . cl-rassoc
)
118 (member* . cl-member
)
119 (delete* . cl-delete
)
120 (remove* . cl-remove
)
121 (defsubst* . cl-defsubst
)
123 (function* . cl-function
)
124 (defmacro* . cl-defmacro
)
126 (mapcar* . cl-mapcar
)
205 define-compiler-macro
223 (define-setf-method . cl-define-setf-expander
)
318 (let ((new (if (consp fun
) (prog1 (cdr fun
) (setq fun
(car fun
)))
319 (intern (format "cl-%s" fun
)))))
321 ;; If `cl-foo' is declare inline, then make `foo' inline as well, and
322 ;; similarly. Same for edebug specifications, indent rules and
323 ;; doc-string position.
324 ;; FIXME: For most of them, we should instead follow aliases
326 (dolist (prop '(byte-optimizer doc-string-elt edebug-form-spec
327 lisp-indent-function
))
329 (put fun prop
(get new prop
))))))
331 (defvar cl-closure-vars nil
)
332 (defvar cl--function-convert-cache nil
)
334 (defun cl--function-convert (f)
335 "Special macro-expander for special cases of (function F).
336 The two cases that are handled are:
337 - closure-conversion of lambda expressions for `lexical-let'.
338 - renaming of F when it's a function defined via `cl-labels' or `labels'."
341 ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked
342 ;; *after* handling `function', but we want to stop macroexpansion from
343 ;; being applied infinitely, so we use a cache to return the exact `form'
344 ;; being expanded even though we don't receive it.
345 ((eq f
(car cl--function-convert-cache
)) (cdr cl--function-convert-cache
))
346 ((eq (car-safe f
) 'lambda
)
347 (let ((body (mapcar (lambda (f)
348 (macroexpand-all f macroexpand-all-environment
))
350 (if (and cl-closure-vars
351 (cl--expr-contains-any body cl-closure-vars
))
352 (let* ((new (mapcar 'cl-gensym cl-closure-vars
))
353 (sub (cl-pairlis cl-closure-vars new
)) (decls nil
))
354 (while (or (stringp (car body
))
355 (eq (car-safe (car body
)) 'interactive
))
356 (push (list 'quote
(pop body
)) decls
))
357 (put (car (last cl-closure-vars
)) 'used t
)
358 `(list 'lambda
'(&rest --cl-rest--
)
359 ,@(cl-sublis sub
(nreverse decls
))
362 #'(lambda ,(append new
(cadr f
))
363 ,@(cl-sublis sub body
)))
364 ,@(nconc (mapcar (lambda (x) `(list 'quote
,x
))
366 '((quote --cl-rest--
))))))
367 (let* ((newf `(lambda ,(cadr f
) ,@body
))
368 (res `(function ,newf
)))
369 (setq cl--function-convert-cache
(cons newf res
))
372 (let ((found (assq f macroexpand-all-environment
)))
373 (if (and found
(ignore-errors
374 (eq (cadr (cl-caddr found
)) 'cl-labels-args
)))
375 (cadr (cl-caddr (cl-cadddr found
)))
376 (let ((res `(function ,f
)))
377 (setq cl--function-convert-cache
(cons f res
))
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 ,(cl-caddr 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 ,(cl-caddr x
))) vars
)
413 (let ,(mapcar (lambda (x) (list (cl-caddr x
) (cadr x
))) vars
)
414 ,(cl-sublis (mapcar (lambda (x)
419 `(let ,(mapcar (lambda (x)
421 `(make-symbol ,(format "--%s--" (car x
)))))
423 (cl-setf ,@(apply #'append
425 (list `(symbol-value ,(cl-caddr x
)) (cadr 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.
445 (defmacro flet
(bindings &rest body
)
446 "Make temporary function definitions.
447 This is an analogue of `let' that operates on the function cell of FUNC
448 rather than its value cell. The FORMs are evaluated with the specified
449 function definitions in place, then the definitions are undone (the FUNCs
450 go back to their previous definitions, or lack thereof).
452 \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
453 (declare (indent 1) (debug cl-flet
))
456 (if (or (and (fboundp (car x
))
457 (eq (car-safe (symbol-function (car x
))) 'macro
))
458 (cdr (assq (car x
) macroexpand-all-environment
)))
459 (error "Use `labels', not `flet', to rebind macro names"))
460 (let ((func `(cl-function
462 (cl-block ,(car x
) ,@(cddr x
))))))
463 (when (cl-compiling-file)
464 ;; Bug#411. It would be nice to fix this.
465 (and (get (car x
) 'byte-compile
)
466 (error "Byte-compiling a redefinition of `%s' \
467 will not work - use `labels' instead" (symbol-name (car x
))))
468 ;; FIXME This affects the rest of the file, when it
469 ;; should be restricted to the flet body.
470 (and (boundp 'byte-compile-function-environment
)
471 (push (cons (car x
) (eval func
))
472 byte-compile-function-environment
)))
473 (list `(symbol-function ',(car x
)) func
)))
477 (defmacro labels
(bindings &rest body
)
478 "Make temporary function bindings.
479 This is like `flet', except the bindings are lexical instead of dynamic.
480 Unlike `flet', this macro is fully compliant with the Common Lisp standard.
482 \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
483 (declare (indent 1) (debug cl-flet
))
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 ;;; Additional compatibility code
500 ;; For names that were clean but really aren't needed any more.
502 (define-obsolete-function-alias 'cl-macroexpand
'macroexpand
"24.2")
503 (define-obsolete-variable-alias 'cl-macro-environment
504 'macroexpand-all-environment
"24.2")
505 (define-obsolete-function-alias 'cl-macroexpand-all
'macroexpand-all
"24.2")
508 ;; This is just kept for compatibility with code byte-compiled by Emacs-20.
510 ;; No idea if this might still be needed.
511 (defun cl-not-hash-table (x &optional y
&rest z
)
512 (signal 'wrong-type-argument
(list 'cl-hash-table-p
(or y x
))))
513 (make-obsolete 'cl-not-hash-table nil
"24.2")
515 (defvar cl-builtin-gethash
(symbol-function 'gethash
))
516 (make-obsolete-variable 'cl-builtin-gethash nil
"24.2")
517 (defvar cl-builtin-remhash
(symbol-function 'remhash
))
518 (make-obsolete-variable 'cl-builtin-remhash nil
"24.2")
519 (defvar cl-builtin-clrhash
(symbol-function 'clrhash
))
520 (make-obsolete-variable 'cl-builtin-clrhash nil
"24.2")
521 (defvar cl-builtin-maphash
(symbol-function 'maphash
))
523 (make-obsolete-variable 'cl-builtin-maphash nil
"24.2")
524 (define-obsolete-function-alias 'cl-map-keymap
'map-keymap
"24.2")
525 (define-obsolete-function-alias 'cl-copy-tree
'copy-tree
"24.2")
526 (define-obsolete-function-alias 'cl-gethash
'gethash
"24.2")
527 (define-obsolete-function-alias 'cl-puthash
'puthash
"24.2")
528 (define-obsolete-function-alias 'cl-remhash
'remhash
"24.2")
529 (define-obsolete-function-alias 'cl-clrhash
'clrhash
"24.2")
530 (define-obsolete-function-alias 'cl-maphash
'maphash
"24.2")
531 (define-obsolete-function-alias 'cl-make-hash-table
'make-hash-table
"24.2")
532 (define-obsolete-function-alias 'cl-hash-table-p
'hash-table-p
"24.2")
533 (define-obsolete-function-alias 'cl-hash-table-count
'hash-table-count
"24.2")
535 ;; FIXME: More candidates: define-modify-macro, define-setf-expander.