aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2012-06-11 11:52:50 -0400
committerStefan Monnier2012-06-11 11:52:50 -0400
commitbb3faf5b98f59f4fed117f3d0e6e27a7b180d04c (patch)
treea7e8a7c9fcae6484bcbee42e81d8587ba23fbbb5
parent3017f87fbd0461b9460e7261a095fc86e166b30e (diff)
downloademacs-bb3faf5b98f59f4fed117f3d0e6e27a7b180d04c.tar.gz
emacs-bb3faf5b98f59f4fed117f3d0e6e27a7b180d04c.zip
Use lexical-binding for all of CL, and clean up its namespace.
* lisp/emacs-lisp/cl-lib.el: Use lexical-binding. (cl-map-extents, cl-maclisp-member): Remove. (cl--set-elt, cl--set-nthcdr, cl--set-buffer-substring) (cl--set-substring, cl--block-wrapper, cl--block-throw) (cl--compiling-file, cl--mapcar-many, cl--do-subst): Use "cl--" prefix. * lisp/emacs-lisp/cl-extra.el: Use lexical-binding. (cl--mapcar-many, cl--map-keymap-recursively, cl--map-intervals) (cl--map-overlays, cl--set-frame-visible-p, cl--progv-save) (cl--progv-before, cl--progv-after, cl--finite-do, cl--set-getf) (cl--do-remf, cl--do-prettyprint): Use "cl--" prefix. * lisp/emacs-lisp/cl-seq.el: Use lexical-binding. (cl--parsing-keywords, cl--check-key, cl--check-test-nokey) (cl--check-test, cl--check-match): Use "cl--" prefix and backquotes. (cl--alist, cl--sublis-rec, cl--nsublis-rec, cl--tree-equal-rec): * lisp/emacs-lisp/cl-macs.el (cl--lambda-list-keywords): Use "cl--" prefix. * lisp/edmacro.el (edmacro-mismatch): Simplify to remove dependence on CL's internals.
Diffstat
-rw-r--r--lisp/ChangeLog20
-rw-r--r--lisp/edmacro.el35
-rw-r--r--lisp/emacs-lisp/bytecomp.el6
-rw-r--r--lisp/emacs-lisp/cl-extra.el70
-rw-r--r--lisp/emacs-lisp/cl-lib.el49
-rw-r--r--lisp/emacs-lisp/cl-loaddefs.el32
-rw-r--r--lisp/emacs-lisp/cl-macs.el188
-rw-r--r--lisp/emacs-lisp/cl-seq.el271
-rw-r--r--lisp/emacs-lisp/cl.el8
-rw-r--r--lisp/help-fns.el2
10 files changed, 339 insertions, 342 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 198e9c5e602..a251c45f323 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,23 @@
12012-06-11 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * emacs-lisp/cl-lib.el: Use lexical-binding.
4 (cl-map-extents, cl-maclisp-member): Remove.
5 (cl--set-elt, cl--set-nthcdr, cl--set-buffer-substring)
6 (cl--set-substring, cl--block-wrapper, cl--block-throw)
7 (cl--compiling-file, cl--mapcar-many, cl--do-subst): Use "cl--" prefix.
8 * emacs-lisp/cl-extra.el: Use lexical-binding.
9 (cl--mapcar-many, cl--map-keymap-recursively, cl--map-intervals)
10 (cl--map-overlays, cl--set-frame-visible-p, cl--progv-save)
11 (cl--progv-before, cl--progv-after, cl--finite-do, cl--set-getf)
12 (cl--do-remf, cl--do-prettyprint): Use "cl--" prefix.
13 * emacs-lisp/cl-seq.el: Use lexical-binding.
14 (cl--parsing-keywords, cl--check-key, cl--check-test-nokey)
15 (cl--check-test, cl--check-match): Use "cl--" prefix and backquotes.
16 (cl--alist, cl--sublis-rec, cl--nsublis-rec, cl--tree-equal-rec):
17 * emacs-lisp/cl-macs.el (cl--lambda-list-keywords): Use "cl--" prefix.
18 * edmacro.el (edmacro-mismatch): Simplify to remove dependence on
19 CL's internals.
20
12012-06-11 Michael Albinus <michael.albinus@gmx.de> 212012-06-11 Michael Albinus <michael.albinus@gmx.de>
2 22
3 Sync with Tramp 2.2.6-pre. 23 Sync with Tramp 2.2.6-pre.
diff --git a/lisp/edmacro.el b/lisp/edmacro.el
index 32915e3ee6e..4bc7f6af69a 100644
--- a/lisp/edmacro.el
+++ b/lisp/edmacro.el
@@ -594,28 +594,19 @@ doubt, use whitespace."
594Return nil if the sequences match. If one sequence is a prefix of the 594Return nil if the sequences match. If one sequence is a prefix of the
595other, the return value indicates the end of the shorted sequence. 595other, the return value indicates the end of the shorted sequence.
596\n(fn SEQ1 SEQ2 START1 END1 START2 END2)" 596\n(fn SEQ1 SEQ2 START1 END1 START2 END2)"
597 (let (cl-test cl-test-not cl-key cl-from-end) 597 (or cl-end1 (setq cl-end1 (length cl-seq1)))
598 (or cl-end1 (setq cl-end1 (length cl-seq1))) 598 (or cl-end2 (setq cl-end2 (length cl-seq2)))
599 (or cl-end2 (setq cl-end2 (length cl-seq2))) 599 (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
600 (if cl-from-end 600 (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
601 (progn 601 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
602 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) 602 (eql (if cl-p1 (car cl-p1)
603 (cl-check-match (elt cl-seq1 (1- cl-end1)) 603 (aref cl-seq1 cl-start1))
604 (elt cl-seq2 (1- cl-end2)))) 604 (if cl-p2 (car cl-p2)
605 (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2))) 605 (aref cl-seq2 cl-start2))))
606 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) 606 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
607 (1- cl-end1))) 607 cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
608 (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1))) 608 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
609 (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2)))) 609 cl-start1)))
610 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
611 (cl-check-match (if cl-p1 (car cl-p1)
612 (aref cl-seq1 cl-start1))
613 (if cl-p2 (car cl-p2)
614 (aref cl-seq2 cl-start2))))
615 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
616 cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
617 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
618 cl-start1)))))
619 610
620(defun edmacro-subseq (seq start &optional end) 611(defun edmacro-subseq (seq start &optional end)
621 "Return the subsequence of SEQ from START to END. 612 "Return the subsequence of SEQ from START to END.
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 98bdcc69f95..a65a355bfdf 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -1399,18 +1399,18 @@ extra args."
1399 ;; These aren't all aliases of subrs, so not trivial to 1399 ;; These aren't all aliases of subrs, so not trivial to
1400 ;; avoid hardwiring the list. 1400 ;; avoid hardwiring the list.
1401 (not (memq func 1401 (not (memq func
1402 '(cl-block-wrapper cl-block-throw 1402 '(cl--block-wrapper cl--block-throw
1403 multiple-value-call nth-value 1403 multiple-value-call nth-value
1404 copy-seq first second rest endp cl-member 1404 copy-seq first second rest endp cl-member
1405 ;; These are included in generated code 1405 ;; These are included in generated code
1406 ;; that can't be called except at compile time 1406 ;; that can't be called except at compile time
1407 ;; or unless cl is loaded anyway. 1407 ;; or unless cl is loaded anyway.
1408 cl-defsubst-expand cl-struct-setf-expander 1408 cl--defsubst-expand cl-struct-setf-expander
1409 ;; These would sometimes be warned about 1409 ;; These would sometimes be warned about
1410 ;; but such warnings are never useful, 1410 ;; but such warnings are never useful,
1411 ;; so don't warn about them. 1411 ;; so don't warn about them.
1412 macroexpand cl-macroexpand-all 1412 macroexpand cl-macroexpand-all
1413 cl-compiling-file)))) 1413 cl--compiling-file))))
1414 (byte-compile-warn "function `%s' from cl package called at runtime" 1414 (byte-compile-warn "function `%s' from cl package called at runtime"
1415 func))) 1415 func)))
1416 form) 1416 form)
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 5c5802f0e02..53c83e73d2e 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -1,4 +1,4 @@
1;;; cl-extra.el --- Common Lisp features, part 2 1;;; cl-extra.el --- Common Lisp features, part 2 -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1993, 2000-2012 Free Software Foundation, Inc. 3;; Copyright (C) 1993, 2000-2012 Free Software Foundation, Inc.
4 4
@@ -88,7 +88,7 @@ strings case-insensitively."
88;;; Control structures. 88;;; Control structures.
89 89
90;;;###autoload 90;;;###autoload
91(defun cl-mapcar-many (cl-func cl-seqs) 91(defun cl--mapcar-many (cl-func cl-seqs)
92 (if (cdr (cdr cl-seqs)) 92 (if (cdr (cdr cl-seqs))
93 (let* ((cl-res nil) 93 (let* ((cl-res nil)
94 (cl-n (apply 'min (mapcar 'length cl-seqs))) 94 (cl-n (apply 'min (mapcar 'length cl-seqs)))
@@ -222,7 +222,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
222 (not (apply 'cl-every cl-pred cl-seq cl-rest))) 222 (not (apply 'cl-every cl-pred cl-seq cl-rest)))
223 223
224;;;###autoload 224;;;###autoload
225(defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) 225(defun cl--map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
226 (or cl-base 226 (or cl-base
227 (setq cl-base (copy-sequence [0]))) 227 (setq cl-base (copy-sequence [0])))
228 (map-keymap 228 (map-keymap
@@ -230,14 +230,14 @@ If so, return the true (non-nil) value returned by PREDICATE.
230 (lambda (cl-key cl-bind) 230 (lambda (cl-key cl-bind)
231 (aset cl-base (1- (length cl-base)) cl-key) 231 (aset cl-base (1- (length cl-base)) cl-key)
232 (if (keymapp cl-bind) 232 (if (keymapp cl-bind)
233 (cl-map-keymap-recursively 233 (cl--map-keymap-recursively
234 cl-func-rec cl-bind 234 cl-func-rec cl-bind
235 (vconcat cl-base (list 0))) 235 (vconcat cl-base (list 0)))
236 (funcall cl-func-rec cl-base cl-bind)))) 236 (funcall cl-func-rec cl-base cl-bind))))
237 cl-map)) 237 cl-map))
238 238
239;;;###autoload 239;;;###autoload
240(defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end) 240(defun cl--map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
241 (or cl-what (setq cl-what (current-buffer))) 241 (or cl-what (setq cl-what (current-buffer)))
242 (if (bufferp cl-what) 242 (if (bufferp cl-what)
243 (let (cl-mark cl-mark2 (cl-next t) cl-next2) 243 (let (cl-mark cl-mark2 (cl-next t) cl-next2)
@@ -265,7 +265,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
265 (setq cl-start cl-next))))) 265 (setq cl-start cl-next)))))
266 266
267;;;###autoload 267;;;###autoload
268(defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) 268(defun cl--map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
269 (or cl-buffer (setq cl-buffer (current-buffer))) 269 (or cl-buffer (setq cl-buffer (current-buffer)))
270 (if (fboundp 'overlay-lists) 270 (if (fboundp 'overlay-lists)
271 271
@@ -307,30 +307,30 @@ If so, return the true (non-nil) value returned by PREDICATE.
307 307
308;;; Support for `cl-setf'. 308;;; Support for `cl-setf'.
309;;;###autoload 309;;;###autoload
310(defun cl-set-frame-visible-p (frame val) 310(defun cl--set-frame-visible-p (frame val)
311 (cond ((null val) (make-frame-invisible frame)) 311 (cond ((null val) (make-frame-invisible frame))
312 ((eq val 'icon) (iconify-frame frame)) 312 ((eq val 'icon) (iconify-frame frame))
313 (t (make-frame-visible frame))) 313 (t (make-frame-visible frame)))
314 val) 314 val)
315 315
316;;; Support for `cl-progv'. 316;;; Support for `cl-progv'.
317(defvar cl-progv-save) 317(defvar cl--progv-save)
318;;;###autoload 318;;;###autoload
319(defun cl-progv-before (syms values) 319(defun cl--progv-before (syms values)
320 (while syms 320 (while syms
321 (push (if (boundp (car syms)) 321 (push (if (boundp (car syms))
322 (cons (car syms) (symbol-value (car syms))) 322 (cons (car syms) (symbol-value (car syms)))
323 (car syms)) cl-progv-save) 323 (car syms)) cl--progv-save)
324 (if values 324 (if values
325 (set (pop syms) (pop values)) 325 (set (pop syms) (pop values))
326 (makunbound (pop syms))))) 326 (makunbound (pop syms)))))
327 327
328(defun cl-progv-after () 328(defun cl--progv-after ()
329 (while cl-progv-save 329 (while cl--progv-save
330 (if (consp (car cl-progv-save)) 330 (if (consp (car cl--progv-save))
331 (set (car (car cl-progv-save)) (cdr (car cl-progv-save))) 331 (set (car (car cl--progv-save)) (cdr (car cl--progv-save)))
332 (makunbound (car cl-progv-save))) 332 (makunbound (car cl--progv-save)))
333 (pop cl-progv-save))) 333 (pop cl--progv-save)))
334 334
335 335
336;;; Numbers. 336;;; Numbers.
@@ -469,8 +469,8 @@ If STATE is t, return a new state object seeded from the time of day."
469 469
470;; Implementation limits. 470;; Implementation limits.
471 471
472(defun cl-finite-do (func a b) 472(defun cl--finite-do (func a b)
473 (condition-case err 473 (condition-case _
474 (let ((res (funcall func a b))) ; check for IEEE infinity 474 (let ((res (funcall func a b))) ; check for IEEE infinity
475 (and (numberp res) (/= res (/ res 2)) res)) 475 (and (numberp res) (/= res (/ res 2)) res))
476 (arith-error nil))) 476 (arith-error nil)))
@@ -485,25 +485,25 @@ This sets the values of: `cl-most-positive-float', `cl-most-negative-float',
485 (or cl-most-positive-float (not (numberp '2e1)) 485 (or cl-most-positive-float (not (numberp '2e1))
486 (let ((x '2e0) y z) 486 (let ((x '2e0) y z)
487 ;; Find maximum exponent (first two loops are optimizations) 487 ;; Find maximum exponent (first two loops are optimizations)
488 (while (cl-finite-do '* x x) (setq x (* x x))) 488 (while (cl--finite-do '* x x) (setq x (* x x)))
489 (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2)))) 489 (while (cl--finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
490 (while (cl-finite-do '+ x x) (setq x (+ x x))) 490 (while (cl--finite-do '+ x x) (setq x (+ x x)))
491 (setq z x y (/ x 2)) 491 (setq z x y (/ x 2))
492 ;; Now cl-fill in 1's in the mantissa. 492 ;; Now cl-fill in 1's in the mantissa.
493 (while (and (cl-finite-do '+ x y) (/= (+ x y) x)) 493 (while (and (cl--finite-do '+ x y) (/= (+ x y) x))
494 (setq x (+ x y) y (/ y 2))) 494 (setq x (+ x y) y (/ y 2)))
495 (setq cl-most-positive-float x 495 (setq cl-most-positive-float x
496 cl-most-negative-float (- x)) 496 cl-most-negative-float (- x))
497 ;; Divide down until mantissa starts rounding. 497 ;; Divide down until mantissa starts rounding.
498 (setq x (/ x z) y (/ 16 z) x (* x y)) 498 (setq x (/ x z) y (/ 16 z) x (* x y))
499 (while (condition-case err (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) 499 (while (condition-case _ (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
500 (arith-error nil)) 500 (arith-error nil))
501 (setq x (/ x 2) y (/ y 2))) 501 (setq x (/ x 2) y (/ y 2)))
502 (setq cl-least-positive-normalized-float y 502 (setq cl-least-positive-normalized-float y
503 cl-least-negative-normalized-float (- y)) 503 cl-least-negative-normalized-float (- y))
504 ;; Divide down until value underflows to zero. 504 ;; Divide down until value underflows to zero.
505 (setq x (/ 1 z) y x) 505 (setq x (/ 1 z) y x)
506 (while (condition-case err (> (/ x 2) 0) (arith-error nil)) 506 (while (condition-case _ (> (/ x 2) 0) (arith-error nil))
507 (setq x (/ x 2))) 507 (setq x (/ x 2)))
508 (setq cl-least-positive-float x 508 (setq cl-least-positive-float x
509 cl-least-negative-float (- x)) 509 cl-least-negative-float (- x))
@@ -612,13 +612,13 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
612 (if plist (car (cdr plist)) def)))) 612 (if plist (car (cdr plist)) def))))
613 613
614;;;###autoload 614;;;###autoload
615(defun cl-set-getf (plist tag val) 615(defun cl--set-getf (plist tag val)
616 (let ((p plist)) 616 (let ((p plist))
617 (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p)))) 617 (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p))))
618 (if p (progn (setcar (cdr p) val) plist) (cl-list* tag val plist)))) 618 (if p (progn (setcar (cdr p) val) plist) (cl-list* tag val plist))))
619 619
620;;;###autoload 620;;;###autoload
621(defun cl-do-remf (plist tag) 621(defun cl--do-remf (plist tag)
622 (let ((p (cdr plist))) 622 (let ((p (cdr plist)))
623 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) 623 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
624 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) 624 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
@@ -630,7 +630,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
630 (let ((plist (symbol-plist sym))) 630 (let ((plist (symbol-plist sym)))
631 (if (and plist (eq tag (car plist))) 631 (if (and plist (eq tag (car plist)))
632 (progn (setplist sym (cdr (cdr plist))) t) 632 (progn (setplist sym (cdr (cdr plist))) t)
633 (cl-do-remf plist tag)))) 633 (cl--do-remf plist tag))))
634 634
635;;; Some debugging aids. 635;;; Some debugging aids.
636 636
@@ -646,15 +646,15 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
646 (forward-sexp) 646 (forward-sexp)
647 (delete-char 1)) 647 (delete-char 1))
648 (goto-char (1+ pt)) 648 (goto-char (1+ pt))
649 (cl-do-prettyprint))) 649 (cl--do-prettyprint)))
650 650
651(defun cl-do-prettyprint () 651(defun cl--do-prettyprint ()
652 (skip-chars-forward " ") 652 (skip-chars-forward " ")
653 (if (looking-at "(") 653 (if (looking-at "(")
654 (let ((skip (or (looking-at "((") (looking-at "(prog") 654 (let ((skip (or (looking-at "((") (looking-at "(prog")
655 (looking-at "(unwind-protect ") 655 (looking-at "(unwind-protect ")
656 (looking-at "(function (") 656 (looking-at "(function (")
657 (looking-at "(cl-block-wrapper "))) 657 (looking-at "(cl--block-wrapper ")))
658 (two (or (looking-at "(defun ") (looking-at "(defmacro "))) 658 (two (or (looking-at "(defun ") (looking-at "(defmacro ")))
659 (let (or (looking-at "(let\\*? ") (looking-at "(while "))) 659 (let (or (looking-at "(let\\*? ") (looking-at "(while ")))
660 (set (looking-at "(p?set[qf] "))) 660 (set (looking-at "(p?set[qf] ")))
@@ -664,21 +664,21 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
664 (and (>= (current-column) 78) (progn (backward-sexp) t)))) 664 (and (>= (current-column) 78) (progn (backward-sexp) t))))
665 (let ((nl t)) 665 (let ((nl t))
666 (forward-char 1) 666 (forward-char 1)
667 (cl-do-prettyprint) 667 (cl--do-prettyprint)
668 (or skip (looking-at ")") (cl-do-prettyprint)) 668 (or skip (looking-at ")") (cl--do-prettyprint))
669 (or (not two) (looking-at ")") (cl-do-prettyprint)) 669 (or (not two) (looking-at ")") (cl--do-prettyprint))
670 (while (not (looking-at ")")) 670 (while (not (looking-at ")"))
671 (if set (setq nl (not nl))) 671 (if set (setq nl (not nl)))
672 (if nl (insert "\n")) 672 (if nl (insert "\n"))
673 (lisp-indent-line) 673 (lisp-indent-line)
674 (cl-do-prettyprint)) 674 (cl--do-prettyprint))
675 (forward-char 1)))) 675 (forward-char 1))))
676 (forward-sexp))) 676 (forward-sexp)))
677 677
678;;;###autoload 678;;;###autoload
679(defun cl-prettyexpand (form &optional full) 679(defun cl-prettyexpand (form &optional full)
680 (message "Expanding...") 680 (message "Expanding...")
681 (let ((cl-macroexpand-cmacs full) (cl-compiling-file full) 681 (let ((cl--compiling-file full)
682 (byte-compile-macro-environment nil)) 682 (byte-compile-macro-environment nil))
683 (setq form (macroexpand-all form 683 (setq form (macroexpand-all form
684 (and (not full) '((cl-block) (cl-eval-when))))) 684 (and (not full) '((cl-block) (cl-eval-when)))))
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 8c0743001f7..e3cf0d3a520 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -1,4 +1,4 @@
1;;; cl-lib.el --- Common Lisp extensions for Emacs 1;;; cl-lib.el --- Common Lisp extensions for Emacs -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc. 3;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc.
4 4
@@ -114,7 +114,7 @@ a future Emacs interpreter will be able to use it.")
114(defun cl-unload-function () 114(defun cl-unload-function ()
115 "Stop unloading of the Common Lisp extensions." 115 "Stop unloading of the Common Lisp extensions."
116 (message "Cannot unload the feature `cl'") 116 (message "Cannot unload the feature `cl'")
117 ;; stop standard unloading! 117 ;; Stop standard unloading!
118 t) 118 t)
119 119
120;;; Generalized variables. 120;;; Generalized variables.
@@ -185,19 +185,19 @@ an element already on the list.
185 (list 'setq place (cl-list* 'cl-adjoin x place keys))) 185 (list 'setq place (cl-list* 'cl-adjoin x place keys)))
186 (cl-list* 'cl-callf2 'cl-adjoin x place keys))) 186 (cl-list* 'cl-callf2 'cl-adjoin x place keys)))
187 187
188(defun cl-set-elt (seq n val) 188(defun cl--set-elt (seq n val)
189 (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) 189 (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val)))
190 190
191(defsubst cl-set-nthcdr (n list x) 191(defsubst cl--set-nthcdr (n list x)
192 (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list)) 192 (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list))
193 193
194(defun cl-set-buffer-substring (start end val) 194(defun cl--set-buffer-substring (start end val)
195 (save-excursion (delete-region start end) 195 (save-excursion (delete-region start end)
196 (goto-char start) 196 (goto-char start)
197 (insert val) 197 (insert val)
198 val)) 198 val))
199 199
200(defun cl-set-substring (str start end val) 200(defun cl--set-substring (str start end val)
201 (if end (if (< end 0) (cl-incf end (length str))) 201 (if end (if (< end 0) (cl-incf end (length str)))
202 (setq end (length str))) 202 (setq end (length str)))
203 (if (< start 0) (cl-incf start (length str))) 203 (if (< start 0) (cl-incf start (length str)))
@@ -206,19 +206,10 @@ an element already on the list.
206 (and (< end (length str)) (substring str end)))) 206 (and (< end (length str)) (substring str end))))
207 207
208 208
209;;; Control structures.
210
211;; These macros are so simple and so often-used that it's better to have
212;; them all the time than to load them from cl-macs.el.
213
214(defun cl-map-extents (&rest cl-args)
215 (apply 'cl-map-overlays cl-args))
216
217
218;;; Blocks and exits. 209;;; Blocks and exits.
219 210
220(defalias 'cl-block-wrapper 'identity) 211(defalias 'cl--block-wrapper 'identity)
221(defalias 'cl-block-throw 'throw) 212(defalias 'cl--block-throw 'throw)
222 213
223 214
224;;; Multiple values. 215;;; Multiple values.
@@ -269,9 +260,9 @@ one value."
269 260
270;;; Declarations. 261;;; Declarations.
271 262
272(defvar cl-compiling-file nil) 263(defvar cl--compiling-file nil)
273(defun cl-compiling-file () 264(defun cl--compiling-file ()
274 (or cl-compiling-file 265 (or cl--compiling-file
275 (and (boundp 'byte-compile--outbuffer) 266 (and (boundp 'byte-compile--outbuffer)
276 (bufferp (symbol-value 'byte-compile--outbuffer)) 267 (bufferp (symbol-value 'byte-compile--outbuffer))
277 (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) 268 (equal (buffer-name (symbol-value 'byte-compile--outbuffer))
@@ -287,7 +278,7 @@ one value."
287(defmacro cl-declaim (&rest specs) 278(defmacro cl-declaim (&rest specs)
288 (let ((body (mapcar (function (lambda (x) (list 'cl-proclaim (list 'quote x)))) 279 (let ((body (mapcar (function (lambda (x) (list 'cl-proclaim (list 'quote x))))
289 specs))) 280 specs)))
290 (if (cl-compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body) 281 (if (cl--compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body)
291 (cons 'progn body)))) ; avoid loading cl-macs.el for cl-eval-when 282 (cons 'progn body)))) ; avoid loading cl-macs.el for cl-eval-when
292 283
293 284
@@ -378,7 +369,7 @@ Call `cl-float-limits' to set this.")
378 369
379(defalias 'cl-copy-seq 'copy-sequence) 370(defalias 'cl-copy-seq 'copy-sequence)
380 371
381(declare-function cl-mapcar-many "cl-extra" (cl-func cl-seqs)) 372(declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs))
382 373
383(defun cl-mapcar (cl-func cl-x &rest cl-rest) 374(defun cl-mapcar (cl-func cl-x &rest cl-rest)
384 "Apply FUNCTION to each element of SEQ, and make a list of the results. 375 "Apply FUNCTION to each element of SEQ, and make a list of the results.
@@ -389,7 +380,7 @@ SEQ, this is like `mapcar'. With several, it is like the Common Lisp
389\n(fn FUNCTION SEQ...)" 380\n(fn FUNCTION SEQ...)"
390 (if cl-rest 381 (if cl-rest
391 (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) 382 (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest)))
392 (cl-mapcar-many cl-func (cons cl-x cl-rest)) 383 (cl--mapcar-many cl-func (cons cl-x cl-rest))
393 (let ((cl-res nil) (cl-y (car cl-rest))) 384 (let ((cl-res nil) (cl-y (car cl-rest)))
394 (while (and cl-x cl-y) 385 (while (and cl-x cl-y)
395 (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res)) 386 (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res))
@@ -575,10 +566,6 @@ The elements of LIST are not copied, just the list structure itself."
575 (prog1 (nreverse res) (setcdr res list))) 566 (prog1 (nreverse res) (setcdr res list)))
576 (car list))) 567 (car list)))
577 568
578(defun cl-maclisp-member (item list)
579 (while (and list (not (equal item (car list)))) (setq list (cdr list)))
580 list)
581
582;; Autoloaded, but we have not loaded cl-loaddefs yet. 569;; Autoloaded, but we have not loaded cl-loaddefs yet.
583(declare-function cl-floor "cl-extra" (x &optional y)) 570(declare-function cl-floor "cl-extra" (x &optional y))
584(declare-function cl-ceiling "cl-extra" (x &optional y)) 571(declare-function cl-ceiling "cl-extra" (x &optional y))
@@ -607,13 +594,13 @@ Return a copy of TREE with all elements `eql' to OLD replaced by NEW.
607\n(fn NEW OLD TREE [KEYWORD VALUE]...)" 594\n(fn NEW OLD TREE [KEYWORD VALUE]...)"
608 (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) 595 (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old))))
609 (apply 'cl-sublis (list (cons cl-old cl-new)) cl-tree cl-keys) 596 (apply 'cl-sublis (list (cons cl-old cl-new)) cl-tree cl-keys)
610 (cl-do-subst cl-new cl-old cl-tree))) 597 (cl--do-subst cl-new cl-old cl-tree)))
611 598
612(defun cl-do-subst (cl-new cl-old cl-tree) 599(defun cl--do-subst (cl-new cl-old cl-tree)
613 (cond ((eq cl-tree cl-old) cl-new) 600 (cond ((eq cl-tree cl-old) cl-new)
614 ((consp cl-tree) 601 ((consp cl-tree)
615 (let ((a (cl-do-subst cl-new cl-old (car cl-tree))) 602 (let ((a (cl--do-subst cl-new cl-old (car cl-tree)))
616 (d (cl-do-subst cl-new cl-old (cdr cl-tree)))) 603 (d (cl--do-subst cl-new cl-old (cdr cl-tree))))
617 (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) 604 (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree)))
618 cl-tree (cons a d)))) 605 cl-tree (cons a d))))
619 (t cl-tree))) 606 (t cl-tree)))
diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el
index 87ae4223737..064ddbde9d0 100644
--- a/lisp/emacs-lisp/cl-loaddefs.el
+++ b/lisp/emacs-lisp/cl-loaddefs.el
@@ -3,15 +3,15 @@
3;;; Code: 3;;; Code:
4 4
5 5
6;;;### (autoloads (cl-prettyexpand cl-remprop cl-do-remf cl-set-getf 6;;;### (autoloads (cl-prettyexpand cl-remprop cl--do-remf cl--set-getf
7;;;;;; cl-getf cl-get cl-tailp cl-list-length cl-nreconc cl-revappend 7;;;;;; cl-getf cl-get cl-tailp cl-list-length cl-nreconc cl-revappend
8;;;;;; cl-concatenate cl-subseq cl-float-limits cl-random-state-p 8;;;;;; cl-concatenate cl-subseq cl-float-limits cl-random-state-p
9;;;;;; cl-make-random-state cl-random cl-signum cl-rem cl-mod cl-round 9;;;;;; cl-make-random-state cl-random cl-signum cl-rem cl-mod cl-round
10;;;;;; cl-truncate cl-ceiling cl-floor cl-isqrt cl-lcm cl-gcd cl-progv-before 10;;;;;; cl-truncate cl-ceiling cl-floor cl-isqrt cl-lcm cl-gcd cl--progv-before
11;;;;;; cl-set-frame-visible-p cl-map-overlays cl-map-intervals cl-map-keymap-recursively 11;;;;;; cl--set-frame-visible-p cl--map-overlays cl--map-intervals
12;;;;;; cl-notevery cl-notany cl-every cl-some cl-mapcon cl-mapcan 12;;;;;; cl--map-keymap-recursively cl-notevery cl-notany cl-every
13;;;;;; cl-mapl cl-maplist cl-map cl-mapcar-many cl-equalp cl-coerce) 13;;;;;; cl-some cl-mapcon cl-mapcan cl-mapl cl-maplist cl-map cl--mapcar-many
14;;;;;; "cl-extra" "cl-extra.el" "6661c504c379dfde0c37a0f8e2ba6568") 14;;;;;; cl-equalp cl-coerce) "cl-extra" "cl-extra.el" "1f486111e93d119ceb6e95c434e3fd4b")
15;;; Generated autoloads from cl-extra.el 15;;; Generated autoloads from cl-extra.el
16 16
17(autoload 'cl-coerce "cl-extra" "\ 17(autoload 'cl-coerce "cl-extra" "\
@@ -28,7 +28,7 @@ strings case-insensitively.
28 28
29\(fn X Y)" nil nil) 29\(fn X Y)" nil nil)
30 30
31(autoload 'cl-mapcar-many "cl-extra" "\ 31(autoload 'cl--mapcar-many "cl-extra" "\
32 32
33 33
34\(fn CL-FUNC CL-SEQS)" nil nil) 34\(fn CL-FUNC CL-SEQS)" nil nil)
@@ -82,27 +82,27 @@ Return true if PREDICATE is false of some element of SEQ or SEQs.
82 82
83\(fn PREDICATE SEQ...)" nil nil) 83\(fn PREDICATE SEQ...)" nil nil)
84 84
85(autoload 'cl-map-keymap-recursively "cl-extra" "\ 85(autoload 'cl--map-keymap-recursively "cl-extra" "\
86 86
87 87
88\(fn CL-FUNC-REC CL-MAP &optional CL-BASE)" nil nil) 88\(fn CL-FUNC-REC CL-MAP &optional CL-BASE)" nil nil)
89 89
90(autoload 'cl-map-intervals "cl-extra" "\ 90(autoload 'cl--map-intervals "cl-extra" "\
91 91
92 92
93\(fn CL-FUNC &optional CL-WHAT CL-PROP CL-START CL-END)" nil nil) 93\(fn CL-FUNC &optional CL-WHAT CL-PROP CL-START CL-END)" nil nil)
94 94
95(autoload 'cl-map-overlays "cl-extra" "\ 95(autoload 'cl--map-overlays "cl-extra" "\
96 96
97 97
98\(fn CL-FUNC &optional CL-BUFFER CL-START CL-END CL-ARG)" nil nil) 98\(fn CL-FUNC &optional CL-BUFFER CL-START CL-END CL-ARG)" nil nil)
99 99
100(autoload 'cl-set-frame-visible-p "cl-extra" "\ 100(autoload 'cl--set-frame-visible-p "cl-extra" "\
101 101
102 102
103\(fn FRAME VAL)" nil nil) 103\(fn FRAME VAL)" nil nil)
104 104
105(autoload 'cl-progv-before "cl-extra" "\ 105(autoload 'cl--progv-before "cl-extra" "\
106 106
107 107
108\(fn SYMS VALUES)" nil nil) 108\(fn SYMS VALUES)" nil nil)
@@ -232,12 +232,12 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
232 232
233\(fn PROPLIST PROPNAME &optional DEFAULT)" nil nil) 233\(fn PROPLIST PROPNAME &optional DEFAULT)" nil nil)
234 234
235(autoload 'cl-set-getf "cl-extra" "\ 235(autoload 'cl--set-getf "cl-extra" "\
236 236
237 237
238\(fn PLIST TAG VAL)" nil nil) 238\(fn PLIST TAG VAL)" nil nil)
239 239
240(autoload 'cl-do-remf "cl-extra" "\ 240(autoload 'cl--do-remf "cl-extra" "\
241 241
242 242
243\(fn PLIST TAG)" nil nil) 243\(fn PLIST TAG)" nil nil)
@@ -265,7 +265,7 @@ Remove from SYMBOL's plist the property PROPNAME and its value.
265;;;;;; cl-do* cl-do cl-loop cl-return-from cl-return cl-block cl-etypecase 265;;;;;; cl-do* cl-do cl-loop cl-return-from cl-return cl-block cl-etypecase
266;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when 266;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when
267;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp 267;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp
268;;;;;; cl-gensym) "cl-macs" "cl-macs.el" "9eb287dd2a8d20f1c6459a9d095fa335") 268;;;;;; cl-gensym) "cl-macs" "cl-macs.el" "a8ede90b4a2ce9015d4b63254b4678a2")
269;;; Generated autoloads from cl-macs.el 269;;; Generated autoloads from cl-macs.el
270 270
271(autoload 'cl-gensym "cl-macs" "\ 271(autoload 'cl-gensym "cl-macs" "\
@@ -791,7 +791,7 @@ surrounded by (cl-block NAME ...).
791;;;;;; cl-nsubstitute-if cl-nsubstitute cl-substitute-if-not cl-substitute-if 791;;;;;; cl-nsubstitute-if cl-nsubstitute cl-substitute-if-not cl-substitute-if
792;;;;;; cl-substitute cl-delete-duplicates cl-remove-duplicates cl-delete-if-not 792;;;;;; cl-substitute cl-delete-duplicates cl-remove-duplicates cl-delete-if-not
793;;;;;; cl-delete-if cl-delete cl-remove-if-not cl-remove-if cl-remove 793;;;;;; cl-delete-if cl-delete cl-remove-if-not cl-remove-if cl-remove
794;;;;;; cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "8877479cb008b43a94098f3e6ec85d91") 794;;;;;; cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "b444601641dcbd14a23ca5182bc80ffa")
795;;; Generated autoloads from cl-seq.el 795;;; Generated autoloads from cl-seq.el
796 796
797(autoload 'cl-reduce "cl-seq" "\ 797(autoload 'cl-reduce "cl-seq" "\
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 60f1189718b..6747d70e1fc 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -203,6 +203,65 @@ The name is made by appending a number to PREFIX, default \"G\"."
203(def-edebug-spec cl-&key-arg 203(def-edebug-spec cl-&key-arg
204 (&or ([&or (symbolp arg) arg] &optional def-form arg) arg)) 204 (&or ([&or (symbolp arg) arg] &optional def-form arg) arg))
205 205
206(defconst cl--lambda-list-keywords
207 '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
208
209(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote)
210(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms)
211
212(defun cl--transform-lambda (form bind-block)
213 (let* ((args (car form)) (body (cdr form)) (orig-args args)
214 (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil)
215 (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil)
216 (header nil) (simple-args nil))
217 (while (or (stringp (car body))
218 (memq (car-safe (car body)) '(interactive cl-declare)))
219 (push (pop body) header))
220 (setq args (if (listp args) (cl-copy-list args) (list '&rest args)))
221 (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
222 (if (setq cl--bind-defs (cadr (memq '&cl-defs args)))
223 (setq args (delq '&cl-defs (delq cl--bind-defs args))
224 cl--bind-defs (cadr cl--bind-defs)))
225 (if (setq cl--bind-enquote (memq '&cl-quote args))
226 (setq args (delq '&cl-quote args)))
227 (if (memq '&whole args) (error "&whole not currently implemented"))
228 (let* ((p (memq '&environment args)) (v (cadr p))
229 (env-exp 'macroexpand-all-environment))
230 (if p (setq args (nconc (delq (car p) (delq v args))
231 (list '&aux (list v env-exp))))))
232 (while (and args (symbolp (car args))
233 (not (memq (car args) '(nil &rest &body &key &aux)))
234 (not (and (eq (car args) '&optional)
235 (or cl--bind-defs (consp (cadr args))))))
236 (push (pop args) simple-args))
237 (or (eq cl--bind-block 'cl-none)
238 (setq body (list `(cl-block ,cl--bind-block ,@body))))
239 (if (null args)
240 (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body))
241 (if (memq '&optional simple-args) (push '&optional args))
242 (cl--do-arglist args nil (- (length simple-args)
243 (if (memq '&optional simple-args) 1 0)))
244 (setq cl--bind-lets (nreverse cl--bind-lets))
245 (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval)
246 ,@(nreverse cl--bind-inits)))
247 (nconc (nreverse simple-args)
248 (list '&rest (car (pop cl--bind-lets))))
249 (nconc (let ((hdr (nreverse header)))
250 ;; Macro expansion can take place in the middle of
251 ;; apparently harmless computation, so it should not
252 ;; touch the match-data.
253 (save-match-data
254 (require 'help-fns)
255 (cons (help-add-fundoc-usage
256 (if (stringp (car hdr)) (pop hdr))
257 (format "%S"
258 (cons 'fn
259 (cl--make-usage-args orig-args))))
260 hdr)))
261 (list `(let* ,cl--bind-lets
262 ,@(nreverse cl--bind-forms)
263 ,@body)))))))
264
206;;;###autoload 265;;;###autoload
207(defmacro cl-defun (name args &rest body) 266(defmacro cl-defun (name args &rest body)
208 "Define NAME as a function. 267 "Define NAME as a function.
@@ -307,12 +366,6 @@ its argument list allows full Common Lisp conventions."
307 `(progn ,@(cdr (cdr (car res))) 366 `(progn ,@(cdr (cdr (car res)))
308 (put ',func ',prop #'(lambda . ,(cdr res)))))) 367 (put ',func ',prop #'(lambda . ,(cdr res))))))
309 368
310(defconst cl-lambda-list-keywords
311 '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
312
313(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote)
314(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms)
315
316(declare-function help-add-fundoc-usage "help-fns" (docstring arglist)) 369(declare-function help-add-fundoc-usage "help-fns" (docstring arglist))
317 370
318(defun cl--make-usage-var (x) 371(defun cl--make-usage-var (x)
@@ -346,62 +399,9 @@ its argument list allows full Common Lisp conventions."
346 )))) 399 ))))
347 arglist))) 400 arglist)))
348 401
349(defun cl--transform-lambda (form bind-block)
350 (let* ((args (car form)) (body (cdr form)) (orig-args args)
351 (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil)
352 (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil)
353 (header nil) (simple-args nil))
354 (while (or (stringp (car body))
355 (memq (car-safe (car body)) '(interactive cl-declare)))
356 (push (pop body) header))
357 (setq args (if (listp args) (cl-copy-list args) (list '&rest args)))
358 (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
359 (if (setq cl--bind-defs (cadr (memq '&cl-defs args)))
360 (setq args (delq '&cl-defs (delq cl--bind-defs args))
361 cl--bind-defs (cadr cl--bind-defs)))
362 (if (setq cl--bind-enquote (memq '&cl-quote args))
363 (setq args (delq '&cl-quote args)))
364 (if (memq '&whole args) (error "&whole not currently implemented"))
365 (let* ((p (memq '&environment args)) (v (cadr p))
366 (env-exp 'macroexpand-all-environment))
367 (if p (setq args (nconc (delq (car p) (delq v args))
368 (list '&aux (list v env-exp))))))
369 (while (and args (symbolp (car args))
370 (not (memq (car args) '(nil &rest &body &key &aux)))
371 (not (and (eq (car args) '&optional)
372 (or cl--bind-defs (consp (cadr args))))))
373 (push (pop args) simple-args))
374 (or (eq cl--bind-block 'cl-none)
375 (setq body (list `(cl-block ,cl--bind-block ,@body))))
376 (if (null args)
377 (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body))
378 (if (memq '&optional simple-args) (push '&optional args))
379 (cl--do-arglist args nil (- (length simple-args)
380 (if (memq '&optional simple-args) 1 0)))
381 (setq cl--bind-lets (nreverse cl--bind-lets))
382 (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval)
383 ,@(nreverse cl--bind-inits)))
384 (nconc (nreverse simple-args)
385 (list '&rest (car (pop cl--bind-lets))))
386 (nconc (let ((hdr (nreverse header)))
387 ;; Macro expansion can take place in the middle of
388 ;; apparently harmless computation, so it should not
389 ;; touch the match-data.
390 (save-match-data
391 (require 'help-fns)
392 (cons (help-add-fundoc-usage
393 (if (stringp (car hdr)) (pop hdr))
394 (format "%S"
395 (cons 'fn
396 (cl--make-usage-args orig-args))))
397 hdr)))
398 (list `(let* ,cl--bind-lets
399 ,@(nreverse cl--bind-forms)
400 ,@body)))))))
401
402(defun cl--do-arglist (args expr &optional num) ; uses bind-* 402(defun cl--do-arglist (args expr &optional num) ; uses bind-*
403 (if (nlistp args) 403 (if (nlistp args)
404 (if (or (memq args cl-lambda-list-keywords) (not (symbolp args))) 404 (if (or (memq args cl--lambda-list-keywords) (not (symbolp args)))
405 (error "Invalid argument name: %s" args) 405 (error "Invalid argument name: %s" args)
406 (push (list args expr) cl--bind-lets)) 406 (push (list args expr) cl--bind-lets))
407 (setq args (cl-copy-list args)) 407 (setq args (cl-copy-list args))
@@ -410,7 +410,7 @@ its argument list allows full Common Lisp conventions."
410 (if (memq '&environment args) (error "&environment used incorrectly")) 410 (if (memq '&environment args) (error "&environment used incorrectly"))
411 (let ((save-args args) 411 (let ((save-args args)
412 (restarg (memq '&rest args)) 412 (restarg (memq '&rest args))
413 (safety (if (cl-compiling-file) cl-optimize-safety 3)) 413 (safety (if (cl--compiling-file) cl-optimize-safety 3))
414 (keys nil) 414 (keys nil)
415 (laterarg nil) (exactarg nil) minarg) 415 (laterarg nil) (exactarg nil) minarg)
416 (or num (setq num 0)) 416 (or num (setq num 0))
@@ -422,14 +422,14 @@ its argument list allows full Common Lisp conventions."
422 (push (list (cl-pop2 args) restarg) cl--bind-lets)) 422 (push (list (cl-pop2 args) restarg) cl--bind-lets))
423 (let ((p args)) 423 (let ((p args))
424 (setq minarg restarg) 424 (setq minarg restarg)
425 (while (and p (not (memq (car p) cl-lambda-list-keywords))) 425 (while (and p (not (memq (car p) cl--lambda-list-keywords)))
426 (or (eq p args) (setq minarg (list 'cdr minarg))) 426 (or (eq p args) (setq minarg (list 'cdr minarg)))
427 (setq p (cdr p))) 427 (setq p (cdr p)))
428 (if (memq (car p) '(nil &aux)) 428 (if (memq (car p) '(nil &aux))
429 (setq minarg `(= (length ,restarg) 429 (setq minarg `(= (length ,restarg)
430 ,(length (cl-ldiff args p))) 430 ,(length (cl-ldiff args p)))
431 exactarg (not (eq args p))))) 431 exactarg (not (eq args p)))))
432 (while (and args (not (memq (car args) cl-lambda-list-keywords))) 432 (while (and args (not (memq (car args) cl--lambda-list-keywords)))
433 (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) 433 (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
434 restarg))) 434 restarg)))
435 (cl--do-arglist 435 (cl--do-arglist
@@ -442,7 +442,7 @@ its argument list allows full Common Lisp conventions."
442 (length ,restarg))))))) 442 (length ,restarg)))))))
443 (setq num (1+ num) laterarg t)) 443 (setq num (1+ num) laterarg t))
444 (while (and (eq (car args) '&optional) (pop args)) 444 (while (and (eq (car args) '&optional) (pop args))
445 (while (and args (not (memq (car args) cl-lambda-list-keywords))) 445 (while (and args (not (memq (car args) cl--lambda-list-keywords)))
446 (let ((arg (pop args))) 446 (let ((arg (pop args)))
447 (or (consp arg) (setq arg (list arg))) 447 (or (consp arg) (setq arg (list arg)))
448 (if (cddr arg) (cl--do-arglist (nth 2 arg) `(and ,restarg t))) 448 (if (cddr arg) (cl--do-arglist (nth 2 arg) `(and ,restarg t)))
@@ -466,7 +466,7 @@ its argument list allows full Common Lisp conventions."
466 (+ ,num (length ,restarg))))) 466 (+ ,num (length ,restarg)))))
467 cl--bind-forms))) 467 cl--bind-forms)))
468 (while (and (eq (car args) '&key) (pop args)) 468 (while (and (eq (car args) '&key) (pop args))
469 (while (and args (not (memq (car args) cl-lambda-list-keywords))) 469 (while (and args (not (memq (car args) cl--lambda-list-keywords)))
470 (let ((arg (pop args))) 470 (let ((arg (pop args)))
471 (or (consp arg) (setq arg (list arg))) 471 (or (consp arg) (setq arg (list arg)))
472 (let* ((karg (if (consp (car arg)) (caar arg) 472 (let* ((karg (if (consp (car arg)) (caar arg)
@@ -511,7 +511,7 @@ its argument list allows full Common Lisp conventions."
511 (car ,var))))))) 511 (car ,var)))))))
512 (push `(let ((,var ,restarg)) ,check) cl--bind-forms))) 512 (push `(let ((,var ,restarg)) ,check) cl--bind-forms)))
513 (while (and (eq (car args) '&aux) (pop args)) 513 (while (and (eq (car args) '&aux) (pop args))
514 (while (and args (not (memq (car args) cl-lambda-list-keywords))) 514 (while (and args (not (memq (car args) cl--lambda-list-keywords)))
515 (if (consp (car args)) 515 (if (consp (car args))
516 (if (and cl--bind-enquote (cl-cadar args)) 516 (if (and cl--bind-enquote (cl-cadar args))
517 (cl--do-arglist (caar args) 517 (cl--do-arglist (caar args)
@@ -525,7 +525,7 @@ its argument list allows full Common Lisp conventions."
525 (let ((res nil) (kind nil) arg) 525 (let ((res nil) (kind nil) arg)
526 (while (consp args) 526 (while (consp args)
527 (setq arg (pop args)) 527 (setq arg (pop args))
528 (if (memq arg cl-lambda-list-keywords) (setq kind arg) 528 (if (memq arg cl--lambda-list-keywords) (setq kind arg)
529 (if (eq arg '&cl-defs) (pop args) 529 (if (eq arg '&cl-defs) (pop args)
530 (and (consp arg) kind (setq arg (car arg))) 530 (and (consp arg) kind (setq arg (car arg)))
531 (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) 531 (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
@@ -557,7 +557,7 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.
557 557
558\(fn (WHEN...) BODY...)" 558\(fn (WHEN...) BODY...)"
559 (declare (indent 1) (debug ((&rest &or "compile" "load" "eval") body))) 559 (declare (indent 1) (debug ((&rest &or "compile" "load" "eval") body)))
560 (if (and (fboundp 'cl-compiling-file) (cl-compiling-file) 560 (if (and (fboundp 'cl--compiling-file) (cl--compiling-file)
561 (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge 561 (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge
562 (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) 562 (let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
563 (cl-not-toplevel t)) 563 (cl-not-toplevel t))
@@ -586,7 +586,7 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.
586 "Like `progn', but evaluates the body at load time. 586 "Like `progn', but evaluates the body at load time.
587The result of the body appears to the compiler as a quoted constant." 587The result of the body appears to the compiler as a quoted constant."
588 (declare (debug (form &optional sexp))) 588 (declare (debug (form &optional sexp)))
589 (if (cl-compiling-file) 589 (if (cl--compiling-file)
590 (let* ((temp (cl-gentemp "--cl-load-time--")) 590 (let* ((temp (cl-gentemp "--cl-load-time--"))
591 (set `(set ',temp ,form))) 591 (set `(set ',temp ,form)))
592 (if (and (fboundp 'byte-compile-file-form-defmumble) 592 (if (and (fboundp 'byte-compile-file-form-defmumble)
@@ -700,7 +700,7 @@ references may appear inside macro expansions, but not inside functions
700called from BODY." 700called from BODY."
701 (declare (indent 1) (debug (symbolp body))) 701 (declare (indent 1) (debug (symbolp body)))
702 (if (cl--safe-expr-p `(progn ,@body)) `(progn ,@body) 702 (if (cl--safe-expr-p `(progn ,@body)) `(progn ,@body)
703 `(cl-block-wrapper 703 `(cl--block-wrapper
704 (catch ',(intern (format "--cl-block-%s--" name)) 704 (catch ',(intern (format "--cl-block-%s--" name))
705 ,@body)))) 705 ,@body))))
706 706
@@ -720,7 +720,7 @@ This is compatible with Common Lisp, but note that `defun' and
720`defmacro' do not create implicit blocks as they do in Common Lisp." 720`defmacro' do not create implicit blocks as they do in Common Lisp."
721 (declare (indent 1) (debug (symbolp &optional form))) 721 (declare (indent 1) (debug (symbolp &optional form)))
722 (let ((name2 (intern (format "--cl-block-%s--" name)))) 722 (let ((name2 (intern (format "--cl-block-%s--" name))))
723 `(cl-block-throw ',name2 ,result))) 723 `(cl--block-throw ',name2 ,result)))
724 724
725 725
726;;; The "cl-loop" macro. 726;;; The "cl-loop" macro.
@@ -1151,7 +1151,7 @@ Valid clauses are:
1151 ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args))) 1151 ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args)))
1152 (t (setq buf (cl-pop2 cl--loop-args))))) 1152 (t (setq buf (cl-pop2 cl--loop-args)))))
1153 (setq cl--loop-map-form 1153 (setq cl--loop-map-form
1154 `(cl-map-extents 1154 `(cl--map-overlays
1155 (lambda (,var ,(make-symbol "--cl-var--")) 1155 (lambda (,var ,(make-symbol "--cl-var--"))
1156 (progn . --cl-map) nil) 1156 (progn . --cl-map) nil)
1157 ,buf ,from ,to)))) 1157 ,buf ,from ,to))))
@@ -1170,7 +1170,7 @@ Valid clauses are:
1170 (setq var1 (car var) var2 (cdr var)) 1170 (setq var1 (car var) var2 (cdr var))
1171 (push (list var `(cons ,var1 ,var2)) loop-for-sets)) 1171 (push (list var `(cons ,var1 ,var2)) loop-for-sets))
1172 (setq cl--loop-map-form 1172 (setq cl--loop-map-form
1173 `(cl-map-intervals 1173 `(cl--map-intervals
1174 (lambda (,var1 ,var2) . --cl-map) 1174 (lambda (,var1 ,var2) . --cl-map)
1175 ,buf ,prop ,from ,to)))) 1175 ,buf ,prop ,from ,to))))
1176 1176
@@ -1188,7 +1188,7 @@ Valid clauses are:
1188 (setq var (prog1 other (setq other var)))) 1188 (setq var (prog1 other (setq other var))))
1189 (setq cl--loop-map-form 1189 (setq cl--loop-map-form
1190 `(,(if (memq word '(key-seq key-seqs)) 1190 `(,(if (memq word '(key-seq key-seqs))
1191 'cl-map-keymap-recursively 'map-keymap) 1191 'cl--map-keymap-recursively 'map-keymap)
1192 (lambda (,var ,other) . --cl-map) ,cl-map)))) 1192 (lambda (,var ,other) . --cl-map) ,cl-map))))
1193 1193
1194 ((memq word '(frame frames screen screens)) 1194 ((memq word '(frame frames screen screens))
@@ -1606,10 +1606,10 @@ second list (or made unbound if VALUES is shorter than SYMBOLS); then the
1606BODY forms are executed and their result is returned. This is much like 1606BODY forms are executed and their result is returned. This is much like
1607a `let' form, except that the list of symbols can be computed at run-time." 1607a `let' form, except that the list of symbols can be computed at run-time."
1608 (declare (indent 2) (debug (form form body))) 1608 (declare (indent 2) (debug (form form body)))
1609 `(let ((cl-progv-save nil)) 1609 `(let ((cl--progv-save nil))
1610 (unwind-protect 1610 (unwind-protect
1611 (progn (cl-progv-before ,symbols ,values) ,@body) 1611 (progn (cl--progv-before ,symbols ,values) ,@body)
1612 (cl-progv-after)))) 1612 (cl--progv-after))))
1613 1613
1614(defvar cl--labels-convert-cache nil) 1614(defvar cl--labels-convert-cache nil)
1615 1615
@@ -1868,7 +1868,7 @@ For instance
1868 1868
1869will turn off byte-compile warnings in the function. 1869will turn off byte-compile warnings in the function.
1870See Info node `(cl)Declarations' for details." 1870See Info node `(cl)Declarations' for details."
1871 (if (cl-compiling-file) 1871 (if (cl--compiling-file)
1872 (while specs 1872 (while specs
1873 (if (listp cl-declare-stack) (push (car specs) cl-declare-stack)) 1873 (if (listp cl-declare-stack) (push (car specs) cl-declare-stack))
1874 (cl-do-proclaim (pop specs) nil))) 1874 (cl-do-proclaim (pop specs) nil)))
@@ -2028,7 +2028,7 @@ Example:
2028(cl-defsetf buffer-name rename-buffer t) 2028(cl-defsetf buffer-name rename-buffer t)
2029(cl-defsetf buffer-string () (store) 2029(cl-defsetf buffer-string () (store)
2030 `(progn (erase-buffer) (insert ,store))) 2030 `(progn (erase-buffer) (insert ,store)))
2031(cl-defsetf buffer-substring cl-set-buffer-substring) 2031(cl-defsetf buffer-substring cl--set-buffer-substring)
2032(cl-defsetf current-buffer set-buffer) 2032(cl-defsetf current-buffer set-buffer)
2033(cl-defsetf current-case-table set-case-table) 2033(cl-defsetf current-case-table set-case-table)
2034(cl-defsetf current-column move-to-column t) 2034(cl-defsetf current-column move-to-column t)
@@ -2050,7 +2050,7 @@ Example:
2050(cl-defsetf file-modes set-file-modes t) 2050(cl-defsetf file-modes set-file-modes t)
2051(cl-defsetf frame-height set-screen-height t) 2051(cl-defsetf frame-height set-screen-height t)
2052(cl-defsetf frame-parameters modify-frame-parameters t) 2052(cl-defsetf frame-parameters modify-frame-parameters t)
2053(cl-defsetf frame-visible-p cl-set-frame-visible-p) 2053(cl-defsetf frame-visible-p cl--set-frame-visible-p)
2054(cl-defsetf frame-width set-screen-width t) 2054(cl-defsetf frame-width set-screen-width t)
2055(cl-defsetf frame-parameter set-frame-parameter t) 2055(cl-defsetf frame-parameter set-frame-parameter t)
2056(cl-defsetf terminal-parameter set-terminal-parameter) 2056(cl-defsetf terminal-parameter set-terminal-parameter)
@@ -2151,8 +2151,8 @@ Example:
2151 (cons n (nth 1 method)) 2151 (cons n (nth 1 method))
2152 (list store-temp) 2152 (list store-temp)
2153 `(let ((,(car (nth 2 method)) 2153 `(let ((,(car (nth 2 method))
2154 (cl-set-nthcdr ,n-temp ,(nth 4 method) 2154 (cl--set-nthcdr ,n-temp ,(nth 4 method)
2155 ,store-temp))) 2155 ,store-temp)))
2156 ,(nth 3 method) ,store-temp) 2156 ,(nth 3 method) ,store-temp)
2157 `(nthcdr ,n-temp ,(nth 4 method))))) 2157 `(nthcdr ,n-temp ,(nth 4 method)))))
2158 2158
@@ -2165,7 +2165,7 @@ Example:
2165 (append (nth 1 method) (list tag def)) 2165 (append (nth 1 method) (list tag def))
2166 (list store-temp) 2166 (list store-temp)
2167 `(let ((,(car (nth 2 method)) 2167 `(let ((,(car (nth 2 method))
2168 (cl-set-getf ,(nth 4 method) ,tag-temp ,store-temp))) 2168 (cl--set-getf ,(nth 4 method) ,tag-temp ,store-temp)))
2169 ,(nth 3 method) ,store-temp) 2169 ,(nth 3 method) ,store-temp)
2170 `(cl-getf ,(nth 4 method) ,tag-temp ,def-temp)))) 2170 `(cl-getf ,(nth 4 method) ,tag-temp ,def-temp))))
2171 2171
@@ -2178,8 +2178,8 @@ Example:
2178 (append (nth 1 method) (list from to)) 2178 (append (nth 1 method) (list from to))
2179 (list store-temp) 2179 (list store-temp)
2180 `(let ((,(car (nth 2 method)) 2180 `(let ((,(car (nth 2 method))
2181 (cl-set-substring ,(nth 4 method) 2181 (cl--set-substring ,(nth 4 method)
2182 ,from-temp ,to-temp ,store-temp))) 2182 ,from-temp ,to-temp ,store-temp)))
2183 ,(nth 3 method) ,store-temp) 2183 ,(nth 3 method) ,store-temp)
2184 `(substring ,(nth 4 method) ,from-temp ,to-temp)))) 2184 `(substring ,(nth 4 method) ,from-temp ,to-temp))))
2185 2185
@@ -2325,7 +2325,7 @@ The form returns true if TAG was found and removed, nil otherwise."
2325 (if (eq ,ttag (car ,tval)) 2325 (if (eq ,ttag (car ,tval))
2326 (progn ,(cl-setf-do-store (nth 1 method) `(cddr ,tval)) 2326 (progn ,(cl-setf-do-store (nth 1 method) `(cddr ,tval))
2327 t) 2327 t)
2328 `(cl-do-remf ,tval ,ttag))))) 2328 `(cl--do-remf ,tval ,ttag)))))
2329 2329
2330;;;###autoload 2330;;;###autoload
2331(defmacro cl-shiftf (place &rest args) 2331(defmacro cl-shiftf (place &rest args)
@@ -2549,7 +2549,7 @@ value, that slot cannot be set via `cl-setf'.
2549 (copier (intern (format "copy-%s" name))) 2549 (copier (intern (format "copy-%s" name)))
2550 (predicate (intern (format "%s-p" name))) 2550 (predicate (intern (format "%s-p" name)))
2551 (print-func nil) (print-auto nil) 2551 (print-func nil) (print-auto nil)
2552 (safety (if (cl-compiling-file) cl-optimize-safety 3)) 2552 (safety (if (cl--compiling-file) cl-optimize-safety 3))
2553 (include nil) 2553 (include nil)
2554 (tag (intern (format "cl-struct-%s" name))) 2554 (tag (intern (format "cl-struct-%s" name)))
2555 (tag-symbol (intern (format "cl-struct-%s-tags" name))) 2555 (tag-symbol (intern (format "cl-struct-%s-tags" name)))
@@ -2835,7 +2835,7 @@ TYPE is a Common Lisp-style type specifier."
2835 "Verify that FORM is of type TYPE; signal an error if not. 2835 "Verify that FORM is of type TYPE; signal an error if not.
2836STRING is an optional description of the desired type." 2836STRING is an optional description of the desired type."
2837 (declare (debug (place cl-type-spec &optional stringp))) 2837 (declare (debug (place cl-type-spec &optional stringp)))
2838 (and (or (not (cl-compiling-file)) 2838 (and (or (not (cl--compiling-file))
2839 (< cl-optimize-speed 3) (= cl-optimize-safety 3)) 2839 (< cl-optimize-speed 3) (= cl-optimize-safety 3))
2840 (let* ((temp (if (cl--simple-expr-p form 3) 2840 (let* ((temp (if (cl--simple-expr-p form 3)
2841 form (make-symbol "--cl-var--"))) 2841 form (make-symbol "--cl-var--")))
@@ -2854,7 +2854,7 @@ Other args STRING and ARGS... are arguments to be passed to `error'.
2854They are not evaluated unless the assertion fails. If STRING is 2854They are not evaluated unless the assertion fails. If STRING is
2855omitted, a default message listing FORM itself is used." 2855omitted, a default message listing FORM itself is used."
2856 (declare (debug (form &rest form))) 2856 (declare (debug (form &rest form)))
2857 (and (or (not (cl-compiling-file)) 2857 (and (or (not (cl--compiling-file))
2858 (< cl-optimize-speed 3) (= cl-optimize-safety 3)) 2858 (< cl-optimize-speed 3) (= cl-optimize-safety 3))
2859 (let ((sargs (and show-args 2859 (let ((sargs (and show-args
2860 (delq nil (mapcar (lambda (x) 2860 (delq nil (mapcar (lambda (x)
@@ -2919,7 +2919,7 @@ and then returning foo."
2919 2919
2920(defvar cl--active-block-names nil) 2920(defvar cl--active-block-names nil)
2921 2921
2922(cl-define-compiler-macro cl-block-wrapper (cl-form) 2922(cl-define-compiler-macro cl--block-wrapper (cl-form)
2923 (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil)) 2923 (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil))
2924 (cl--active-block-names (cons cl-entry cl--active-block-names)) 2924 (cl--active-block-names (cons cl-entry cl--active-block-names))
2925 (cl-body (macroexpand-all ;Performs compiler-macro expansions. 2925 (cl-body (macroexpand-all ;Performs compiler-macro expansions.
@@ -2931,7 +2931,7 @@ and then returning foo."
2931 `(catch ,(nth 1 cl-form) ,@(cdr cl-body)) 2931 `(catch ,(nth 1 cl-form) ,@(cdr cl-body))
2932 cl-body))) 2932 cl-body)))
2933 2933
2934(cl-define-compiler-macro cl-block-throw (cl-tag cl-value) 2934(cl-define-compiler-macro cl--block-throw (cl-tag cl-value)
2935 (let ((cl-found (assq (nth 1 cl-tag) cl--active-block-names))) 2935 (let ((cl-found (assq (nth 1 cl-tag) cl--active-block-names)))
2936 (if cl-found (setcdr cl-found t))) 2936 (if cl-found (setcdr cl-found t)))
2937 `(throw ,cl-tag ,cl-value)) 2937 `(throw ,cl-tag ,cl-value))
@@ -2955,7 +2955,7 @@ surrounded by (cl-block NAME ...).
2955 ,(if (memq '&key args) 2955 ,(if (memq '&key args)
2956 `(&whole cl-whole &cl-quote ,@args) 2956 `(&whole cl-whole &cl-quote ,@args)
2957 (cons '&cl-quote args)) 2957 (cons '&cl-quote args))
2958 (cl-defsubst-expand 2958 (cl--defsubst-expand
2959 ',argns '(cl-block ,name ,@body) 2959 ',argns '(cl-block ,name ,@body)
2960 ;; We used to pass `simple' as 2960 ;; We used to pass `simple' as
2961 ;; (not (or unsafe (cl-expr-access-order pbody argns))) 2961 ;; (not (or unsafe (cl-expr-access-order pbody argns)))
@@ -2966,7 +2966,7 @@ surrounded by (cl-block NAME ...).
2966 ,(and (memq '&key args) 'cl-whole) ,unsafe ,@argns))) 2966 ,(and (memq '&key args) 'cl-whole) ,unsafe ,@argns)))
2967 (cl-defun ,name ,args ,@body)))) 2967 (cl-defun ,name ,args ,@body))))
2968 2968
2969(defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs) 2969(defun cl--defsubst-expand (argns body simple whole unsafe &rest argvs)
2970 (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole 2970 (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole
2971 (if (cl--simple-exprs-p argvs) (setq simple t)) 2971 (if (cl--simple-exprs-p argvs) (setq simple t))
2972 (let* ((substs ()) 2972 (let* ((substs ())
@@ -3059,7 +3059,7 @@ surrounded by (cl-block NAME ...).
3059 3059
3060;;; Things that are inline. 3060;;; Things that are inline.
3061(cl-proclaim '(inline cl-floatp-safe cl-acons cl-map cl-concatenate cl-notany cl-notevery 3061(cl-proclaim '(inline cl-floatp-safe cl-acons cl-map cl-concatenate cl-notany cl-notevery
3062 cl-set-elt cl-revappend cl-nreconc gethash)) 3062 cl--set-elt cl-revappend cl-nreconc gethash))
3063 3063
3064;;; Things that are side-effect-free. 3064;;; Things that are side-effect-free.
3065(mapc (lambda (x) (put x 'side-effect-free t)) 3065(mapc (lambda (x) (put x 'side-effect-free t))
diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el
index cb167ad2881..b55f1df5ba5 100644
--- a/lisp/emacs-lisp/cl-seq.el
+++ b/lisp/emacs-lisp/cl-seq.el
@@ -1,4 +1,4 @@
1;;; cl-seq.el --- Common Lisp features, part 3 1;;; cl-seq.el --- Common Lisp features, part 3 -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc. 3;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc.
4 4
@@ -43,99 +43,91 @@
43 43
44(require 'cl-lib) 44(require 'cl-lib)
45 45
46;;; Keyword parsing. This is special-cased here so that we can compile 46;; Keyword parsing.
47;;; this file independent from cl-macs. 47;; This is special-cased here so that we can compile
48;; this file independent from cl-macs.
48 49
49(defmacro cl-parsing-keywords (kwords other-keys &rest body) 50(defmacro cl--parsing-keywords (kwords other-keys &rest body)
50 (declare (indent 2) (debug (sexp sexp &rest form))) 51 (declare (indent 2) (debug (sexp sexp &rest form)))
51 (cons 52 `(let* ,(mapcar
52 'let* 53 (lambda (x)
53 (cons (mapcar 54 (let* ((var (if (consp x) (car x) x))
54 (function 55 (mem `(car (cdr (memq ',var cl-keys)))))
55 (lambda (x) 56 (if (eq var :test-not)
56 (let* ((var (if (consp x) (car x) x)) 57 (setq mem `(and ,mem (setq cl-test ,mem) t)))
57 (mem (list 'car (list 'cdr (list 'memq (list 'quote var) 58 (if (eq var :if-not)
58 'cl-keys))))) 59 (setq mem `(and ,mem (setq cl-if ,mem) t)))
59 (if (eq var :test-not) 60 (list (intern
60 (setq mem (list 'and mem (list 'setq 'cl-test mem) t))) 61 (format "cl-%s" (substring (symbol-name var) 1)))
61 (if (eq var :if-not) 62 (if (consp x) `(or ,mem ,(car (cdr x))) mem))))
62 (setq mem (list 'and mem (list 'setq 'cl-if mem) t))) 63 kwords)
63 (list (intern 64 ,@(append
64 (format "cl-%s" (substring (symbol-name var) 1))) 65 (and (not (eq other-keys t))
65 (if (consp x) (list 'or mem (car (cdr x))) mem))))) 66 (list
66 kwords) 67 (list 'let '((cl-keys-temp cl-keys))
67 (append 68 (list 'while 'cl-keys-temp
68 (and (not (eq other-keys t)) 69 (list 'or (list 'memq '(car cl-keys-temp)
69 (list 70 (list 'quote
70 (list 'let '((cl-keys-temp cl-keys)) 71 (mapcar
71 (list 'while 'cl-keys-temp 72 (function
72 (list 'or (list 'memq '(car cl-keys-temp) 73 (lambda (x)
73 (list 'quote 74 (if (consp x)
74 (mapcar 75 (car x) x)))
75 (function 76 (append kwords
76 (lambda (x) 77 other-keys))))
77 (if (consp x) 78 '(car (cdr (memq (quote :allow-other-keys)
78 (car x) x))) 79 cl-keys)))
79 (append kwords 80 '(error "Bad keyword argument %s"
80 other-keys)))) 81 (car cl-keys-temp)))
81 '(car (cdr (memq (quote :allow-other-keys) 82 '(setq cl-keys-temp (cdr (cdr cl-keys-temp)))))))
82 cl-keys))) 83 body)))
83 '(error "Bad keyword argument %s" 84
84 (car cl-keys-temp))) 85(defmacro cl--check-key (x) ;Expects `cl-key' in context of generated code.
85 '(setq cl-keys-temp (cdr (cdr cl-keys-temp)))))))
86 body))))
87
88(defmacro cl-check-key (x)
89 (declare (debug edebug-forms)) 86 (declare (debug edebug-forms))
90 (list 'if 'cl-key (list 'funcall 'cl-key x) x)) 87 `(if cl-key (funcall cl-key ,x) ,x))
91 88
92(defmacro cl-check-test-nokey (item x) 89(defmacro cl--check-test-nokey (item x) ;cl-test cl-if cl-test-not cl-if-not.
93 (declare (debug edebug-forms)) 90 (declare (debug edebug-forms))
94 (list 'cond 91 `(cond
95 (list 'cl-test 92 (cl-test (eq (not (funcall cl-test ,item ,x))
96 (list 'eq (list 'not (list 'funcall 'cl-test item x)) 93 cl-test-not))
97 'cl-test-not)) 94 (cl-if (eq (not (funcall cl-if ,x)) cl-if-not))
98 (list 'cl-if 95 (t (eql ,item ,x))))
99 (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not)) 96
100 (list 't (list 'if (list 'numberp item) 97(defmacro cl--check-test (item x) ;all of the above.
101 (list 'equal item x) (list 'eq item x)))))
102
103(defmacro cl-check-test (item x)
104 (declare (debug edebug-forms)) 98 (declare (debug edebug-forms))
105 (list 'cl-check-test-nokey item (list 'cl-check-key x))) 99 `(cl--check-test-nokey ,item (cl--check-key ,x)))
106 100
107(defmacro cl-check-match (x y) 101(defmacro cl--check-match (x y) ;cl-key cl-test cl-test-not
108 (declare (debug edebug-forms)) 102 (declare (debug edebug-forms))
109 (setq x (list 'cl-check-key x) y (list 'cl-check-key y)) 103 (setq x `(cl--check-key ,x) y `(cl--check-key ,y))
110 (list 'if 'cl-test 104 `(if cl-test
111 (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not) 105 (eq (not (funcall cl-test ,x ,y)) cl-test-not)
112 (list 'if (list 'numberp x) 106 (eql ,x ,y)))
113 (list 'equal x y) (list 'eq x y))))
114 107
115(defvar cl-test) (defvar cl-test-not) 108(defvar cl-test) (defvar cl-test-not)
116(defvar cl-if) (defvar cl-if-not) 109(defvar cl-if) (defvar cl-if-not)
117(defvar cl-key) 110(defvar cl-key)
118 111
119
120;;;###autoload 112;;;###autoload
121(defun cl-reduce (cl-func cl-seq &rest cl-keys) 113(defun cl-reduce (cl-func cl-seq &rest cl-keys)
122 "Reduce two-argument FUNCTION across SEQ. 114 "Reduce two-argument FUNCTION across SEQ.
123\nKeywords supported: :start :end :from-end :initial-value :key 115\nKeywords supported: :start :end :from-end :initial-value :key
124\n(fn FUNCTION SEQ [KEYWORD VALUE]...)" 116\n(fn FUNCTION SEQ [KEYWORD VALUE]...)"
125 (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) () 117 (cl--parsing-keywords (:from-end (:start 0) :end :initial-value :key) ()
126 (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) 118 (or (listp cl-seq) (setq cl-seq (append cl-seq nil)))
127 (setq cl-seq (cl-subseq cl-seq cl-start cl-end)) 119 (setq cl-seq (cl-subseq cl-seq cl-start cl-end))
128 (if cl-from-end (setq cl-seq (nreverse cl-seq))) 120 (if cl-from-end (setq cl-seq (nreverse cl-seq)))
129 (let ((cl-accum (cond ((memq :initial-value cl-keys) cl-initial-value) 121 (let ((cl-accum (cond ((memq :initial-value cl-keys) cl-initial-value)
130 (cl-seq (cl-check-key (pop cl-seq))) 122 (cl-seq (cl--check-key (pop cl-seq)))
131 (t (funcall cl-func))))) 123 (t (funcall cl-func)))))
132 (if cl-from-end 124 (if cl-from-end
133 (while cl-seq 125 (while cl-seq
134 (setq cl-accum (funcall cl-func (cl-check-key (pop cl-seq)) 126 (setq cl-accum (funcall cl-func (cl--check-key (pop cl-seq))
135 cl-accum))) 127 cl-accum)))
136 (while cl-seq 128 (while cl-seq
137 (setq cl-accum (funcall cl-func cl-accum 129 (setq cl-accum (funcall cl-func cl-accum
138 (cl-check-key (pop cl-seq)))))) 130 (cl--check-key (pop cl-seq))))))
139 cl-accum))) 131 cl-accum)))
140 132
141;;;###autoload 133;;;###autoload
@@ -143,7 +135,7 @@
143 "Fill the elements of SEQ with ITEM. 135 "Fill the elements of SEQ with ITEM.
144\nKeywords supported: :start :end 136\nKeywords supported: :start :end
145\n(fn SEQ ITEM [KEYWORD VALUE]...)" 137\n(fn SEQ ITEM [KEYWORD VALUE]...)"
146 (cl-parsing-keywords ((:start 0) :end) () 138 (cl--parsing-keywords ((:start 0) :end) ()
147 (if (listp seq) 139 (if (listp seq)
148 (let ((p (nthcdr cl-start seq)) 140 (let ((p (nthcdr cl-start seq))
149 (n (if cl-end (- cl-end cl-start) 8000000))) 141 (n (if cl-end (- cl-end cl-start) 8000000)))
@@ -164,14 +156,14 @@
164SEQ1 is destructively modified, then returned. 156SEQ1 is destructively modified, then returned.
165\nKeywords supported: :start1 :end1 :start2 :end2 157\nKeywords supported: :start1 :end1 :start2 :end2
166\n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" 158\n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)"
167 (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) () 159 (cl--parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) ()
168 (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1)) 160 (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1))
169 (or (= cl-start1 cl-start2) 161 (or (= cl-start1 cl-start2)
170 (let* ((cl-len (length cl-seq1)) 162 (let* ((cl-len (length cl-seq1))
171 (cl-n (min (- (or cl-end1 cl-len) cl-start1) 163 (cl-n (min (- (or cl-end1 cl-len) cl-start1)
172 (- (or cl-end2 cl-len) cl-start2)))) 164 (- (or cl-end2 cl-len) cl-start2))))
173 (while (>= (setq cl-n (1- cl-n)) 0) 165 (while (>= (setq cl-n (1- cl-n)) 0)
174 (cl-set-elt cl-seq1 (+ cl-start1 cl-n) 166 (cl--set-elt cl-seq1 (+ cl-start1 cl-n)
175 (elt cl-seq2 (+ cl-start2 cl-n)))))) 167 (elt cl-seq2 (+ cl-start2 cl-n))))))
176 (if (listp cl-seq1) 168 (if (listp cl-seq1)
177 (let ((cl-p1 (nthcdr cl-start1 cl-seq1)) 169 (let ((cl-p1 (nthcdr cl-start1 cl-seq1))
@@ -208,7 +200,7 @@ This is a non-destructive function; it makes a copy of SEQ if necessary
208to avoid corrupting the original SEQ. 200to avoid corrupting the original SEQ.
209\nKeywords supported: :test :test-not :key :count :start :end :from-end 201\nKeywords supported: :test :test-not :key :count :start :end :from-end
210\n(fn ITEM SEQ [KEYWORD VALUE]...)" 202\n(fn ITEM SEQ [KEYWORD VALUE]...)"
211 (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end 203 (cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end
212 (:start 0) :end) () 204 (:start 0) :end) ()
213 (if (<= (or cl-count (setq cl-count 8000000)) 0) 205 (if (<= (or cl-count (setq cl-count 8000000)) 0)
214 cl-seq 206 cl-seq
@@ -227,14 +219,14 @@ to avoid corrupting the original SEQ.
227 (setq cl-end (- (or cl-end 8000000) cl-start)) 219 (setq cl-end (- (or cl-end 8000000) cl-start))
228 (if (= cl-start 0) 220 (if (= cl-start 0)
229 (while (and cl-seq (> cl-end 0) 221 (while (and cl-seq (> cl-end 0)
230 (cl-check-test cl-item (car cl-seq)) 222 (cl--check-test cl-item (car cl-seq))
231 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) 223 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
232 (> (setq cl-count (1- cl-count)) 0)))) 224 (> (setq cl-count (1- cl-count)) 0))))
233 (if (and (> cl-count 0) (> cl-end 0)) 225 (if (and (> cl-count 0) (> cl-end 0))
234 (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq) 226 (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq)
235 (setq cl-end (1- cl-end)) (cdr cl-seq)))) 227 (setq cl-end (1- cl-end)) (cdr cl-seq))))
236 (while (and cl-p (> cl-end 0) 228 (while (and cl-p (> cl-end 0)
237 (not (cl-check-test cl-item (car cl-p)))) 229 (not (cl--check-test cl-item (car cl-p))))
238 (setq cl-p (cdr cl-p) cl-end (1- cl-end))) 230 (setq cl-p (cdr cl-p) cl-end (1- cl-end)))
239 (if (and cl-p (> cl-end 0)) 231 (if (and cl-p (> cl-end 0))
240 (nconc (cl-ldiff cl-seq cl-p) 232 (nconc (cl-ldiff cl-seq cl-p)
@@ -271,7 +263,7 @@ to avoid corrupting the original SEQ.
271This is a destructive function; it reuses the storage of SEQ whenever possible. 263This is a destructive function; it reuses the storage of SEQ whenever possible.
272\nKeywords supported: :test :test-not :key :count :start :end :from-end 264\nKeywords supported: :test :test-not :key :count :start :end :from-end
273\n(fn ITEM SEQ [KEYWORD VALUE]...)" 265\n(fn ITEM SEQ [KEYWORD VALUE]...)"
274 (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end 266 (cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end
275 (:start 0) :end) () 267 (:start 0) :end) ()
276 (if (<= (or cl-count (setq cl-count 8000000)) 0) 268 (if (<= (or cl-count (setq cl-count 8000000)) 0)
277 cl-seq 269 cl-seq
@@ -291,7 +283,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
291 (progn 283 (progn
292 (while (and cl-seq 284 (while (and cl-seq
293 (> cl-end 0) 285 (> cl-end 0)
294 (cl-check-test cl-item (car cl-seq)) 286 (cl--check-test cl-item (car cl-seq))
295 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) 287 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
296 (> (setq cl-count (1- cl-count)) 0))) 288 (> (setq cl-count (1- cl-count)) 0)))
297 (setq cl-end (1- cl-end))) 289 (setq cl-end (1- cl-end)))
@@ -299,7 +291,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
299 (if (and (> cl-count 0) (> cl-end 0)) 291 (if (and (> cl-count 0) (> cl-end 0))
300 (let ((cl-p (nthcdr cl-start cl-seq))) 292 (let ((cl-p (nthcdr cl-start cl-seq)))
301 (while (and (cdr cl-p) (> cl-end 0)) 293 (while (and (cdr cl-p) (> cl-end 0))
302 (if (cl-check-test cl-item (car (cdr cl-p))) 294 (if (cl--check-test cl-item (car (cdr cl-p)))
303 (progn 295 (progn
304 (setcdr cl-p (cdr (cdr cl-p))) 296 (setcdr cl-p (cdr (cdr cl-p)))
305 (if (= (setq cl-count (1- cl-count)) 0) 297 (if (= (setq cl-count (1- cl-count)) 0)
@@ -341,14 +333,14 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
341 333
342(defun cl--delete-duplicates (cl-seq cl-keys cl-copy) 334(defun cl--delete-duplicates (cl-seq cl-keys cl-copy)
343 (if (listp cl-seq) 335 (if (listp cl-seq)
344 (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) 336 (cl--parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if)
345 () 337 ()
346 (if cl-from-end 338 (if cl-from-end
347 (let ((cl-p (nthcdr cl-start cl-seq)) cl-i) 339 (let ((cl-p (nthcdr cl-start cl-seq)) cl-i)
348 (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) 340 (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
349 (while (> cl-end 1) 341 (while (> cl-end 1)
350 (setq cl-i 0) 342 (setq cl-i 0)
351 (while (setq cl-i (cl--position (cl-check-key (car cl-p)) 343 (while (setq cl-i (cl--position (cl--check-key (car cl-p))
352 (cdr cl-p) cl-i (1- cl-end))) 344 (cdr cl-p) cl-i (1- cl-end)))
353 (if cl-copy (setq cl-seq (copy-sequence cl-seq) 345 (if cl-copy (setq cl-seq (copy-sequence cl-seq)
354 cl-p (nthcdr cl-start cl-seq) cl-copy nil)) 346 cl-p (nthcdr cl-start cl-seq) cl-copy nil))
@@ -360,13 +352,13 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
360 cl-seq) 352 cl-seq)
361 (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) 353 (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
362 (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1) 354 (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1)
363 (cl--position (cl-check-key (car cl-seq)) 355 (cl--position (cl--check-key (car cl-seq))
364 (cdr cl-seq) 0 (1- cl-end))) 356 (cdr cl-seq) 0 (1- cl-end)))
365 (setq cl-seq (cdr cl-seq) cl-end (1- cl-end))) 357 (setq cl-seq (cdr cl-seq) cl-end (1- cl-end)))
366 (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq) 358 (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq)
367 (setq cl-end (1- cl-end) cl-start 1) cl-seq))) 359 (setq cl-end (1- cl-end) cl-start 1) cl-seq)))
368 (while (and (cdr (cdr cl-p)) (> cl-end 1)) 360 (while (and (cdr (cdr cl-p)) (> cl-end 1))
369 (if (cl--position (cl-check-key (car (cdr cl-p))) 361 (if (cl--position (cl--check-key (car (cdr cl-p)))
370 (cdr (cdr cl-p)) 0 (1- cl-end)) 362 (cdr (cdr cl-p)) 0 (1- cl-end))
371 (progn 363 (progn
372 (if cl-copy (setq cl-seq (copy-sequence cl-seq) 364 (if cl-copy (setq cl-seq (copy-sequence cl-seq)
@@ -386,7 +378,7 @@ This is a non-destructive function; it makes a copy of SEQ if necessary
386to avoid corrupting the original SEQ. 378to avoid corrupting the original SEQ.
387\nKeywords supported: :test :test-not :key :count :start :end :from-end 379\nKeywords supported: :test :test-not :key :count :start :end :from-end
388\n(fn NEW OLD SEQ [KEYWORD VALUE]...)" 380\n(fn NEW OLD SEQ [KEYWORD VALUE]...)"
389 (cl-parsing-keywords (:test :test-not :key :if :if-not :count 381 (cl--parsing-keywords (:test :test-not :key :if :if-not :count
390 (:start 0) :end :from-end) () 382 (:start 0) :end :from-end) ()
391 (if (or (eq cl-old cl-new) 383 (if (or (eq cl-old cl-new)
392 (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0)) 384 (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0))
@@ -396,7 +388,7 @@ to avoid corrupting the original SEQ.
396 cl-seq 388 cl-seq
397 (setq cl-seq (copy-sequence cl-seq)) 389 (setq cl-seq (copy-sequence cl-seq))
398 (or cl-from-end 390 (or cl-from-end
399 (progn (cl-set-elt cl-seq cl-i cl-new) 391 (progn (cl--set-elt cl-seq cl-i cl-new)
400 (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) 392 (setq cl-i (1+ cl-i) cl-count (1- cl-count))))
401 (apply 'cl-nsubstitute cl-new cl-old cl-seq :count cl-count 393 (apply 'cl-nsubstitute cl-new cl-old cl-seq :count cl-count
402 :start cl-i cl-keys)))))) 394 :start cl-i cl-keys))))))
@@ -425,14 +417,14 @@ to avoid corrupting the original SEQ.
425This is a destructive function; it reuses the storage of SEQ whenever possible. 417This is a destructive function; it reuses the storage of SEQ whenever possible.
426\nKeywords supported: :test :test-not :key :count :start :end :from-end 418\nKeywords supported: :test :test-not :key :count :start :end :from-end
427\n(fn NEW OLD SEQ [KEYWORD VALUE]...)" 419\n(fn NEW OLD SEQ [KEYWORD VALUE]...)"
428 (cl-parsing-keywords (:test :test-not :key :if :if-not :count 420 (cl--parsing-keywords (:test :test-not :key :if :if-not :count
429 (:start 0) :end :from-end) () 421 (:start 0) :end :from-end) ()
430 (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0) 422 (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0)
431 (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000))) 423 (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000)))
432 (let ((cl-p (nthcdr cl-start cl-seq))) 424 (let ((cl-p (nthcdr cl-start cl-seq)))
433 (setq cl-end (- (or cl-end 8000000) cl-start)) 425 (setq cl-end (- (or cl-end 8000000) cl-start))
434 (while (and cl-p (> cl-end 0) (> cl-count 0)) 426 (while (and cl-p (> cl-end 0) (> cl-count 0))
435 (if (cl-check-test cl-old (car cl-p)) 427 (if (cl--check-test cl-old (car cl-p))
436 (progn 428 (progn
437 (setcar cl-p cl-new) 429 (setcar cl-p cl-new)
438 (setq cl-count (1- cl-count)))) 430 (setq cl-count (1- cl-count))))
@@ -441,12 +433,12 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
441 (if cl-from-end 433 (if cl-from-end
442 (while (and (< cl-start cl-end) (> cl-count 0)) 434 (while (and (< cl-start cl-end) (> cl-count 0))
443 (setq cl-end (1- cl-end)) 435 (setq cl-end (1- cl-end))
444 (if (cl-check-test cl-old (elt cl-seq cl-end)) 436 (if (cl--check-test cl-old (elt cl-seq cl-end))
445 (progn 437 (progn
446 (cl-set-elt cl-seq cl-end cl-new) 438 (cl--set-elt cl-seq cl-end cl-new)
447 (setq cl-count (1- cl-count))))) 439 (setq cl-count (1- cl-count)))))
448 (while (and (< cl-start cl-end) (> cl-count 0)) 440 (while (and (< cl-start cl-end) (> cl-count 0))
449 (if (cl-check-test cl-old (aref cl-seq cl-start)) 441 (if (cl--check-test cl-old (aref cl-seq cl-start))
450 (progn 442 (progn
451 (aset cl-seq cl-start cl-new) 443 (aset cl-seq cl-start cl-new)
452 (setq cl-count (1- cl-count)))) 444 (setq cl-count (1- cl-count))))
@@ -500,7 +492,7 @@ Return the matching item, or nil if not found.
500Return the index of the matching item, or nil if not found. 492Return the index of the matching item, or nil if not found.
501\nKeywords supported: :test :test-not :key :start :end :from-end 493\nKeywords supported: :test :test-not :key :start :end :from-end
502\n(fn ITEM SEQ [KEYWORD VALUE]...)" 494\n(fn ITEM SEQ [KEYWORD VALUE]...)"
503 (cl-parsing-keywords (:test :test-not :key :if :if-not 495 (cl--parsing-keywords (:test :test-not :key :if :if-not
504 (:start 0) :end :from-end) () 496 (:start 0) :end :from-end) ()
505 (cl--position cl-item cl-seq cl-start cl-end cl-from-end))) 497 (cl--position cl-item cl-seq cl-start cl-end cl-from-end)))
506 498
@@ -510,7 +502,7 @@ Return the index of the matching item, or nil if not found.
510 (or cl-end (setq cl-end 8000000)) 502 (or cl-end (setq cl-end 8000000))
511 (let ((cl-res nil)) 503 (let ((cl-res nil))
512 (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end)) 504 (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end))
513 (if (cl-check-test cl-item (car cl-p)) 505 (if (cl--check-test cl-item (car cl-p))
514 (setq cl-res cl-start)) 506 (setq cl-res cl-start))
515 (setq cl-p (cdr cl-p) cl-start (1+ cl-start))) 507 (setq cl-p (cdr cl-p) cl-start (1+ cl-start)))
516 cl-res)) 508 cl-res))
@@ -518,10 +510,10 @@ Return the index of the matching item, or nil if not found.
518 (if cl-from-end 510 (if cl-from-end
519 (progn 511 (progn
520 (while (and (>= (setq cl-end (1- cl-end)) cl-start) 512 (while (and (>= (setq cl-end (1- cl-end)) cl-start)
521 (not (cl-check-test cl-item (aref cl-seq cl-end))))) 513 (not (cl--check-test cl-item (aref cl-seq cl-end)))))
522 (and (>= cl-end cl-start) cl-end)) 514 (and (>= cl-end cl-start) cl-end))
523 (while (and (< cl-start cl-end) 515 (while (and (< cl-start cl-end)
524 (not (cl-check-test cl-item (aref cl-seq cl-start)))) 516 (not (cl--check-test cl-item (aref cl-seq cl-start))))
525 (setq cl-start (1+ cl-start))) 517 (setq cl-start (1+ cl-start)))
526 (and (< cl-start cl-end) cl-start)))) 518 (and (< cl-start cl-end) cl-start))))
527 519
@@ -546,13 +538,13 @@ Return the index of the matching item, or nil if not found.
546 "Count the number of occurrences of ITEM in SEQ. 538 "Count the number of occurrences of ITEM in SEQ.
547\nKeywords supported: :test :test-not :key :start :end 539\nKeywords supported: :test :test-not :key :start :end
548\n(fn ITEM SEQ [KEYWORD VALUE]...)" 540\n(fn ITEM SEQ [KEYWORD VALUE]...)"
549 (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) () 541 (cl--parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) ()
550 (let ((cl-count 0) cl-x) 542 (let ((cl-count 0) cl-x)
551 (or cl-end (setq cl-end (length cl-seq))) 543 (or cl-end (setq cl-end (length cl-seq)))
552 (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq))) 544 (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq)))
553 (while (< cl-start cl-end) 545 (while (< cl-start cl-end)
554 (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start))) 546 (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start)))
555 (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count))) 547 (if (cl--check-test cl-item cl-x) (setq cl-count (1+ cl-count)))
556 (setq cl-start (1+ cl-start))) 548 (setq cl-start (1+ cl-start)))
557 cl-count))) 549 cl-count)))
558 550
@@ -577,14 +569,14 @@ Return nil if the sequences match. If one sequence is a prefix of the
577other, the return value indicates the end of the shorter sequence. 569other, the return value indicates the end of the shorter sequence.
578\nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end 570\nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
579\n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" 571\n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)"
580 (cl-parsing-keywords (:test :test-not :key :from-end 572 (cl--parsing-keywords (:test :test-not :key :from-end
581 (:start1 0) :end1 (:start2 0) :end2) () 573 (:start1 0) :end1 (:start2 0) :end2) ()
582 (or cl-end1 (setq cl-end1 (length cl-seq1))) 574 (or cl-end1 (setq cl-end1 (length cl-seq1)))
583 (or cl-end2 (setq cl-end2 (length cl-seq2))) 575 (or cl-end2 (setq cl-end2 (length cl-seq2)))
584 (if cl-from-end 576 (if cl-from-end
585 (progn 577 (progn
586 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) 578 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
587 (cl-check-match (elt cl-seq1 (1- cl-end1)) 579 (cl--check-match (elt cl-seq1 (1- cl-end1))
588 (elt cl-seq2 (1- cl-end2)))) 580 (elt cl-seq2 (1- cl-end2))))
589 (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2))) 581 (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2)))
590 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) 582 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
@@ -592,7 +584,7 @@ other, the return value indicates the end of the shorter sequence.
592 (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1))) 584 (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
593 (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2)))) 585 (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
594 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) 586 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
595 (cl-check-match (if cl-p1 (car cl-p1) 587 (cl--check-match (if cl-p1 (car cl-p1)
596 (aref cl-seq1 cl-start1)) 588 (aref cl-seq1 cl-start1))
597 (if cl-p2 (car cl-p2) 589 (if cl-p2 (car cl-p2)
598 (aref cl-seq2 cl-start2)))) 590 (aref cl-seq2 cl-start2))))
@@ -608,14 +600,14 @@ Return the index of the leftmost element of the first match found;
608return nil if there are no matches. 600return nil if there are no matches.
609\nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end 601\nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
610\n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" 602\n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)"
611 (cl-parsing-keywords (:test :test-not :key :from-end 603 (cl--parsing-keywords (:test :test-not :key :from-end
612 (:start1 0) :end1 (:start2 0) :end2) () 604 (:start1 0) :end1 (:start2 0) :end2) ()
613 (or cl-end1 (setq cl-end1 (length cl-seq1))) 605 (or cl-end1 (setq cl-end1 (length cl-seq1)))
614 (or cl-end2 (setq cl-end2 (length cl-seq2))) 606 (or cl-end2 (setq cl-end2 (length cl-seq2)))
615 (if (>= cl-start1 cl-end1) 607 (if (>= cl-start1 cl-end1)
616 (if cl-from-end cl-end2 cl-start2) 608 (if cl-from-end cl-end2 cl-start2)
617 (let* ((cl-len (- cl-end1 cl-start1)) 609 (let* ((cl-len (- cl-end1 cl-start1))
618 (cl-first (cl-check-key (elt cl-seq1 cl-start1))) 610 (cl-first (cl--check-key (elt cl-seq1 cl-start1)))
619 (cl-if nil) cl-pos) 611 (cl-if nil) cl-pos)
620 (setq cl-end2 (- cl-end2 (1- cl-len))) 612 (setq cl-end2 (- cl-end2 (1- cl-len)))
621 (while (and (< cl-start2 cl-end2) 613 (while (and (< cl-start2 cl-end2)
@@ -636,7 +628,7 @@ This is a destructive function; it reuses the storage of SEQ if possible.
636\n(fn SEQ PREDICATE [KEYWORD VALUE]...)" 628\n(fn SEQ PREDICATE [KEYWORD VALUE]...)"
637 (if (nlistp cl-seq) 629 (if (nlistp cl-seq)
638 (cl-replace cl-seq (apply 'cl-sort (append cl-seq nil) cl-pred cl-keys)) 630 (cl-replace cl-seq (apply 'cl-sort (append cl-seq nil) cl-pred cl-keys))
639 (cl-parsing-keywords (:key) () 631 (cl--parsing-keywords (:key) ()
640 (if (memq cl-key '(nil identity)) 632 (if (memq cl-key '(nil identity))
641 (sort cl-seq cl-pred) 633 (sort cl-seq cl-pred)
642 (sort cl-seq (function (lambda (cl-x cl-y) 634 (sort cl-seq (function (lambda (cl-x cl-y)
@@ -660,16 +652,15 @@ sequences, and PREDICATE is a `less-than' predicate on the elements.
660\n(fn TYPE SEQ1 SEQ2 PREDICATE [KEYWORD VALUE]...)" 652\n(fn TYPE SEQ1 SEQ2 PREDICATE [KEYWORD VALUE]...)"
661 (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil))) 653 (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil)))
662 (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil))) 654 (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil)))
663 (cl-parsing-keywords (:key) () 655 (cl--parsing-keywords (:key) ()
664 (let ((cl-res nil)) 656 (let ((cl-res nil))
665 (while (and cl-seq1 cl-seq2) 657 (while (and cl-seq1 cl-seq2)
666 (if (funcall cl-pred (cl-check-key (car cl-seq2)) 658 (if (funcall cl-pred (cl--check-key (car cl-seq2))
667 (cl-check-key (car cl-seq1))) 659 (cl--check-key (car cl-seq1)))
668 (push (pop cl-seq2) cl-res) 660 (push (pop cl-seq2) cl-res)
669 (push (pop cl-seq1) cl-res))) 661 (push (pop cl-seq1) cl-res)))
670 (cl-coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) 662 (cl-coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type))))
671 663
672;;; See compiler macro in cl-macs.el
673;;;###autoload 664;;;###autoload
674(defun cl-member (cl-item cl-list &rest cl-keys) 665(defun cl-member (cl-item cl-list &rest cl-keys)
675 "Find the first occurrence of ITEM in LIST. 666 "Find the first occurrence of ITEM in LIST.
@@ -678,8 +669,8 @@ Return the sublist of LIST whose car is ITEM.
678\n(fn ITEM LIST [KEYWORD VALUE]...)" 669\n(fn ITEM LIST [KEYWORD VALUE]...)"
679 (declare (compiler-macro cl--compiler-macro-member)) 670 (declare (compiler-macro cl--compiler-macro-member))
680 (if cl-keys 671 (if cl-keys
681 (cl-parsing-keywords (:test :test-not :key :if :if-not) () 672 (cl--parsing-keywords (:test :test-not :key :if :if-not) ()
682 (while (and cl-list (not (cl-check-test cl-item (car cl-list)))) 673 (while (and cl-list (not (cl--check-test cl-item (car cl-list))))
683 (setq cl-list (cdr cl-list))) 674 (setq cl-list (cdr cl-list)))
684 cl-list) 675 cl-list)
685 (if (and (numberp cl-item) (not (integerp cl-item))) 676 (if (and (numberp cl-item) (not (integerp cl-item)))
@@ -705,12 +696,11 @@ Return the sublist of LIST whose car matches.
705 696
706;;;###autoload 697;;;###autoload
707(defun cl--adjoin (cl-item cl-list &rest cl-keys) 698(defun cl--adjoin (cl-item cl-list &rest cl-keys)
708 (if (cl-parsing-keywords (:key) t 699 (if (cl--parsing-keywords (:key) t
709 (apply 'cl-member (cl-check-key cl-item) cl-list cl-keys)) 700 (apply 'cl-member (cl--check-key cl-item) cl-list cl-keys))
710 cl-list 701 cl-list
711 (cons cl-item cl-list))) 702 (cons cl-item cl-list)))
712 703
713;;; See compiler macro in cl-macs.el
714;;;###autoload 704;;;###autoload
715(defun cl-assoc (cl-item cl-alist &rest cl-keys) 705(defun cl-assoc (cl-item cl-alist &rest cl-keys)
716 "Find the first item whose car matches ITEM in LIST. 706 "Find the first item whose car matches ITEM in LIST.
@@ -718,10 +708,10 @@ Return the sublist of LIST whose car matches.
718\n(fn ITEM LIST [KEYWORD VALUE]...)" 708\n(fn ITEM LIST [KEYWORD VALUE]...)"
719 (declare (compiler-macro cl--compiler-macro-assoc)) 709 (declare (compiler-macro cl--compiler-macro-assoc))
720 (if cl-keys 710 (if cl-keys
721 (cl-parsing-keywords (:test :test-not :key :if :if-not) () 711 (cl--parsing-keywords (:test :test-not :key :if :if-not) ()
722 (while (and cl-alist 712 (while (and cl-alist
723 (or (not (consp (car cl-alist))) 713 (or (not (consp (car cl-alist)))
724 (not (cl-check-test cl-item (car (car cl-alist)))))) 714 (not (cl--check-test cl-item (car (car cl-alist))))))
725 (setq cl-alist (cdr cl-alist))) 715 (setq cl-alist (cdr cl-alist)))
726 (and cl-alist (car cl-alist))) 716 (and cl-alist (car cl-alist)))
727 (if (and (numberp cl-item) (not (integerp cl-item))) 717 (if (and (numberp cl-item) (not (integerp cl-item)))
@@ -749,10 +739,10 @@ Return the sublist of LIST whose car matches.
749\nKeywords supported: :test :test-not :key 739\nKeywords supported: :test :test-not :key
750\n(fn ITEM LIST [KEYWORD VALUE]...)" 740\n(fn ITEM LIST [KEYWORD VALUE]...)"
751 (if (or cl-keys (numberp cl-item)) 741 (if (or cl-keys (numberp cl-item))
752 (cl-parsing-keywords (:test :test-not :key :if :if-not) () 742 (cl--parsing-keywords (:test :test-not :key :if :if-not) ()
753 (while (and cl-alist 743 (while (and cl-alist
754 (or (not (consp (car cl-alist))) 744 (or (not (consp (car cl-alist)))
755 (not (cl-check-test cl-item (cdr (car cl-alist)))))) 745 (not (cl--check-test cl-item (cdr (car cl-alist))))))
756 (setq cl-alist (cdr cl-alist))) 746 (setq cl-alist (cdr cl-alist)))
757 (and cl-alist (car cl-alist))) 747 (and cl-alist (car cl-alist)))
758 (rassq cl-item cl-alist))) 748 (rassq cl-item cl-alist)))
@@ -813,13 +803,13 @@ to avoid corrupting the original LIST1 and LIST2.
813\n(fn LIST1 LIST2 [KEYWORD VALUE]...)" 803\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
814 (and cl-list1 cl-list2 804 (and cl-list1 cl-list2
815 (if (equal cl-list1 cl-list2) cl-list1 805 (if (equal cl-list1 cl-list2) cl-list1
816 (cl-parsing-keywords (:key) (:test :test-not) 806 (cl--parsing-keywords (:key) (:test :test-not)
817 (let ((cl-res nil)) 807 (let ((cl-res nil))
818 (or (>= (length cl-list1) (length cl-list2)) 808 (or (>= (length cl-list1) (length cl-list2))
819 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) 809 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
820 (while cl-list2 810 (while cl-list2
821 (if (if (or cl-keys (numberp (car cl-list2))) 811 (if (if (or cl-keys (numberp (car cl-list2)))
822 (apply 'cl-member (cl-check-key (car cl-list2)) 812 (apply 'cl-member (cl--check-key (car cl-list2))
823 cl-list1 cl-keys) 813 cl-list1 cl-keys)
824 (memq (car cl-list2) cl-list1)) 814 (memq (car cl-list2) cl-list1))
825 (push (car cl-list2) cl-res)) 815 (push (car cl-list2) cl-res))
@@ -845,11 +835,11 @@ to avoid corrupting the original LIST1 and LIST2.
845\nKeywords supported: :test :test-not :key 835\nKeywords supported: :test :test-not :key
846\n(fn LIST1 LIST2 [KEYWORD VALUE]...)" 836\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
847 (if (or (null cl-list1) (null cl-list2)) cl-list1 837 (if (or (null cl-list1) (null cl-list2)) cl-list1
848 (cl-parsing-keywords (:key) (:test :test-not) 838 (cl--parsing-keywords (:key) (:test :test-not)
849 (let ((cl-res nil)) 839 (let ((cl-res nil))
850 (while cl-list1 840 (while cl-list1
851 (or (if (or cl-keys (numberp (car cl-list1))) 841 (or (if (or cl-keys (numberp (car cl-list1)))
852 (apply 'cl-member (cl-check-key (car cl-list1)) 842 (apply 'cl-member (cl--check-key (car cl-list1))
853 cl-list2 cl-keys) 843 cl-list2 cl-keys)
854 (memq (car cl-list1) cl-list2)) 844 (memq (car cl-list1) cl-list2))
855 (push (car cl-list1) cl-res)) 845 (push (car cl-list1) cl-res))
@@ -901,9 +891,9 @@ I.e., if every element of LIST1 also appears in LIST2.
901\n(fn LIST1 LIST2 [KEYWORD VALUE]...)" 891\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
902 (cond ((null cl-list1) t) ((null cl-list2) nil) 892 (cond ((null cl-list1) t) ((null cl-list2) nil)
903 ((equal cl-list1 cl-list2) t) 893 ((equal cl-list1 cl-list2) t)
904 (t (cl-parsing-keywords (:key) (:test :test-not) 894 (t (cl--parsing-keywords (:key) (:test :test-not)
905 (while (and cl-list1 895 (while (and cl-list1
906 (apply 'cl-member (cl-check-key (car cl-list1)) 896 (apply 'cl-member (cl--check-key (car cl-list1))
907 cl-list2 cl-keys)) 897 cl-list2 cl-keys))
908 (pop cl-list1)) 898 (pop cl-list1))
909 (null cl-list1))))) 899 (null cl-list1)))))
@@ -949,24 +939,26 @@ Any element of TREE which matches is changed to NEW (via a call to `setcar').
949\n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" 939\n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)"
950 (apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) 940 (apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
951 941
942(defvar cl--alist)
943
952;;;###autoload 944;;;###autoload
953(defun cl-sublis (cl-alist cl-tree &rest cl-keys) 945(defun cl-sublis (cl-alist cl-tree &rest cl-keys)
954 "Perform substitutions indicated by ALIST in TREE (non-destructively). 946 "Perform substitutions indicated by ALIST in TREE (non-destructively).
955Return a copy of TREE with all matching elements replaced. 947Return a copy of TREE with all matching elements replaced.
956\nKeywords supported: :test :test-not :key 948\nKeywords supported: :test :test-not :key
957\n(fn ALIST TREE [KEYWORD VALUE]...)" 949\n(fn ALIST TREE [KEYWORD VALUE]...)"
958 (cl-parsing-keywords (:test :test-not :key :if :if-not) () 950 (cl--parsing-keywords (:test :test-not :key :if :if-not) ()
959 (cl-sublis-rec cl-tree))) 951 (let ((cl--alist cl-alist))
952 (cl--sublis-rec cl-tree))))
960 953
961(defvar cl-alist) 954(defun cl--sublis-rec (cl-tree) ;Uses cl--alist cl-key/test*/if*.
962(defun cl-sublis-rec (cl-tree) ; uses cl-alist/key/test*/if* 955 (let ((cl-temp (cl--check-key cl-tree)) (cl-p cl--alist))
963 (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist)) 956 (while (and cl-p (not (cl--check-test-nokey (car (car cl-p)) cl-temp)))
964 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
965 (setq cl-p (cdr cl-p))) 957 (setq cl-p (cdr cl-p)))
966 (if cl-p (cdr (car cl-p)) 958 (if cl-p (cdr (car cl-p))
967 (if (consp cl-tree) 959 (if (consp cl-tree)
968 (let ((cl-a (cl-sublis-rec (car cl-tree))) 960 (let ((cl-a (cl--sublis-rec (car cl-tree)))
969 (cl-d (cl-sublis-rec (cdr cl-tree)))) 961 (cl-d (cl--sublis-rec (cdr cl-tree))))
970 (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree))) 962 (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree)))
971 cl-tree 963 cl-tree
972 (cons cl-a cl-d))) 964 (cons cl-a cl-d)))
@@ -978,20 +970,21 @@ Return a copy of TREE with all matching elements replaced.
978Any matching element of TREE is changed via a call to `setcar'. 970Any matching element of TREE is changed via a call to `setcar'.
979\nKeywords supported: :test :test-not :key 971\nKeywords supported: :test :test-not :key
980\n(fn ALIST TREE [KEYWORD VALUE]...)" 972\n(fn ALIST TREE [KEYWORD VALUE]...)"
981 (cl-parsing-keywords (:test :test-not :key :if :if-not) () 973 (cl--parsing-keywords (:test :test-not :key :if :if-not) ()
982 (let ((cl-hold (list cl-tree))) 974 (let ((cl-hold (list cl-tree))
983 (cl-nsublis-rec cl-hold) 975 (cl--alist cl-alist))
976 (cl--nsublis-rec cl-hold)
984 (car cl-hold)))) 977 (car cl-hold))))
985 978
986(defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if* 979(defun cl--nsublis-rec (cl-tree) ;Uses cl--alist cl-key/test*/if*.
987 (while (consp cl-tree) 980 (while (consp cl-tree)
988 (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist)) 981 (let ((cl-temp (cl--check-key (car cl-tree))) (cl-p cl--alist))
989 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) 982 (while (and cl-p (not (cl--check-test-nokey (car (car cl-p)) cl-temp)))
990 (setq cl-p (cdr cl-p))) 983 (setq cl-p (cdr cl-p)))
991 (if cl-p (setcar cl-tree (cdr (car cl-p))) 984 (if cl-p (setcar cl-tree (cdr (car cl-p)))
992 (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree)))) 985 (if (consp (car cl-tree)) (cl--nsublis-rec (car cl-tree))))
993 (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist) 986 (setq cl-temp (cl--check-key (cdr cl-tree)) cl-p cl--alist)
994 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) 987 (while (and cl-p (not (cl--check-test-nokey (car (car cl-p)) cl-temp)))
995 (setq cl-p (cdr cl-p))) 988 (setq cl-p (cdr cl-p)))
996 (if cl-p 989 (if cl-p
997 (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil)) 990 (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil))
@@ -1003,14 +996,14 @@ Any matching element of TREE is changed via a call to `setcar'.
1003Atoms are compared by `eql'; cons cells are compared recursively. 996Atoms are compared by `eql'; cons cells are compared recursively.
1004\nKeywords supported: :test :test-not :key 997\nKeywords supported: :test :test-not :key
1005\n(fn TREE1 TREE2 [KEYWORD VALUE]...)" 998\n(fn TREE1 TREE2 [KEYWORD VALUE]...)"
1006 (cl-parsing-keywords (:test :test-not :key) () 999 (cl--parsing-keywords (:test :test-not :key) ()
1007 (cl-tree-equal-rec cl-x cl-y))) 1000 (cl--tree-equal-rec cl-x cl-y)))
1008 1001
1009(defun cl-tree-equal-rec (cl-x cl-y) 1002(defun cl--tree-equal-rec (cl-x cl-y) ;Uses cl-key/test*.
1010 (while (and (consp cl-x) (consp cl-y) 1003 (while (and (consp cl-x) (consp cl-y)
1011 (cl-tree-equal-rec (car cl-x) (car cl-y))) 1004 (cl--tree-equal-rec (car cl-x) (car cl-y)))
1012 (setq cl-x (cdr cl-x) cl-y (cdr cl-y))) 1005 (setq cl-x (cdr cl-x) cl-y (cdr cl-y)))
1013 (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y))) 1006 (and (not (consp cl-x)) (not (consp cl-y)) (cl--check-match cl-x cl-y)))
1014 1007
1015 1008
1016(run-hooks 'cl-seq-load-hook) 1009(run-hooks 'cl-seq-load-hook)
diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el
index d162a377f9b..d41b72f20d4 100644
--- a/lisp/emacs-lisp/cl.el
+++ b/lisp/emacs-lisp/cl.el
@@ -337,6 +337,7 @@ The two cases that are handled are:
337- closure-conversion of lambda expressions for `lexical-let'. 337- closure-conversion of lambda expressions for `lexical-let'.
338- renaming of F when it's a function defined via `cl-labels' or `labels'." 338- renaming of F when it's a function defined via `cl-labels' or `labels'."
339 (require 'cl-macs) 339 (require 'cl-macs)
340 (declare-function cl--expr-contains-any "cl-macs" (x y))
340 (cond 341 (cond
341 ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked 342 ;; ¡¡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 ;; *after* handling `function', but we want to stop macroexpansion from
@@ -460,7 +461,7 @@ go back to their previous definitions, or lack thereof).
460 (let ((func `(cl-function 461 (let ((func `(cl-function
461 (lambda ,(cadr x) 462 (lambda ,(cadr x)
462 (cl-block ,(car x) ,@(cddr x)))))) 463 (cl-block ,(car x) ,@(cddr x))))))
463 (when (cl-compiling-file) 464 (when (cl--compiling-file)
464 ;; Bug#411. It would be nice to fix this. 465 ;; Bug#411. It would be nice to fix this.
465 (and (get (car x) 'byte-compile) 466 (and (get (car x) 'byte-compile)
466 (error "Byte-compiling a redefinition of `%s' \ 467 (error "Byte-compiling a redefinition of `%s' \
@@ -532,6 +533,11 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard.
532(define-obsolete-function-alias 'cl-hash-table-p 'hash-table-p "24.2") 533(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") 534(define-obsolete-function-alias 'cl-hash-table-count 'hash-table-count "24.2")
534 535
536(defun cl-maclisp-member (item list)
537 (declare (obsolete member "24.2"))
538 (while (and list (not (equal item (car list)))) (setq list (cdr list)))
539 list)
540
535;; FIXME: More candidates: define-modify-macro, define-setf-expander. 541;; FIXME: More candidates: define-modify-macro, define-setf-expander.
536 542
537(provide 'cl) 543(provide 'cl)
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index ed52be6cc1e..357bc6a77f6 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -510,7 +510,7 @@ suitable file is found, return nil."
510 (unless (looking-back "\n\n") 510 (unless (looking-back "\n\n")
511 (terpri))))) 511 (terpri)))))
512 ;; Note that list* etc do not get this property until 512 ;; Note that list* etc do not get this property until
513 ;; cl-hack-byte-compiler runs, after bytecomp is loaded. 513 ;; cl--hack-byte-compiler runs, after bytecomp is loaded.
514 (when (and (symbolp function) 514 (when (and (symbolp function)
515 (eq (get function 'byte-compile) 515 (eq (get function 'byte-compile)
516 'cl-byte-compile-compiler-macro)) 516 'cl-byte-compile-compiler-macro))
generated by cgit v1.2.1 (git 2.18.0) at 2026-02-07 00:02:57 +0000