aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--lisp/ChangeLog12
-rw-r--r--lisp/emacs-lisp/cl-extra.el9
-rw-r--r--lisp/emacs-lisp/cl-lib.el21
-rw-r--r--lisp/emacs-lisp/cl-loaddefs.el12
-rw-r--r--lisp/emacs-lisp/cl-macs.el262
-rw-r--r--lisp/emacs-lisp/cl-seq.el9
6 files changed, 191 insertions, 134 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 41c535dc889..c2649b77321 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,17 @@
12012-12-06 Stefan Monnier <monnier@iro.umontreal.ca> 12012-12-06 Stefan Monnier <monnier@iro.umontreal.ca>
2 2
3 Further cleanup of the "cl-" namespace. Fit CL in 80 columns.
4 * emacs-lisp/cl-macs.el (cl--pop2, cl--optimize-safety)
5 (cl--optimize-speed, cl--not-toplevel, cl--parse-loop-clause)
6 (cl--expand-do-loop, cl--proclaim-history, cl--declare-stack)
7 (cl--do-proclaim, cl--proclaims-deferred): Rename from the "cl-" prefix.
8 (cl-progv): Don't rely on dynamic scoping to find the body.
9 * emacs-lisp/cl-lib.el (cl--optimize-speed, cl--optimize-safety)
10 (cl--proclaims-deferred): Rename from the "cl-" prefix.
11 (cl-declaim): Use backquotes.
12 * emacs-lisp/cl-extra.el (cl-make-random-state, cl-random-state-p):
13 Use "cl--" prefix for the object's tag.
14
3 * ses.el: Use advice-add/remove. 15 * ses.el: Use advice-add/remove.
4 (ses--advice-copy-region-as-kill, ses--advice-yank): New functions. 16 (ses--advice-copy-region-as-kill, ses--advice-yank): New functions.
5 (copy-region-as-kill, yank): Use advice-add. 17 (copy-region-as-kill, yank): Use advice-add.
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 7c25972835b..b12b332d2e6 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -51,7 +51,8 @@ TYPE is a Common Lisp type specifier.
51 ((eq type 'string) (if (stringp x) x (concat x))) 51 ((eq type 'string) (if (stringp x) x (concat x)))
52 ((eq type 'array) (if (arrayp x) x (vconcat x))) 52 ((eq type 'array) (if (arrayp x) x (vconcat x)))
53 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) 53 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
54 ((and (eq type 'character) (symbolp x)) (cl-coerce (symbol-name x) type)) 54 ((and (eq type 'character) (symbolp x))
55 (cl-coerce (symbol-name x) type))
55 ((eq type 'float) (float x)) 56 ((eq type 'float) (float x))
56 ((cl-typep x type) x) 57 ((cl-typep x type) x)
57 (t (error "Can't coerce %s to type %s" x type)))) 58 (t (error "Can't coerce %s to type %s" x type))))
@@ -69,7 +70,7 @@ strings case-insensitively."
69 ((stringp x) 70 ((stringp x)
70 (and (stringp y) (= (length x) (length y)) 71 (and (stringp y) (= (length x) (length y))
71 (or (string-equal x y) 72 (or (string-equal x y)
72 (string-equal (downcase x) (downcase y))))) ; lazy but simple! 73 (string-equal (downcase x) (downcase y))))) ;Lazy but simple!
73 ((numberp x) 74 ((numberp x)
74 (and (numberp y) (= x y))) 75 (and (numberp y) (= x y)))
75 ((consp x) 76 ((consp x)
@@ -439,14 +440,14 @@ Optional second arg STATE is a random-state object."
439If STATE is t, return a new state object seeded from the time of day." 440If STATE is t, return a new state object seeded from the time of day."
440 (cond ((null state) (cl-make-random-state cl--random-state)) 441 (cond ((null state) (cl-make-random-state cl--random-state))
441 ((vectorp state) (copy-tree state t)) 442 ((vectorp state) (copy-tree state t))
442 ((integerp state) (vector 'cl-random-state-tag -1 30 state)) 443 ((integerp state) (vector 'cl--random-state-tag -1 30 state))
443 (t (cl-make-random-state (cl--random-time))))) 444 (t (cl-make-random-state (cl--random-time)))))
444 445
445;;;###autoload 446;;;###autoload
446(defun cl-random-state-p (object) 447(defun cl-random-state-p (object)
447 "Return t if OBJECT is a random-state object." 448 "Return t if OBJECT is a random-state object."
448 (and (vectorp object) (= (length object) 4) 449 (and (vectorp object) (= (length object) 4)
449 (eq (aref object 0) 'cl-random-state-tag))) 450 (eq (aref object 0) 'cl--random-state-tag)))
450 451
451 452
452;; Implementation limits. 453;; Implementation limits.
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index d5e5f4bbfbc..8120c87de16 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -93,8 +93,8 @@
93 93
94(require 'macroexp) 94(require 'macroexp)
95 95
96(defvar cl-optimize-speed 1) 96(defvar cl--optimize-speed 1)
97(defvar cl-optimize-safety 1) 97(defvar cl--optimize-safety 1)
98 98
99;;;###autoload 99;;;###autoload
100(define-obsolete-variable-alias 100(define-obsolete-variable-alias
@@ -248,23 +248,21 @@ one value.
248 (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) 248 (equal (buffer-name (symbol-value 'byte-compile--outbuffer))
249 " *Compiler Output*")))) 249 " *Compiler Output*"))))
250 250
251(defvar cl-proclaims-deferred nil) 251(defvar cl--proclaims-deferred nil)
252 252
253(defun cl-proclaim (spec) 253(defun cl-proclaim (spec)
254 "Record a global declaration specified by SPEC." 254 "Record a global declaration specified by SPEC."
255 (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t) 255 (if (fboundp 'cl--do-proclaim) (cl--do-proclaim spec t)
256 (push spec cl-proclaims-deferred)) 256 (push spec cl--proclaims-deferred))
257 nil) 257 nil)
258 258
259(defmacro cl-declaim (&rest specs) 259(defmacro cl-declaim (&rest specs)
260 "Like `cl-proclaim', but takes any number of unevaluated, unquoted arguments. 260 "Like `cl-proclaim', but takes any number of unevaluated, unquoted arguments.
261Puts `(cl-eval-when (compile load eval) ...)' around the declarations 261Puts `(cl-eval-when (compile load eval) ...)' around the declarations
262so that they are registered at compile-time as well as run-time." 262so that they are registered at compile-time as well as run-time."
263 (let ((body (mapcar (function (lambda (x) 263 (let ((body (mapcar (lambda (x) `(cl-proclaim ',x) specs))))
264 (list 'cl-proclaim (list 'quote x)))) 264 (if (cl--compiling-file) `(cl-eval-when (compile load eval) ,@body)
265 specs))) 265 `(progn ,@body)))) ; Avoid loading cl-macs.el for cl-eval-when.
266 (if (cl--compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body)
267 (cons 'progn body)))) ; avoid loading cl-macs.el for cl-eval-when
268 266
269 267
270;;; Symbols. 268;;; Symbols.
@@ -301,7 +299,8 @@ always returns nil."
301 "Return t if INTEGER is even." 299 "Return t if INTEGER is even."
302 (eq (logand integer 1) 0)) 300 (eq (logand integer 1) 0))
303 301
304(defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl--random-time))) 302(defvar cl--random-state
303 (vector 'cl--random-state-tag -1 30 (cl--random-time)))
305 304
306(defconst cl-most-positive-float nil 305(defconst cl-most-positive-float nil
307 "The largest value that a Lisp float can hold. 306 "The largest value that a Lisp float can hold.
diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el
index a9523caf0eb..73759857aca 100644
--- a/lisp/emacs-lisp/cl-loaddefs.el
+++ b/lisp/emacs-lisp/cl-loaddefs.el
@@ -11,7 +11,7 @@
11;;;;;; cl--map-overlays cl--map-intervals cl--map-keymap-recursively 11;;;;;; cl--map-overlays cl--map-intervals cl--map-keymap-recursively
12;;;;;; cl-notevery cl-notany cl-every cl-some cl-mapcon cl-mapcan 12;;;;;; cl-notevery cl-notany cl-every cl-some cl-mapcon cl-mapcan
13;;;;;; cl-mapl cl-mapc cl-maplist cl-map cl--mapcar-many cl-equalp 13;;;;;; cl-mapl cl-mapc cl-maplist cl-map cl--mapcar-many cl-equalp
14;;;;;; cl-coerce) "cl-extra" "cl-extra.el" "8e9fee941c465ac0fee9b92a92d64154") 14;;;;;; cl-coerce) "cl-extra" "cl-extra.el" "3ee58411735a01dd1e1d3964fdcfae70")
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" "\
@@ -224,7 +224,7 @@ Return the value of SYMBOL's PROPNAME property, or DEFAULT if none.
224 224
225\(fn SYMBOL PROPNAME &optional DEFAULT)" nil nil) 225\(fn SYMBOL PROPNAME &optional DEFAULT)" nil nil)
226 226
227(put 'cl-get 'compiler-macro #'cl--compiler-macro-get) 227(eval-and-compile (put 'cl-get 'compiler-macro #'cl--compiler-macro-get))
228 228
229(autoload 'cl-getf "cl-extra" "\ 229(autoload 'cl-getf "cl-extra" "\
230Search PROPLIST for property PROPNAME; return its value or DEFAULT. 230Search PROPLIST for property PROPNAME; return its value or DEFAULT.
@@ -267,7 +267,7 @@ including `cl-block' and `cl-eval-when'.
267;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when 267;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when
268;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp 268;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp
269;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*) 269;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*)
270;;;;;; "cl-macs" "cl-macs.el" "3dd5e153133b2752fd52e45792c46dfe") 270;;;;;; "cl-macs" "cl-macs.el" "5df0692d7c4bffb2cc353f802d94f796")
271;;; Generated autoloads from cl-macs.el 271;;; Generated autoloads from cl-macs.el
272 272
273(autoload 'cl--compiler-macro-list* "cl-macs" "\ 273(autoload 'cl--compiler-macro-list* "cl-macs" "\
@@ -759,7 +759,7 @@ surrounded by (cl-block NAME ...).
759;;;;;; cl-nsubstitute-if cl-nsubstitute cl-substitute-if-not cl-substitute-if 759;;;;;; cl-nsubstitute-if cl-nsubstitute cl-substitute-if-not cl-substitute-if
760;;;;;; cl-substitute cl-delete-duplicates cl-remove-duplicates cl-delete-if-not 760;;;;;; cl-substitute cl-delete-duplicates cl-remove-duplicates cl-delete-if-not
761;;;;;; cl-delete-if cl-delete cl-remove-if-not cl-remove-if cl-remove 761;;;;;; cl-delete-if cl-delete cl-remove-if-not cl-remove-if cl-remove
762;;;;;; cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "4c1e1191e82dc8d5449a5ec4d59efc10") 762;;;;;; cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "697d04e7ae0a9b9c15eea705b359b1bb")
763;;; Generated autoloads from cl-seq.el 763;;; Generated autoloads from cl-seq.el
764 764
765(autoload 'cl-reduce "cl-seq" "\ 765(autoload 'cl-reduce "cl-seq" "\
@@ -1020,7 +1020,7 @@ Keywords supported: :test :test-not :key
1020 1020
1021\(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) 1021\(fn ITEM LIST [KEYWORD VALUE]...)" nil nil)
1022 1022
1023(put 'cl-member 'compiler-macro #'cl--compiler-macro-member) 1023(eval-and-compile (put 'cl-member 'compiler-macro #'cl--compiler-macro-member))
1024 1024
1025(autoload 'cl-member-if "cl-seq" "\ 1025(autoload 'cl-member-if "cl-seq" "\
1026Find the first item satisfying PREDICATE in LIST. 1026Find the first item satisfying PREDICATE in LIST.
@@ -1050,7 +1050,7 @@ Keywords supported: :test :test-not :key
1050 1050
1051\(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) 1051\(fn ITEM LIST [KEYWORD VALUE]...)" nil nil)
1052 1052
1053(put 'cl-assoc 'compiler-macro #'cl--compiler-macro-assoc) 1053(eval-and-compile (put 'cl-assoc 'compiler-macro #'cl--compiler-macro-assoc))
1054 1054
1055(autoload 'cl-assoc-if "cl-seq" "\ 1055(autoload 'cl-assoc-if "cl-seq" "\
1056Find the first item whose car satisfies PREDICATE in LIST. 1056Find the first item whose car satisfies PREDICATE in LIST.
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index a1f1cf36025..829357cbbe0 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -48,13 +48,13 @@
48;; `gv' is required here because cl-macs can be loaded before loaddefs.el. 48;; `gv' is required here because cl-macs can be loaded before loaddefs.el.
49(require 'gv) 49(require 'gv)
50 50
51(defmacro cl-pop2 (place) 51(defmacro cl--pop2 (place)
52 (declare (debug edebug-sexps)) 52 (declare (debug edebug-sexps))
53 `(prog1 (car (cdr ,place)) 53 `(prog1 (car (cdr ,place))
54 (setq ,place (cdr (cdr ,place))))) 54 (setq ,place (cdr (cdr ,place)))))
55 55
56(defvar cl-optimize-safety) 56(defvar cl--optimize-safety)
57(defvar cl-optimize-speed) 57(defvar cl--optimize-speed)
58 58
59;;; Initialization. 59;;; Initialization.
60 60
@@ -431,7 +431,7 @@ its argument list allows full Common Lisp conventions."
431 (if (memq '&environment args) (error "&environment used incorrectly")) 431 (if (memq '&environment args) (error "&environment used incorrectly"))
432 (let ((save-args args) 432 (let ((save-args args)
433 (restarg (memq '&rest args)) 433 (restarg (memq '&rest args))
434 (safety (if (cl--compiling-file) cl-optimize-safety 3)) 434 (safety (if (cl--compiling-file) cl--optimize-safety 3))
435 (keys nil) 435 (keys nil)
436 (laterarg nil) (exactarg nil) minarg) 436 (laterarg nil) (exactarg nil) minarg)
437 (or num (setq num 0)) 437 (or num (setq num 0))
@@ -440,7 +440,7 @@ its argument list allows full Common Lisp conventions."
440 (setq restarg (cadr restarg))) 440 (setq restarg (cadr restarg)))
441 (push (list restarg expr) cl--bind-lets) 441 (push (list restarg expr) cl--bind-lets)
442 (if (eq (car args) '&whole) 442 (if (eq (car args) '&whole)
443 (push (list (cl-pop2 args) restarg) cl--bind-lets)) 443 (push (list (cl--pop2 args) restarg) cl--bind-lets))
444 (let ((p args)) 444 (let ((p args))
445 (setq minarg restarg) 445 (setq minarg restarg)
446 (while (and p (not (memq (car p) cl--lambda-list-keywords))) 446 (while (and p (not (memq (car p) cl--lambda-list-keywords)))
@@ -476,7 +476,7 @@ its argument list allows full Common Lisp conventions."
476 (if def `(if ,restarg ,poparg ,def) poparg)) 476 (if def `(if ,restarg ,poparg ,def) poparg))
477 (setq num (1+ num)))))) 477 (setq num (1+ num))))))
478 (if (eq (car args) '&rest) 478 (if (eq (car args) '&rest)
479 (let ((arg (cl-pop2 args))) 479 (let ((arg (cl--pop2 args)))
480 (if (consp arg) (cl--do-arglist arg restarg))) 480 (if (consp arg) (cl--do-arglist arg restarg)))
481 (or (eq (car args) '&key) (= safety 0) exactarg 481 (or (eq (car args) '&key) (= safety 0) exactarg
482 (push `(if ,restarg 482 (push `(if ,restarg
@@ -574,7 +574,7 @@ its argument list allows full Common Lisp conventions."
574 574
575;;; The `cl-eval-when' form. 575;;; The `cl-eval-when' form.
576 576
577(defvar cl-not-toplevel nil) 577(defvar cl--not-toplevel nil)
578 578
579;;;###autoload 579;;;###autoload
580(defmacro cl-eval-when (when &rest body) 580(defmacro cl-eval-when (when &rest body)
@@ -586,9 +586,9 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.
586\(fn (WHEN...) BODY...)" 586\(fn (WHEN...) BODY...)"
587 (declare (indent 1) (debug ((&rest &or "compile" "load" "eval") body))) 587 (declare (indent 1) (debug ((&rest &or "compile" "load" "eval") body)))
588 (if (and (fboundp 'cl--compiling-file) (cl--compiling-file) 588 (if (and (fboundp 'cl--compiling-file) (cl--compiling-file)
589 (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge 589 (not cl--not-toplevel) (not (boundp 'for-effect))) ;Horrible kludge.
590 (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) 590 (let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
591 (cl-not-toplevel t)) 591 (cl--not-toplevel t))
592 (if (or (memq 'load when) (memq :load-toplevel when)) 592 (if (or (memq 'load when) (memq :load-toplevel when))
593 (if comp (cons 'progn (mapcar 'cl--compile-time-too body)) 593 (if comp (cons 'progn (mapcar 'cl--compile-time-too body))
594 `(if nil nil ,@body)) 594 `(if nil nil ,@body))
@@ -759,7 +759,8 @@ This is compatible with Common Lisp, but note that `defun' and
759(defvar cl--loop-first-flag) 759(defvar cl--loop-first-flag)
760(defvar cl--loop-initially) (defvar cl--loop-map-form) (defvar cl--loop-name) 760(defvar cl--loop-initially) (defvar cl--loop-map-form) (defvar cl--loop-name)
761(defvar cl--loop-result) (defvar cl--loop-result-explicit) 761(defvar cl--loop-result) (defvar cl--loop-result-explicit)
762(defvar cl--loop-result-var) (defvar cl--loop-steps) (defvar cl--loop-symbol-macs) 762(defvar cl--loop-result-var) (defvar cl--loop-steps)
763(defvar cl--loop-symbol-macs)
763 764
764;;;###autoload 765;;;###autoload
765(defmacro cl-loop (&rest loop-args) 766(defmacro cl-loop (&rest loop-args)
@@ -792,7 +793,8 @@ Valid clauses are:
792 "return"] form] 793 "return"] form]
793 ;; Simple default, which covers 99% of the cases. 794 ;; Simple default, which covers 99% of the cases.
794 symbolp form))) 795 symbolp form)))
795 (if (not (memq t (mapcar 'symbolp (delq nil (delq t (cl-copy-list loop-args)))))) 796 (if (not (memq t (mapcar #'symbolp
797 (delq nil (delq t (cl-copy-list loop-args))))))
796 `(cl-block nil (while t ,@loop-args)) 798 `(cl-block nil (while t ,@loop-args))
797 (let ((cl--loop-args loop-args) (cl--loop-name nil) (cl--loop-bindings nil) 799 (let ((cl--loop-args loop-args) (cl--loop-name nil) (cl--loop-bindings nil)
798 (cl--loop-body nil) (cl--loop-steps nil) 800 (cl--loop-body nil) (cl--loop-steps nil)
@@ -803,14 +805,16 @@ Valid clauses are:
803 (cl--loop-map-form nil) (cl--loop-first-flag nil) 805 (cl--loop-map-form nil) (cl--loop-first-flag nil)
804 (cl--loop-destr-temps nil) (cl--loop-symbol-macs nil)) 806 (cl--loop-destr-temps nil) (cl--loop-symbol-macs nil))
805 (setq cl--loop-args (append cl--loop-args '(cl-end-loop))) 807 (setq cl--loop-args (append cl--loop-args '(cl-end-loop)))
806 (while (not (eq (car cl--loop-args) 'cl-end-loop)) (cl-parse-loop-clause)) 808 (while (not (eq (car cl--loop-args) 'cl-end-loop))
809 (cl--parse-loop-clause))
807 (if cl--loop-finish-flag 810 (if cl--loop-finish-flag
808 (push `((,cl--loop-finish-flag t)) cl--loop-bindings)) 811 (push `((,cl--loop-finish-flag t)) cl--loop-bindings))
809 (if cl--loop-first-flag 812 (if cl--loop-first-flag
810 (progn (push `((,cl--loop-first-flag t)) cl--loop-bindings) 813 (progn (push `((,cl--loop-first-flag t)) cl--loop-bindings)
811 (push `(setq ,cl--loop-first-flag nil) cl--loop-steps))) 814 (push `(setq ,cl--loop-first-flag nil) cl--loop-steps)))
812 (let* ((epilogue (nconc (nreverse cl--loop-finally) 815 (let* ((epilogue (nconc (nreverse cl--loop-finally)
813 (list (or cl--loop-result-explicit cl--loop-result)))) 816 (list (or cl--loop-result-explicit
817 cl--loop-result))))
814 (ands (cl--loop-build-ands (nreverse cl--loop-body))) 818 (ands (cl--loop-build-ands (nreverse cl--loop-body)))
815 (while-body (nconc (cadr ands) (nreverse cl--loop-steps))) 819 (while-body (nconc (cadr ands) (nreverse cl--loop-steps)))
816 (body (append 820 (body (append
@@ -830,7 +834,8 @@ Valid clauses are:
830 `((if ,cl--loop-finish-flag 834 `((if ,cl--loop-finish-flag
831 (progn ,@epilogue) ,cl--loop-result-var))) 835 (progn ,@epilogue) ,cl--loop-result-var)))
832 epilogue)))) 836 epilogue))))
833 (if cl--loop-result-var (push (list cl--loop-result-var) cl--loop-bindings)) 837 (if cl--loop-result-var
838 (push (list cl--loop-result-var) cl--loop-bindings))
834 (while cl--loop-bindings 839 (while cl--loop-bindings
835 (if (cdar cl--loop-bindings) 840 (if (cdar cl--loop-bindings)
836 (setq body (list (cl--loop-let (pop cl--loop-bindings) body t))) 841 (setq body (list (cl--loop-let (pop cl--loop-bindings) body t)))
@@ -840,7 +845,8 @@ Valid clauses are:
840 (push (car (pop cl--loop-bindings)) lets)) 845 (push (car (pop cl--loop-bindings)) lets))
841 (setq body (list (cl--loop-let lets body nil)))))) 846 (setq body (list (cl--loop-let lets body nil))))))
842 (if cl--loop-symbol-macs 847 (if cl--loop-symbol-macs
843 (setq body (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body)))) 848 (setq body
849 (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body))))
844 `(cl-block ,cl--loop-name ,@body))))) 850 `(cl-block ,cl--loop-name ,@body)))))
845 851
846;; Below is a complete spec for cl-loop, in several parts that correspond 852;; Below is a complete spec for cl-loop, in several parts that correspond
@@ -995,7 +1001,7 @@ Valid clauses are:
995 1001
996 1002
997 1003
998(defun cl-parse-loop-clause () ; uses loop-* 1004(defun cl--parse-loop-clause () ; uses loop-*
999 (let ((word (pop cl--loop-args)) 1005 (let ((word (pop cl--loop-args))
1000 (hash-types '(hash-key hash-keys hash-value hash-values)) 1006 (hash-types '(hash-key hash-keys hash-value hash-values))
1001 (key-types '(key-code key-codes key-seq key-seqs 1007 (key-types '(key-code key-codes key-seq key-seqs
@@ -1010,17 +1016,21 @@ Valid clauses are:
1010 1016
1011 ((eq word 'initially) 1017 ((eq word 'initially)
1012 (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) 1018 (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args))
1013 (or (consp (car cl--loop-args)) (error "Syntax error on `initially' clause")) 1019 (or (consp (car cl--loop-args))
1020 (error "Syntax error on `initially' clause"))
1014 (while (consp (car cl--loop-args)) 1021 (while (consp (car cl--loop-args))
1015 (push (pop cl--loop-args) cl--loop-initially))) 1022 (push (pop cl--loop-args) cl--loop-initially)))
1016 1023
1017 ((eq word 'finally) 1024 ((eq word 'finally)
1018 (if (eq (car cl--loop-args) 'return) 1025 (if (eq (car cl--loop-args) 'return)
1019 (setq cl--loop-result-explicit (or (cl-pop2 cl--loop-args) '(quote nil))) 1026 (setq cl--loop-result-explicit
1027 (or (cl--pop2 cl--loop-args) '(quote nil)))
1020 (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) 1028 (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args))
1021 (or (consp (car cl--loop-args)) (error "Syntax error on `finally' clause")) 1029 (or (consp (car cl--loop-args))
1030 (error "Syntax error on `finally' clause"))
1022 (if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name)) 1031 (if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name))
1023 (setq cl--loop-result-explicit (or (nth 1 (pop cl--loop-args)) '(quote nil))) 1032 (setq cl--loop-result-explicit
1033 (or (nth 1 (pop cl--loop-args)) '(quote nil)))
1024 (while (consp (car cl--loop-args)) 1034 (while (consp (car cl--loop-args))
1025 (push (pop cl--loop-args) cl--loop-finally))))) 1035 (push (pop cl--loop-args) cl--loop-finally)))))
1026 1036
@@ -1036,7 +1046,8 @@ Valid clauses are:
1036 (if (eq word 'being) (setq word (pop cl--loop-args))) 1046 (if (eq word 'being) (setq word (pop cl--loop-args)))
1037 (if (memq word '(the each)) (setq word (pop cl--loop-args))) 1047 (if (memq word '(the each)) (setq word (pop cl--loop-args)))
1038 (if (memq word '(buffer buffers)) 1048 (if (memq word '(buffer buffers))
1039 (setq word 'in cl--loop-args (cons '(buffer-list) cl--loop-args))) 1049 (setq word 'in
1050 cl--loop-args (cons '(buffer-list) cl--loop-args)))
1040 (cond 1051 (cond
1041 1052
1042 ((memq word '(from downfrom upfrom to downto upto 1053 ((memq word '(from downfrom upfrom to downto upto
@@ -1045,15 +1056,19 @@ Valid clauses are:
1045 (if (memq (car cl--loop-args) '(downto above)) 1056 (if (memq (car cl--loop-args) '(downto above))
1046 (error "Must specify `from' value for downward cl-loop")) 1057 (error "Must specify `from' value for downward cl-loop"))
1047 (let* ((down (or (eq (car cl--loop-args) 'downfrom) 1058 (let* ((down (or (eq (car cl--loop-args) 'downfrom)
1048 (memq (cl-caddr cl--loop-args) '(downto above)))) 1059 (memq (cl-caddr cl--loop-args)
1060 '(downto above))))
1049 (excl (or (memq (car cl--loop-args) '(above below)) 1061 (excl (or (memq (car cl--loop-args) '(above below))
1050 (memq (cl-caddr cl--loop-args) '(above below)))) 1062 (memq (cl-caddr cl--loop-args)
1051 (start (and (memq (car cl--loop-args) '(from upfrom downfrom)) 1063 '(above below))))
1052 (cl-pop2 cl--loop-args))) 1064 (start (and (memq (car cl--loop-args)
1065 '(from upfrom downfrom))
1066 (cl--pop2 cl--loop-args)))
1053 (end (and (memq (car cl--loop-args) 1067 (end (and (memq (car cl--loop-args)
1054 '(to upto downto above below)) 1068 '(to upto downto above below))
1055 (cl-pop2 cl--loop-args))) 1069 (cl--pop2 cl--loop-args)))
1056 (step (and (eq (car cl--loop-args) 'by) (cl-pop2 cl--loop-args))) 1070 (step (and (eq (car cl--loop-args) 'by)
1071 (cl--pop2 cl--loop-args)))
1057 (end-var (and (not (macroexp-const-p end)) 1072 (end-var (and (not (macroexp-const-p end))
1058 (make-symbol "--cl-var--"))) 1073 (make-symbol "--cl-var--")))
1059 (step-var (and (not (macroexp-const-p step)) 1074 (step-var (and (not (macroexp-const-p step))
@@ -1087,7 +1102,7 @@ Valid clauses are:
1087 loop-for-sets)))) 1102 loop-for-sets))))
1088 (push (list temp 1103 (push (list temp
1089 (if (eq (car cl--loop-args) 'by) 1104 (if (eq (car cl--loop-args) 'by)
1090 (let ((step (cl-pop2 cl--loop-args))) 1105 (let ((step (cl--pop2 cl--loop-args)))
1091 (if (and (memq (car-safe step) 1106 (if (and (memq (car-safe step)
1092 '(quote function 1107 '(quote function
1093 cl-function)) 1108 cl-function))
@@ -1099,7 +1114,8 @@ Valid clauses are:
1099 1114
1100 ((eq word '=) 1115 ((eq word '=)
1101 (let* ((start (pop cl--loop-args)) 1116 (let* ((start (pop cl--loop-args))
1102 (then (if (eq (car cl--loop-args) 'then) (cl-pop2 cl--loop-args) start))) 1117 (then (if (eq (car cl--loop-args) 'then)
1118 (cl--pop2 cl--loop-args) start)))
1103 (push (list var nil) loop-for-bindings) 1119 (push (list var nil) loop-for-bindings)
1104 (if (or ands (eq (car cl--loop-args) 'and)) 1120 (if (or ands (eq (car cl--loop-args) 'and))
1105 (progn 1121 (progn
@@ -1136,14 +1152,15 @@ Valid clauses are:
1136 (let ((ref (or (memq (car cl--loop-args) '(in-ref of-ref)) 1152 (let ((ref (or (memq (car cl--loop-args) '(in-ref of-ref))
1137 (and (not (memq (car cl--loop-args) '(in of))) 1153 (and (not (memq (car cl--loop-args) '(in of)))
1138 (error "Expected `of'")))) 1154 (error "Expected `of'"))))
1139 (seq (cl-pop2 cl--loop-args)) 1155 (seq (cl--pop2 cl--loop-args))
1140 (temp-seq (make-symbol "--cl-seq--")) 1156 (temp-seq (make-symbol "--cl-seq--"))
1141 (temp-idx (if (eq (car cl--loop-args) 'using) 1157 (temp-idx
1142 (if (and (= (length (cadr cl--loop-args)) 2) 1158 (if (eq (car cl--loop-args) 'using)
1143 (eq (cl-caadr cl--loop-args) 'index)) 1159 (if (and (= (length (cadr cl--loop-args)) 2)
1144 (cadr (cl-pop2 cl--loop-args)) 1160 (eq (cl-caadr cl--loop-args) 'index))
1145 (error "Bad `using' clause")) 1161 (cadr (cl--pop2 cl--loop-args))
1146 (make-symbol "--cl-idx--")))) 1162 (error "Bad `using' clause"))
1163 (make-symbol "--cl-idx--"))))
1147 (push (list temp-seq seq) loop-for-bindings) 1164 (push (list temp-seq seq) loop-for-bindings)
1148 (push (list temp-idx 0) loop-for-bindings) 1165 (push (list temp-idx 0) loop-for-bindings)
1149 (if ref 1166 (if ref
@@ -1166,15 +1183,17 @@ Valid clauses are:
1166 loop-for-steps))) 1183 loop-for-steps)))
1167 1184
1168 ((memq word hash-types) 1185 ((memq word hash-types)
1169 (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'")) 1186 (or (memq (car cl--loop-args) '(in of))
1170 (let* ((table (cl-pop2 cl--loop-args)) 1187 (error "Expected `of'"))
1171 (other (if (eq (car cl--loop-args) 'using) 1188 (let* ((table (cl--pop2 cl--loop-args))
1172 (if (and (= (length (cadr cl--loop-args)) 2) 1189 (other
1173 (memq (cl-caadr cl--loop-args) hash-types) 1190 (if (eq (car cl--loop-args) 'using)
1174 (not (eq (cl-caadr cl--loop-args) word))) 1191 (if (and (= (length (cadr cl--loop-args)) 2)
1175 (cadr (cl-pop2 cl--loop-args)) 1192 (memq (cl-caadr cl--loop-args) hash-types)
1176 (error "Bad `using' clause")) 1193 (not (eq (cl-caadr cl--loop-args) word)))
1177 (make-symbol "--cl-var--")))) 1194 (cadr (cl--pop2 cl--loop-args))
1195 (error "Bad `using' clause"))
1196 (make-symbol "--cl-var--"))))
1178 (if (memq word '(hash-value hash-values)) 1197 (if (memq word '(hash-value hash-values))
1179 (setq var (prog1 other (setq other var)))) 1198 (setq var (prog1 other (setq other var))))
1180 (setq cl--loop-map-form 1199 (setq cl--loop-map-form
@@ -1182,16 +1201,19 @@ Valid clauses are:
1182 1201
1183 ((memq word '(symbol present-symbol external-symbol 1202 ((memq word '(symbol present-symbol external-symbol
1184 symbols present-symbols external-symbols)) 1203 symbols present-symbols external-symbols))
1185 (let ((ob (and (memq (car cl--loop-args) '(in of)) (cl-pop2 cl--loop-args)))) 1204 (let ((ob (and (memq (car cl--loop-args) '(in of))
1205 (cl--pop2 cl--loop-args))))
1186 (setq cl--loop-map-form 1206 (setq cl--loop-map-form
1187 `(mapatoms (lambda (,var) . --cl-map) ,ob)))) 1207 `(mapatoms (lambda (,var) . --cl-map) ,ob))))
1188 1208
1189 ((memq word '(overlay overlays extent extents)) 1209 ((memq word '(overlay overlays extent extents))
1190 (let ((buf nil) (from nil) (to nil)) 1210 (let ((buf nil) (from nil) (to nil))
1191 (while (memq (car cl--loop-args) '(in of from to)) 1211 (while (memq (car cl--loop-args) '(in of from to))
1192 (cond ((eq (car cl--loop-args) 'from) (setq from (cl-pop2 cl--loop-args))) 1212 (cond ((eq (car cl--loop-args) 'from)
1193 ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args))) 1213 (setq from (cl--pop2 cl--loop-args)))
1194 (t (setq buf (cl-pop2 cl--loop-args))))) 1214 ((eq (car cl--loop-args) 'to)
1215 (setq to (cl--pop2 cl--loop-args)))
1216 (t (setq buf (cl--pop2 cl--loop-args)))))
1195 (setq cl--loop-map-form 1217 (setq cl--loop-map-form
1196 `(cl--map-overlays 1218 `(cl--map-overlays
1197 (lambda (,var ,(make-symbol "--cl-var--")) 1219 (lambda (,var ,(make-symbol "--cl-var--"))
@@ -1203,11 +1225,13 @@ Valid clauses are:
1203 (var1 (make-symbol "--cl-var1--")) 1225 (var1 (make-symbol "--cl-var1--"))
1204 (var2 (make-symbol "--cl-var2--"))) 1226 (var2 (make-symbol "--cl-var2--")))
1205 (while (memq (car cl--loop-args) '(in of property from to)) 1227 (while (memq (car cl--loop-args) '(in of property from to))
1206 (cond ((eq (car cl--loop-args) 'from) (setq from (cl-pop2 cl--loop-args))) 1228 (cond ((eq (car cl--loop-args) 'from)
1207 ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args))) 1229 (setq from (cl--pop2 cl--loop-args)))
1230 ((eq (car cl--loop-args) 'to)
1231 (setq to (cl--pop2 cl--loop-args)))
1208 ((eq (car cl--loop-args) 'property) 1232 ((eq (car cl--loop-args) 'property)
1209 (setq prop (cl-pop2 cl--loop-args))) 1233 (setq prop (cl--pop2 cl--loop-args)))
1210 (t (setq buf (cl-pop2 cl--loop-args))))) 1234 (t (setq buf (cl--pop2 cl--loop-args)))))
1211 (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) 1235 (if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
1212 (setq var1 (car var) var2 (cdr var)) 1236 (setq var1 (car var) var2 (cdr var))
1213 (push (list var `(cons ,var1 ,var2)) loop-for-sets)) 1237 (push (list var `(cons ,var1 ,var2)) loop-for-sets))
@@ -1217,15 +1241,17 @@ Valid clauses are:
1217 ,buf ,prop ,from ,to)))) 1241 ,buf ,prop ,from ,to))))
1218 1242
1219 ((memq word key-types) 1243 ((memq word key-types)
1220 (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'")) 1244 (or (memq (car cl--loop-args) '(in of))
1221 (let ((cl-map (cl-pop2 cl--loop-args)) 1245 (error "Expected `of'"))
1222 (other (if (eq (car cl--loop-args) 'using) 1246 (let ((cl-map (cl--pop2 cl--loop-args))
1223 (if (and (= (length (cadr cl--loop-args)) 2) 1247 (other
1224 (memq (cl-caadr cl--loop-args) key-types) 1248 (if (eq (car cl--loop-args) 'using)
1225 (not (eq (cl-caadr cl--loop-args) word))) 1249 (if (and (= (length (cadr cl--loop-args)) 2)
1226 (cadr (cl-pop2 cl--loop-args)) 1250 (memq (cl-caadr cl--loop-args) key-types)
1227 (error "Bad `using' clause")) 1251 (not (eq (cl-caadr cl--loop-args) word)))
1228 (make-symbol "--cl-var--")))) 1252 (cadr (cl--pop2 cl--loop-args))
1253 (error "Bad `using' clause"))
1254 (make-symbol "--cl-var--"))))
1229 (if (memq word '(key-binding key-bindings)) 1255 (if (memq word '(key-binding key-bindings))
1230 (setq var (prog1 other (setq other var)))) 1256 (setq var (prog1 other (setq other var))))
1231 (setq cl--loop-map-form 1257 (setq cl--loop-map-form
@@ -1245,7 +1271,8 @@ Valid clauses are:
1245 loop-for-steps))) 1271 loop-for-steps)))
1246 1272
1247 ((memq word '(window windows)) 1273 ((memq word '(window windows))
1248 (let ((scr (and (memq (car cl--loop-args) '(in of)) (cl-pop2 cl--loop-args))) 1274 (let ((scr (and (memq (car cl--loop-args) '(in of))
1275 (cl--pop2 cl--loop-args)))
1249 (temp (make-symbol "--cl-var--")) 1276 (temp (make-symbol "--cl-var--"))
1250 (minip (make-symbol "--cl-minip--"))) 1277 (minip (make-symbol "--cl-minip--")))
1251 (push (list var (if scr 1278 (push (list var (if scr
@@ -1340,7 +1367,8 @@ Valid clauses are:
1340 1367
1341 ((memq word '(minimize minimizing maximize maximizing)) 1368 ((memq word '(minimize minimizing maximize maximizing))
1342 (let* ((what (pop cl--loop-args)) 1369 (let* ((what (pop cl--loop-args))
1343 (temp (if (cl--simple-expr-p what) what (make-symbol "--cl-var--"))) 1370 (temp (if (cl--simple-expr-p what) what
1371 (make-symbol "--cl-var--")))
1344 (var (cl--loop-handle-accum nil)) 1372 (var (cl--loop-handle-accum nil))
1345 (func (intern (substring (symbol-name word) 0 3))) 1373 (func (intern (substring (symbol-name word) 0 3)))
1346 (set `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) 1374 (set `(setq ,var (if ,var (,func ,var ,temp) ,temp))))
@@ -1351,7 +1379,8 @@ Valid clauses are:
1351 ((eq word 'with) 1379 ((eq word 'with)
1352 (let ((bindings nil)) 1380 (let ((bindings nil))
1353 (while (progn (push (list (pop cl--loop-args) 1381 (while (progn (push (list (pop cl--loop-args)
1354 (and (eq (car cl--loop-args) '=) (cl-pop2 cl--loop-args))) 1382 (and (eq (car cl--loop-args) '=)
1383 (cl--pop2 cl--loop-args)))
1355 bindings) 1384 bindings)
1356 (eq (car cl--loop-args) 'and)) 1385 (eq (car cl--loop-args) 'and))
1357 (pop cl--loop-args)) 1386 (pop cl--loop-args))
@@ -1364,19 +1393,23 @@ Valid clauses are:
1364 (push `(not ,(pop cl--loop-args)) cl--loop-body)) 1393 (push `(not ,(pop cl--loop-args)) cl--loop-body))
1365 1394
1366 ((eq word 'always) 1395 ((eq word 'always)
1367 (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) 1396 (or cl--loop-finish-flag
1397 (setq cl--loop-finish-flag (make-symbol "--cl-flag--")))
1368 (push `(setq ,cl--loop-finish-flag ,(pop cl--loop-args)) cl--loop-body) 1398 (push `(setq ,cl--loop-finish-flag ,(pop cl--loop-args)) cl--loop-body)
1369 (setq cl--loop-result t)) 1399 (setq cl--loop-result t))
1370 1400
1371 ((eq word 'never) 1401 ((eq word 'never)
1372 (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) 1402 (or cl--loop-finish-flag
1403 (setq cl--loop-finish-flag (make-symbol "--cl-flag--")))
1373 (push `(setq ,cl--loop-finish-flag (not ,(pop cl--loop-args))) 1404 (push `(setq ,cl--loop-finish-flag (not ,(pop cl--loop-args)))
1374 cl--loop-body) 1405 cl--loop-body)
1375 (setq cl--loop-result t)) 1406 (setq cl--loop-result t))
1376 1407
1377 ((eq word 'thereis) 1408 ((eq word 'thereis)
1378 (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) 1409 (or cl--loop-finish-flag
1379 (or cl--loop-result-var (setq cl--loop-result-var (make-symbol "--cl-var--"))) 1410 (setq cl--loop-finish-flag (make-symbol "--cl-flag--")))
1411 (or cl--loop-result-var
1412 (setq cl--loop-result-var (make-symbol "--cl-var--")))
1380 (push `(setq ,cl--loop-finish-flag 1413 (push `(setq ,cl--loop-finish-flag
1381 (not (setq ,cl--loop-result-var ,(pop cl--loop-args)))) 1414 (not (setq ,cl--loop-result-var ,(pop cl--loop-args))))
1382 cl--loop-body)) 1415 cl--loop-body))
@@ -1384,11 +1417,11 @@ Valid clauses are:
1384 ((memq word '(if when unless)) 1417 ((memq word '(if when unless))
1385 (let* ((cond (pop cl--loop-args)) 1418 (let* ((cond (pop cl--loop-args))
1386 (then (let ((cl--loop-body nil)) 1419 (then (let ((cl--loop-body nil))
1387 (cl-parse-loop-clause) 1420 (cl--parse-loop-clause)
1388 (cl--loop-build-ands (nreverse cl--loop-body)))) 1421 (cl--loop-build-ands (nreverse cl--loop-body))))
1389 (else (let ((cl--loop-body nil)) 1422 (else (let ((cl--loop-body nil))
1390 (if (eq (car cl--loop-args) 'else) 1423 (if (eq (car cl--loop-args) 'else)
1391 (progn (pop cl--loop-args) (cl-parse-loop-clause))) 1424 (progn (pop cl--loop-args) (cl--parse-loop-clause)))
1392 (cl--loop-build-ands (nreverse cl--loop-body)))) 1425 (cl--loop-build-ands (nreverse cl--loop-body))))
1393 (simple (and (eq (car then) t) (eq (car else) t)))) 1426 (simple (and (eq (car then) t) (eq (car else) t))))
1394 (if (eq (car cl--loop-args) 'end) (pop cl--loop-args)) 1427 (if (eq (car cl--loop-args) 'end) (pop cl--loop-args))
@@ -1410,8 +1443,10 @@ Valid clauses are:
1410 (push (cons 'progn (nreverse (cons t body))) cl--loop-body))) 1443 (push (cons 'progn (nreverse (cons t body))) cl--loop-body)))
1411 1444
1412 ((eq word 'return) 1445 ((eq word 'return)
1413 (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-var--"))) 1446 (or cl--loop-finish-flag
1414 (or cl--loop-result-var (setq cl--loop-result-var (make-symbol "--cl-var--"))) 1447 (setq cl--loop-finish-flag (make-symbol "--cl-var--")))
1448 (or cl--loop-result-var
1449 (setq cl--loop-result-var (make-symbol "--cl-var--")))
1415 (push `(setq ,cl--loop-result-var ,(pop cl--loop-args) 1450 (push `(setq ,cl--loop-result-var ,(pop cl--loop-args)
1416 ,cl--loop-finish-flag nil) cl--loop-body)) 1451 ,cl--loop-finish-flag nil) cl--loop-body))
1417 1452
@@ -1421,7 +1456,7 @@ Valid clauses are:
1421 (or handler (error "Expected a cl-loop keyword, found %s" word)) 1456 (or handler (error "Expected a cl-loop keyword, found %s" word))
1422 (funcall handler)))) 1457 (funcall handler))))
1423 (if (eq (car cl--loop-args) 'and) 1458 (if (eq (car cl--loop-args) 'and)
1424 (progn (pop cl--loop-args) (cl-parse-loop-clause))))) 1459 (progn (pop cl--loop-args) (cl--parse-loop-clause)))))
1425 1460
1426(defun cl--loop-let (specs body par) ; uses loop-* 1461(defun cl--loop-let (specs body par) ; uses loop-*
1427 (let ((p specs) (temps nil) (new nil)) 1462 (let ((p specs) (temps nil) (new nil))
@@ -1440,10 +1475,12 @@ Valid clauses are:
1440 (if (and (consp (car specs)) (listp (caar specs))) 1475 (if (and (consp (car specs)) (listp (caar specs)))
1441 (let* ((spec (caar specs)) (nspecs nil) 1476 (let* ((spec (caar specs)) (nspecs nil)
1442 (expr (cadr (pop specs))) 1477 (expr (cadr (pop specs)))
1443 (temp (cdr (or (assq spec cl--loop-destr-temps) 1478 (temp
1444 (car (push (cons spec (or (last spec 0) 1479 (cdr (or (assq spec cl--loop-destr-temps)
1445 (make-symbol "--cl-var--"))) 1480 (car (push (cons spec
1446 cl--loop-destr-temps)))))) 1481 (or (last spec 0)
1482 (make-symbol "--cl-var--")))
1483 cl--loop-destr-temps))))))
1447 (push (list temp expr) new) 1484 (push (list temp expr) new)
1448 (while (consp spec) 1485 (while (consp spec)
1449 (push (list (pop spec) 1486 (push (list (pop spec)
@@ -1452,24 +1489,27 @@ Valid clauses are:
1452 (setq specs (nconc (nreverse nspecs) specs))) 1489 (setq specs (nconc (nreverse nspecs) specs)))
1453 (push (pop specs) new))) 1490 (push (pop specs) new)))
1454 (if (eq body 'setq) 1491 (if (eq body 'setq)
1455 (let ((set (cons (if par 'cl-psetq 'setq) (apply 'nconc (nreverse new))))) 1492 (let ((set (cons (if par 'cl-psetq 'setq)
1493 (apply 'nconc (nreverse new)))))
1456 (if temps `(let* ,(nreverse temps) ,set) set)) 1494 (if temps `(let* ,(nreverse temps) ,set) set))
1457 `(,(if par 'let 'let*) 1495 `(,(if par 'let 'let*)
1458 ,(nconc (nreverse temps) (nreverse new)) ,@body)))) 1496 ,(nconc (nreverse temps) (nreverse new)) ,@body))))
1459 1497
1460(defun cl--loop-handle-accum (def &optional func) ; uses loop-* 1498(defun cl--loop-handle-accum (def &optional func) ; uses loop-*
1461 (if (eq (car cl--loop-args) 'into) 1499 (if (eq (car cl--loop-args) 'into)
1462 (let ((var (cl-pop2 cl--loop-args))) 1500 (let ((var (cl--pop2 cl--loop-args)))
1463 (or (memq var cl--loop-accum-vars) 1501 (or (memq var cl--loop-accum-vars)
1464 (progn (push (list (list var def)) cl--loop-bindings) 1502 (progn (push (list (list var def)) cl--loop-bindings)
1465 (push var cl--loop-accum-vars))) 1503 (push var cl--loop-accum-vars)))
1466 var) 1504 var)
1467 (or cl--loop-accum-var 1505 (or cl--loop-accum-var
1468 (progn 1506 (progn
1469 (push (list (list (setq cl--loop-accum-var (make-symbol "--cl-var--")) def)) 1507 (push (list (list
1470 cl--loop-bindings) 1508 (setq cl--loop-accum-var (make-symbol "--cl-var--"))
1509 def))
1510 cl--loop-bindings)
1471 (setq cl--loop-result (if func (list func cl--loop-accum-var) 1511 (setq cl--loop-result (if func (list func cl--loop-accum-var)
1472 cl--loop-accum-var)) 1512 cl--loop-accum-var))
1473 cl--loop-accum-var)))) 1513 cl--loop-accum-var))))
1474 1514
1475(defun cl--loop-build-ands (clauses) 1515(defun cl--loop-build-ands (clauses)
@@ -1516,7 +1556,7 @@ such that COMBO is equivalent to (and . CLAUSES)."
1516 ((&rest &or symbolp (symbolp &optional form form)) 1556 ((&rest &or symbolp (symbolp &optional form form))
1517 (form body) 1557 (form body)
1518 cl-declarations body))) 1558 cl-declarations body)))
1519 (cl-expand-do-loop steps endtest body nil)) 1559 (cl--expand-do-loop steps endtest body nil))
1520 1560
1521;;;###autoload 1561;;;###autoload
1522(defmacro cl-do* (steps endtest &rest body) 1562(defmacro cl-do* (steps endtest &rest body)
@@ -1524,9 +1564,9 @@ such that COMBO is equivalent to (and . CLAUSES)."
1524 1564
1525\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" 1565\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
1526 (declare (indent 2) (debug cl-do)) 1566 (declare (indent 2) (debug cl-do))
1527 (cl-expand-do-loop steps endtest body t)) 1567 (cl--expand-do-loop steps endtest body t))
1528 1568
1529(defun cl-expand-do-loop (steps endtest body star) 1569(defun cl--expand-do-loop (steps endtest body star)
1530 `(cl-block nil 1570 `(cl-block nil
1531 (,(if star 'let* 'let) 1571 (,(if star 'let* 'let)
1532 ,(mapcar (lambda (c) (if (consp c) (list (car c) (nth 1 c)) c)) 1572 ,(mapcar (lambda (c) (if (consp c) (list (car c) (nth 1 c)) c))
@@ -1620,19 +1660,18 @@ second list (or to nil if VALUES is shorter than SYMBOLS); then the
1620BODY forms are executed and their result is returned. This is much like 1660BODY forms are executed and their result is returned. This is much like
1621a `let' form, except that the list of symbols can be computed at run-time." 1661a `let' form, except that the list of symbols can be computed at run-time."
1622 (declare (indent 2) (debug (form form body))) 1662 (declare (indent 2) (debug (form form body)))
1623 (let ((bodyfun (make-symbol "cl--progv-body")) 1663 (let ((bodyfun (make-symbol "body"))
1624 (binds (make-symbol "binds")) 1664 (binds (make-symbol "binds"))
1625 (syms (make-symbol "syms")) 1665 (syms (make-symbol "syms"))
1626 (vals (make-symbol "vals"))) 1666 (vals (make-symbol "vals")))
1627 `(progn 1667 `(progn
1628 (defvar ,bodyfun)
1629 (let* ((,syms ,symbols) 1668 (let* ((,syms ,symbols)
1630 (,vals ,values) 1669 (,vals ,values)
1631 (,bodyfun (lambda () ,@body)) 1670 (,bodyfun (lambda () ,@body))
1632 (,binds ())) 1671 (,binds ()))
1633 (while ,syms 1672 (while ,syms
1634 (push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds)) 1673 (push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds))
1635 (eval (list 'let ,binds '(funcall ,bodyfun))))))) 1674 (eval (list 'let ,binds (list 'funcall (list 'quote ,bodyfun))))))))
1636 1675
1637(defvar cl--labels-convert-cache nil) 1676(defvar cl--labels-convert-cache nil)
1638 1677
@@ -1903,11 +1942,11 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C).
1903 (declare (indent 1) (debug (cl-type-spec form))) 1942 (declare (indent 1) (debug (cl-type-spec form)))
1904 form) 1943 form)
1905 1944
1906(defvar cl-proclaim-history t) ; for future compilers 1945(defvar cl--proclaim-history t) ; for future compilers
1907(defvar cl-declare-stack t) ; for future compilers 1946(defvar cl--declare-stack t) ; for future compilers
1908 1947
1909(defun cl-do-proclaim (spec hist) 1948(defun cl--do-proclaim (spec hist)
1910 (and hist (listp cl-proclaim-history) (push spec cl-proclaim-history)) 1949 (and hist (listp cl--proclaim-history) (push spec cl--proclaim-history))
1911 (cond ((eq (car-safe spec) 'special) 1950 (cond ((eq (car-safe spec) 'special)
1912 (if (boundp 'byte-compile-bound-variables) 1951 (if (boundp 'byte-compile-bound-variables)
1913 (setq byte-compile-bound-variables 1952 (setq byte-compile-bound-variables
@@ -1932,9 +1971,9 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C).
1932 '((0 nil) (1 t) (2 t) (3 t)))) 1971 '((0 nil) (1 t) (2 t) (3 t))))
1933 (safety (assq (nth 1 (assq 'safety (cdr spec))) 1972 (safety (assq (nth 1 (assq 'safety (cdr spec)))
1934 '((0 t) (1 t) (2 t) (3 nil))))) 1973 '((0 t) (1 t) (2 t) (3 nil)))))
1935 (if speed (setq cl-optimize-speed (car speed) 1974 (if speed (setq cl--optimize-speed (car speed)
1936 byte-optimize (nth 1 speed))) 1975 byte-optimize (nth 1 speed)))
1937 (if safety (setq cl-optimize-safety (car safety) 1976 (if safety (setq cl--optimize-safety (car safety)
1938 byte-compile-delete-errors (nth 1 safety))))) 1977 byte-compile-delete-errors (nth 1 safety)))))
1939 1978
1940 ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) 1979 ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings))
@@ -1946,10 +1985,10 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C).
1946 nil) 1985 nil)
1947 1986
1948;;; Process any proclamations made before cl-macs was loaded. 1987;;; Process any proclamations made before cl-macs was loaded.
1949(defvar cl-proclaims-deferred) 1988(defvar cl--proclaims-deferred)
1950(let ((p (reverse cl-proclaims-deferred))) 1989(let ((p (reverse cl--proclaims-deferred)))
1951 (while p (cl-do-proclaim (pop p) t)) 1990 (while p (cl--do-proclaim (pop p) t))
1952 (setq cl-proclaims-deferred nil)) 1991 (setq cl--proclaims-deferred nil))
1953 1992
1954;;;###autoload 1993;;;###autoload
1955(defmacro cl-declare (&rest specs) 1994(defmacro cl-declare (&rest specs)
@@ -1962,8 +2001,8 @@ will turn off byte-compile warnings in the function.
1962See Info node `(cl)Declarations' for details." 2001See Info node `(cl)Declarations' for details."
1963 (if (cl--compiling-file) 2002 (if (cl--compiling-file)
1964 (while specs 2003 (while specs
1965 (if (listp cl-declare-stack) (push (car specs) cl-declare-stack)) 2004 (if (listp cl--declare-stack) (push (car specs) cl--declare-stack))
1966 (cl-do-proclaim (pop specs) nil))) 2005 (cl--do-proclaim (pop specs) nil)))
1967 nil) 2006 nil)
1968 2007
1969;;; The standard modify macros. 2008;;; The standard modify macros.
@@ -2209,7 +2248,7 @@ value, that slot cannot be set via `setf'.
2209 (copier (intern (format "copy-%s" name))) 2248 (copier (intern (format "copy-%s" name)))
2210 (predicate (intern (format "%s-p" name))) 2249 (predicate (intern (format "%s-p" name)))
2211 (print-func nil) (print-auto nil) 2250 (print-func nil) (print-auto nil)
2212 (safety (if (cl--compiling-file) cl-optimize-safety 3)) 2251 (safety (if (cl--compiling-file) cl--optimize-safety 3))
2213 (include nil) 2252 (include nil)
2214 (tag (intern (format "cl-struct-%s" name))) 2253 (tag (intern (format "cl-struct-%s" name)))
2215 (tag-symbol (intern (format "cl-struct-%s-tags" name))) 2254 (tag-symbol (intern (format "cl-struct-%s-tags" name)))
@@ -2454,7 +2493,8 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc."
2454 (if (consp (cadr type)) `(> ,val ,(cl-caadr type)) 2493 (if (consp (cadr type)) `(> ,val ,(cl-caadr type))
2455 `(>= ,val ,(cadr type)))) 2494 `(>= ,val ,(cadr type))))
2456 ,(if (memq (cl-caddr type) '(* nil)) t 2495 ,(if (memq (cl-caddr type) '(* nil)) t
2457 (if (consp (cl-caddr type)) `(< ,val ,(cl-caaddr type)) 2496 (if (consp (cl-caddr type))
2497 `(< ,val ,(cl-caaddr type))
2458 `(<= ,val ,(cl-caddr type))))))) 2498 `(<= ,val ,(cl-caddr type)))))))
2459 ((memq (car type) '(and or not)) 2499 ((memq (car type) '(and or not))
2460 (cons (car type) 2500 (cons (car type)
@@ -2479,7 +2519,7 @@ TYPE is a Common Lisp-style type specifier."
2479STRING is an optional description of the desired type." 2519STRING is an optional description of the desired type."
2480 (declare (debug (place cl-type-spec &optional stringp))) 2520 (declare (debug (place cl-type-spec &optional stringp)))
2481 (and (or (not (cl--compiling-file)) 2521 (and (or (not (cl--compiling-file))
2482 (< cl-optimize-speed 3) (= cl-optimize-safety 3)) 2522 (< cl--optimize-speed 3) (= cl--optimize-safety 3))
2483 (let* ((temp (if (cl--simple-expr-p form 3) 2523 (let* ((temp (if (cl--simple-expr-p form 3)
2484 form (make-symbol "--cl-var--"))) 2524 form (make-symbol "--cl-var--")))
2485 (body `(or ,(cl--make-type-test temp type) 2525 (body `(or ,(cl--make-type-test temp type)
@@ -2499,7 +2539,7 @@ They are not evaluated unless the assertion fails. If STRING is
2499omitted, a default message listing FORM itself is used." 2539omitted, a default message listing FORM itself is used."
2500 (declare (debug (form &rest form))) 2540 (declare (debug (form &rest form)))
2501 (and (or (not (cl--compiling-file)) 2541 (and (or (not (cl--compiling-file))
2502 (< cl-optimize-speed 3) (= cl-optimize-safety 3)) 2542 (< cl--optimize-speed 3) (= cl--optimize-safety 3))
2503 (let ((sargs (and show-args 2543 (let ((sargs (and show-args
2504 (delq nil (mapcar (lambda (x) 2544 (delq nil (mapcar (lambda (x)
2505 (unless (macroexp-const-p x) 2545 (unless (macroexp-const-p x)
@@ -2695,14 +2735,14 @@ surrounded by (cl-block NAME ...).
2695 2735
2696;;; Things that are side-effect-free. 2736;;; Things that are side-effect-free.
2697(mapc (lambda (x) (put x 'side-effect-free t)) 2737(mapc (lambda (x) (put x 'side-effect-free t))
2698 '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd cl-lcm 2738 '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd
2699 cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem cl-subseq 2739 cl-lcm cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem
2700 cl-list-length cl-get cl-getf)) 2740 cl-subseq cl-list-length cl-get cl-getf))
2701 2741
2702;;; Things that are side-effect-and-error-free. 2742;;; Things that are side-effect-and-error-free.
2703(mapc (lambda (x) (put x 'side-effect-free 'error-free)) 2743(mapc (lambda (x) (put x 'side-effect-free 'error-free))
2704 '(eql cl-floatp-safe cl-list* cl-subst cl-acons cl-equalp cl-random-state-p 2744 '(eql cl-floatp-safe cl-list* cl-subst cl-acons cl-equalp
2705 copy-tree cl-sublis)) 2745 cl-random-state-p copy-tree cl-sublis))
2706 2746
2707 2747
2708(run-hooks 'cl-macs-load-hook) 2748(run-hooks 'cl-macs-load-hook)
diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el
index 1fa562e328a..b8fd3c29b5c 100644
--- a/lisp/emacs-lisp/cl-seq.el
+++ b/lisp/emacs-lisp/cl-seq.el
@@ -105,6 +105,9 @@
105 (eq (not (funcall cl-test ,x ,y)) cl-test-not) 105 (eq (not (funcall cl-test ,x ,y)) cl-test-not)
106 (eql ,x ,y))) 106 (eql ,x ,y)))
107 107
108;; Yuck! These vars are set/bound by cl--parsing-keywords to match :if :test
109;; and :key keyword args, and they are also accessed (sometimes) via dynamic
110;; scoping (and some of those accesses are from macro-expanded code).
108(defvar cl-test) (defvar cl-test-not) 111(defvar cl-test) (defvar cl-test-not)
109(defvar cl-if) (defvar cl-if-not) 112(defvar cl-if) (defvar cl-if-not)
110(defvar cl-key) 113(defvar cl-key)
@@ -333,7 +336,8 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
333 336
334(defun cl--delete-duplicates (cl-seq cl-keys cl-copy) 337(defun cl--delete-duplicates (cl-seq cl-keys cl-copy)
335 (if (listp cl-seq) 338 (if (listp cl-seq)
336 (cl--parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) 339 (cl--parsing-keywords
340 (:test :test-not :key (:start 0) :end :from-end :if)
337 () 341 ()
338 (if cl-from-end 342 (if cl-from-end
339 (let ((cl-p (nthcdr cl-start cl-seq)) cl-i) 343 (let ((cl-p (nthcdr cl-start cl-seq)) cl-i)
@@ -776,7 +780,8 @@ to avoid corrupting the original LIST1 and LIST2.
776 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) 780 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
777 (while cl-list2 781 (while cl-list2
778 (if (or cl-keys (numberp (car cl-list2))) 782 (if (or cl-keys (numberp (car cl-list2)))
779 (setq cl-list1 (apply 'cl-adjoin (car cl-list2) cl-list1 cl-keys)) 783 (setq cl-list1
784 (apply 'cl-adjoin (car cl-list2) cl-list1 cl-keys))
780 (or (memq (car cl-list2) cl-list1) 785 (or (memq (car cl-list2) cl-list1)
781 (push (car cl-list2) cl-list1))) 786 (push (car cl-list2) cl-list1)))
782 (pop cl-list2)) 787 (pop cl-list2))