mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-29 19:48:19 +00:00
Code Issues Releases Activity

Use lexical-binding for all of CL, and clean up its namespace.

Browse Source 
* 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.
This commit is contained in:
Stefan Monnier 2012-06-11 11:52:50 -04:00
parent 3017f87fbd
commit bb3faf5b98
10 changed files with 337 additions and 340 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
lisp/ChangeLog
View File

@ -1,3 +1,23 @@
2012-06-11 Stefan Monnier <monnier@iro.umontreal.ca>
* 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.
* 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.
* 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):
* emacs-lisp/cl-macs.el (cl--lambda-list-keywords): Use "cl--" prefix.
* edmacro.el (edmacro-mismatch): Simplify to remove dependence on
CL's internals.
2012-06-11 Michael Albinus <michael.albinus@gmx.de>
Sync with Tramp 2.2.6-pre.

35
lisp/edmacro.el
View File

@ -594,28 +594,19 @@ doubt, use whitespace."
Return nil if the sequences match. If one sequence is a prefix of the
other, the return value indicates the end of the shorted sequence.
\n(fn SEQ1 SEQ2 START1 END1 START2 END2)"
(let (cl-test cl-test-not cl-key cl-from-end)
(or cl-end1 (setq cl-end1 (length cl-seq1)))
(or cl-end2 (setq cl-end2 (length cl-seq2)))
(if cl-from-end
(progn
(while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
(cl-check-match (elt cl-seq1 (1- cl-end1))
(elt cl-seq2 (1- cl-end2))))
(setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2)))
(and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
(1- cl-end1)))
(let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
(cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
(while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
(cl-check-match (if cl-p1 (car cl-p1)
(aref cl-seq1 cl-start1))
(if cl-p2 (car cl-p2)
(aref cl-seq2 cl-start2))))
(setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
(and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
cl-start1)))))
(or cl-end1 (setq cl-end1 (length cl-seq1)))
(or cl-end2 (setq cl-end2 (length cl-seq2)))
(let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
(cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
(while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
(eql (if cl-p1 (car cl-p1)
(aref cl-seq1 cl-start1))
(if cl-p2 (car cl-p2)
(aref cl-seq2 cl-start2))))
(setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
(and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
cl-start1)))
(defun edmacro-subseq (seq start &optional end)
"Return the subsequence of SEQ from START to END.

6
lisp/emacs-lisp/bytecomp.el
View File

@ -1399,18 +1399,18 @@ extra args."
;; These aren't all aliases of subrs, so not trivial to
;; avoid hardwiring the list.
(not (memq func
'(cl-block-wrapper cl-block-throw
'(cl--block-wrapper cl--block-throw
multiple-value-call nth-value
copy-seq first second rest endp cl-member
;; These are included in generated code
;; that can't be called except at compile time
;; or unless cl is loaded anyway.
cl-defsubst-expand cl-struct-setf-expander
cl--defsubst-expand cl-struct-setf-expander
;; These would sometimes be warned about
;; but such warnings are never useful,
;; so don't warn about them.
macroexpand cl-macroexpand-all
cl-compiling-file))))
cl--compiling-file))))
(byte-compile-warn "function `%s' from cl package called at runtime"
func)))
form)

70
lisp/emacs-lisp/cl-extra.el
View File

@ -1,4 +1,4 @@
;;; cl-extra.el --- Common Lisp features, part 2
;;; cl-extra.el --- Common Lisp features, part 2 -*- lexical-binding: t -*-
;; Copyright (C) 1993, 2000-2012 Free Software Foundation, Inc.
@ -88,7 +88,7 @@ strings case-insensitively."
;;; Control structures.
;;;###autoload
(defun cl-mapcar-many (cl-func cl-seqs)
(defun cl--mapcar-many (cl-func cl-seqs)
(if (cdr (cdr cl-seqs))
(let* ((cl-res nil)
(cl-n (apply 'min (mapcar 'length cl-seqs)))
@ -222,7 +222,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
(not (apply 'cl-every cl-pred cl-seq cl-rest)))
;;;###autoload
(defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
(defun cl--map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
(or cl-base
(setq cl-base (copy-sequence [0])))
(map-keymap
@ -230,14 +230,14 @@ If so, return the true (non-nil) value returned by PREDICATE.
(lambda (cl-key cl-bind)
(aset cl-base (1- (length cl-base)) cl-key)
(if (keymapp cl-bind)
(cl-map-keymap-recursively
(cl--map-keymap-recursively
cl-func-rec cl-bind
(vconcat cl-base (list 0)))
(funcall cl-func-rec cl-base cl-bind))))
cl-map))
;;;###autoload
(defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
(defun cl--map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
(or cl-what (setq cl-what (current-buffer)))
(if (bufferp cl-what)
(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.
(setq cl-start cl-next)))))
;;;###autoload
(defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
(defun cl--map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
(or cl-buffer (setq cl-buffer (current-buffer)))
(if (fboundp 'overlay-lists)
@ -307,30 +307,30 @@ If so, return the true (non-nil) value returned by PREDICATE.
;;; Support for `cl-setf'.
;;;###autoload
(defun cl-set-frame-visible-p (frame val)
(defun cl--set-frame-visible-p (frame val)
(cond ((null val) (make-frame-invisible frame))
((eq val 'icon) (iconify-frame frame))
(t (make-frame-visible frame)))
val)
;;; Support for `cl-progv'.
(defvar cl-progv-save)
(defvar cl--progv-save)
;;;###autoload
(defun cl-progv-before (syms values)
(defun cl--progv-before (syms values)
(while syms
(push (if (boundp (car syms))
(cons (car syms) (symbol-value (car syms)))
(car syms)) cl-progv-save)
(car syms)) cl--progv-save)
(if values
(set (pop syms) (pop values))
(makunbound (pop syms)))))
(defun cl-progv-after ()
(while cl-progv-save
(if (consp (car cl-progv-save))
(set (car (car cl-progv-save)) (cdr (car cl-progv-save)))
(makunbound (car cl-progv-save)))
(pop cl-progv-save)))
(defun cl--progv-after ()
(while cl--progv-save
(if (consp (car cl--progv-save))
(set (car (car cl--progv-save)) (cdr (car cl--progv-save)))
(makunbound (car cl--progv-save)))
(pop cl--progv-save)))
;;; Numbers.
@ -469,8 +469,8 @@ If STATE is t, return a new state object seeded from the time of day."
;; Implementation limits.
(defun cl-finite-do (func a b)
(condition-case err
(defun cl--finite-do (func a b)
(condition-case _
(let ((res (funcall func a b))) ; check for IEEE infinity
(and (numberp res) (/= res (/ res 2)) res))
(arith-error nil)))
@ -485,25 +485,25 @@ This sets the values of: `cl-most-positive-float', `cl-most-negative-float',
(or cl-most-positive-float (not (numberp '2e1))
(let ((x '2e0) y z)
;; Find maximum exponent (first two loops are optimizations)
(while (cl-finite-do '* x x) (setq x (* x x)))
(while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
(while (cl-finite-do '+ x x) (setq x (+ x x)))
(while (cl--finite-do '* x x) (setq x (* x x)))
(while (cl--finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
(while (cl--finite-do '+ x x) (setq x (+ x x)))
(setq z x y (/ x 2))
;; Now cl-fill in 1's in the mantissa.
(while (and (cl-finite-do '+ x y) (/= (+ x y) x))
(while (and (cl--finite-do '+ x y) (/= (+ x y) x))
(setq x (+ x y) y (/ y 2)))
(setq cl-most-positive-float x
cl-most-negative-float (- x))
;; Divide down until mantissa starts rounding.
(setq x (/ x z) y (/ 16 z) x (* x y))
(while (condition-case err (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
(while (condition-case _ (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
(arith-error nil))
(setq x (/ x 2) y (/ y 2)))
(setq cl-least-positive-normalized-float y
cl-least-negative-normalized-float (- y))
;; Divide down until value underflows to zero.
(setq x (/ 1 z) y x)
(while (condition-case err (> (/ x 2) 0) (arith-error nil))
(while (condition-case _ (> (/ x 2) 0) (arith-error nil))
(setq x (/ x 2)))
(setq cl-least-positive-float x
cl-least-negative-float (- x))
@ -612,13 +612,13 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
(if plist (car (cdr plist)) def))))
;;;###autoload
(defun cl-set-getf (plist tag val)
(defun cl--set-getf (plist tag val)
(let ((p plist))
(while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p))))
(if p (progn (setcar (cdr p) val) plist) (cl-list* tag val plist))))
;;;###autoload
(defun cl-do-remf (plist tag)
(defun cl--do-remf (plist tag)
(let ((p (cdr plist)))
(while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
(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'.
(let ((plist (symbol-plist sym)))
(if (and plist (eq tag (car plist)))
(progn (setplist sym (cdr (cdr plist))) t)
(cl-do-remf plist tag))))
(cl--do-remf plist tag))))
;;; Some debugging aids.
@ -646,15 +646,15 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
(forward-sexp)
(delete-char 1))
(goto-char (1+ pt))
(cl-do-prettyprint)))
(cl--do-prettyprint)))
(defun cl-do-prettyprint ()
(defun cl--do-prettyprint ()
(skip-chars-forward " ")
(if (looking-at "(")
(let ((skip (or (looking-at "((") (looking-at "(prog")
(looking-at "(unwind-protect ")
(looking-at "(function (")
(looking-at "(cl-block-wrapper ")))
(looking-at "(cl--block-wrapper ")))
(two (or (looking-at "(defun ") (looking-at "(defmacro ")))
(let (or (looking-at "(let\\*? ") (looking-at "(while ")))
(set (looking-at "(p?set[qf] ")))
@ -664,21 +664,21 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
(and (>= (current-column) 78) (progn (backward-sexp) t))))
(let ((nl t))
(forward-char 1)
(cl-do-prettyprint)
(or skip (looking-at ")") (cl-do-prettyprint))
(or (not two) (looking-at ")") (cl-do-prettyprint))
(cl--do-prettyprint)
(or skip (looking-at ")") (cl--do-prettyprint))
(or (not two) (looking-at ")") (cl--do-prettyprint))
(while (not (looking-at ")"))
(if set (setq nl (not nl)))
(if nl (insert "\n"))
(lisp-indent-line)
(cl-do-prettyprint))
(cl--do-prettyprint))
(forward-char 1))))
(forward-sexp)))
;;;###autoload
(defun cl-prettyexpand (form &optional full)
(message "Expanding...")
(let ((cl-macroexpand-cmacs full) (cl-compiling-file full)
(let ((cl--compiling-file full)
(byte-compile-macro-environment nil))
(setq form (macroexpand-all form
(and (not full) '((cl-block) (cl-eval-when)))))

49
lisp/emacs-lisp/cl-lib.el
View File

@ -1,4 +1,4 @@
;;; cl-lib.el --- Common Lisp extensions for Emacs
;;; cl-lib.el --- Common Lisp extensions for Emacs -*- lexical-binding: t -*-
;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc.
@ -114,7 +114,7 @@ a future Emacs interpreter will be able to use it.")
(defun cl-unload-function ()
"Stop unloading of the Common Lisp extensions."
(message "Cannot unload the feature `cl'")
;; stop standard unloading!
;; Stop standard unloading!
t)
;;; Generalized variables.
@ -185,19 +185,19 @@ an element already on the list.
(list 'setq place (cl-list* 'cl-adjoin x place keys)))
(cl-list* 'cl-callf2 'cl-adjoin x place keys)))
(defun cl-set-elt (seq n val)
(defun cl--set-elt (seq n val)
(if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val)))
(defsubst cl-set-nthcdr (n list x)
(defsubst cl--set-nthcdr (n list x)
(if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list))
(defun cl-set-buffer-substring (start end val)
(defun cl--set-buffer-substring (start end val)
(save-excursion (delete-region start end)
(goto-char start)
(insert val)
val))
(defun cl-set-substring (str start end val)
(defun cl--set-substring (str start end val)
(if end (if (< end 0) (cl-incf end (length str)))
(setq end (length str)))
(if (< start 0) (cl-incf start (length str)))
@ -206,19 +206,10 @@ an element already on the list.
(and (< end (length str)) (substring str end))))
;;; Control structures.
;; These macros are so simple and so often-used that it's better to have
;; them all the time than to load them from cl-macs.el.
(defun cl-map-extents (&rest cl-args)
(apply 'cl-map-overlays cl-args))
;;; Blocks and exits.
(defalias 'cl-block-wrapper 'identity)
(defalias 'cl-block-throw 'throw)
(defalias 'cl--block-wrapper 'identity)
(defalias 'cl--block-throw 'throw)
;;; Multiple values.
@ -269,9 +260,9 @@ one value."
;;; Declarations.
(defvar cl-compiling-file nil)
(defun cl-compiling-file ()
(or cl-compiling-file
(defvar cl--compiling-file nil)
(defun cl--compiling-file ()
(or cl--compiling-file
(and (boundp 'byte-compile--outbuffer)
(bufferp (symbol-value 'byte-compile--outbuffer))
(equal (buffer-name (symbol-value 'byte-compile--outbuffer))
@ -287,7 +278,7 @@ one value."
(defmacro cl-declaim (&rest specs)
(let ((body (mapcar (function (lambda (x) (list 'cl-proclaim (list 'quote x))))
specs)))
(if (cl-compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body)
(if (cl--compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body)
(cons 'progn body)))) ; avoid loading cl-macs.el for cl-eval-when
@ -378,7 +369,7 @@ Call `cl-float-limits' to set this.")
(defalias 'cl-copy-seq 'copy-sequence)
(declare-function cl-mapcar-many "cl-extra" (cl-func cl-seqs))
(declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs))
(defun cl-mapcar (cl-func cl-x &rest cl-rest)
"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
\n(fn FUNCTION SEQ...)"
(if cl-rest
(if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest)))
(cl-mapcar-many cl-func (cons cl-x cl-rest))
(cl--mapcar-many cl-func (cons cl-x cl-rest))
(let ((cl-res nil) (cl-y (car cl-rest)))
(while (and cl-x cl-y)
(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."
(prog1 (nreverse res) (setcdr res list)))
(car list)))
(defun cl-maclisp-member (item list)
(while (and list (not (equal item (car list)))) (setq list (cdr list)))
list)
;; Autoloaded, but we have not loaded cl-loaddefs yet.
(declare-function cl-floor "cl-extra" (x &optional y))
(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.
\n(fn NEW OLD TREE [KEYWORD VALUE]...)"
(if (or cl-keys (and (numberp cl-old) (not (integerp cl-old))))
(apply 'cl-sublis (list (cons cl-old cl-new)) cl-tree cl-keys)
(cl-do-subst cl-new cl-old cl-tree)))
(cl--do-subst cl-new cl-old cl-tree)))
(defun cl-do-subst (cl-new cl-old cl-tree)
(defun cl--do-subst (cl-new cl-old cl-tree)
(cond ((eq cl-tree cl-old) cl-new)
((consp cl-tree)
(let ((a (cl-do-subst cl-new cl-old (car cl-tree)))
(d (cl-do-subst cl-new cl-old (cdr cl-tree))))
(let ((a (cl--do-subst cl-new cl-old (car cl-tree)))
(d (cl--do-subst cl-new cl-old (cdr cl-tree))))
(if (and (eq a (car cl-tree)) (eq d (cdr cl-tree)))
cl-tree (cons a d))))
(t cl-tree)))

32
lisp/emacs-lisp/cl-loaddefs.el
View File

@ -3,15 +3,15 @@
;;; Code:
;;;### (autoloads (cl-prettyexpand cl-remprop cl-do-remf cl-set-getf
;;;### (autoloads (cl-prettyexpand cl-remprop cl--do-remf cl--set-getf
;;;;;; cl-getf cl-get cl-tailp cl-list-length cl-nreconc cl-revappend
;;;;;; cl-concatenate cl-subseq cl-float-limits cl-random-state-p
;;;;;; cl-make-random-state cl-random cl-signum cl-rem cl-mod cl-round
;;;;;; cl-truncate cl-ceiling cl-floor cl-isqrt cl-lcm cl-gcd cl-progv-before
;;;;;; cl-set-frame-visible-p cl-map-overlays cl-map-intervals cl-map-keymap-recursively
;;;;;; cl-notevery cl-notany cl-every cl-some cl-mapcon cl-mapcan
;;;;;; cl-mapl cl-maplist cl-map cl-mapcar-many cl-equalp cl-coerce)
;;;;;; "cl-extra" "cl-extra.el" "6661c504c379dfde0c37a0f8e2ba6568")
;;;;;; cl-truncate cl-ceiling cl-floor cl-isqrt cl-lcm cl-gcd cl--progv-before
;;;;;; cl--set-frame-visible-p cl--map-overlays cl--map-intervals
;;;;;; cl--map-keymap-recursively cl-notevery cl-notany cl-every
;;;;;; cl-some cl-mapcon cl-mapcan cl-mapl cl-maplist cl-map cl--mapcar-many
;;;;;; cl-equalp cl-coerce) "cl-extra" "cl-extra.el" "1f486111e93d119ceb6e95c434e3fd4b")
;;; Generated autoloads from cl-extra.el
(autoload 'cl-coerce "cl-extra" "\
@ -28,7 +28,7 @@ strings case-insensitively.
\(fn X Y)" nil nil)
(autoload 'cl-mapcar-many "cl-extra" "\
(autoload 'cl--mapcar-many "cl-extra" "\
\(fn CL-FUNC CL-SEQS)" nil nil)
@ -82,27 +82,27 @@ Return true if PREDICATE is false of some element of SEQ or SEQs.
\(fn PREDICATE SEQ...)" nil nil)
(autoload 'cl-map-keymap-recursively "cl-extra" "\
(autoload 'cl--map-keymap-recursively "cl-extra" "\
\(fn CL-FUNC-REC CL-MAP &optional CL-BASE)" nil nil)
(autoload 'cl-map-intervals "cl-extra" "\
(autoload 'cl--map-intervals "cl-extra" "\
\(fn CL-FUNC &optional CL-WHAT CL-PROP CL-START CL-END)" nil nil)
(autoload 'cl-map-overlays "cl-extra" "\
(autoload 'cl--map-overlays "cl-extra" "\
\(fn CL-FUNC &optional CL-BUFFER CL-START CL-END CL-ARG)" nil nil)
(autoload 'cl-set-frame-visible-p "cl-extra" "\
(autoload 'cl--set-frame-visible-p "cl-extra" "\
\(fn FRAME VAL)" nil nil)
(autoload 'cl-progv-before "cl-extra" "\
(autoload 'cl--progv-before "cl-extra" "\
\(fn SYMS VALUES)" nil nil)
@ -232,12 +232,12 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
\(fn PROPLIST PROPNAME &optional DEFAULT)" nil nil)
(autoload 'cl-set-getf "cl-extra" "\
(autoload 'cl--set-getf "cl-extra" "\
\(fn PLIST TAG VAL)" nil nil)
(autoload 'cl-do-remf "cl-extra" "\
(autoload 'cl--do-remf "cl-extra" "\
\(fn PLIST TAG)" nil nil)
@ -265,7 +265,7 @@ Remove from SYMBOL's plist the property PROPNAME and its value.
;;;;;; cl-do* cl-do cl-loop cl-return-from cl-return cl-block cl-etypecase
;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when
;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp
;;;;;; cl-gensym) "cl-macs" "cl-macs.el" "9eb287dd2a8d20f1c6459a9d095fa335")
;;;;;; cl-gensym) "cl-macs" "cl-macs.el" "a8ede90b4a2ce9015d4b63254b4678a2")
;;; Generated autoloads from cl-macs.el
(autoload 'cl-gensym "cl-macs" "\
@ -791,7 +791,7 @@ surrounded by (cl-block NAME ...).
;;;;;; cl-nsubstitute-if cl-nsubstitute cl-substitute-if-not cl-substitute-if
;;;;;; cl-substitute cl-delete-duplicates cl-remove-duplicates cl-delete-if-not
;;;;;; cl-delete-if cl-delete cl-remove-if-not cl-remove-if cl-remove
;;;;;; cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "8877479cb008b43a94098f3e6ec85d91")
;;;;;; cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "b444601641dcbd14a23ca5182bc80ffa")
;;; Generated autoloads from cl-seq.el
(autoload 'cl-reduce "cl-seq" "\

188
lisp/emacs-lisp/cl-macs.el
View File

@ -203,6 +203,65 @@ The name is made by appending a number to PREFIX, default \"G\"."
(def-edebug-spec cl-&key-arg
(&or ([&or (symbolp arg) arg] &optional def-form arg) arg))
(defconst cl--lambda-list-keywords
'(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote)
(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms)
(defun cl--transform-lambda (form bind-block)
(let* ((args (car form)) (body (cdr form)) (orig-args args)
(cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil)
(cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil)
(header nil) (simple-args nil))
(while (or (stringp (car body))
(memq (car-safe (car body)) '(interactive cl-declare)))
(push (pop body) header))
(setq args (if (listp args) (cl-copy-list args) (list '&rest args)))
(let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
(if (setq cl--bind-defs (cadr (memq '&cl-defs args)))
(setq args (delq '&cl-defs (delq cl--bind-defs args))
cl--bind-defs (cadr cl--bind-defs)))
(if (setq cl--bind-enquote (memq '&cl-quote args))
(setq args (delq '&cl-quote args)))
(if (memq '&whole args) (error "&whole not currently implemented"))
(let* ((p (memq '&environment args)) (v (cadr p))
(env-exp 'macroexpand-all-environment))
(if p (setq args (nconc (delq (car p) (delq v args))
(list '&aux (list v env-exp))))))
(while (and args (symbolp (car args))
(not (memq (car args) '(nil &rest &body &key &aux)))
(not (and (eq (car args) '&optional)
(or cl--bind-defs (consp (cadr args))))))
(push (pop args) simple-args))
(or (eq cl--bind-block 'cl-none)
(setq body (list `(cl-block ,cl--bind-block ,@body))))
(if (null args)
(cl-list* nil (nreverse simple-args) (nconc (nreverse header) body))
(if (memq '&optional simple-args) (push '&optional args))
(cl--do-arglist args nil (- (length simple-args)
(if (memq '&optional simple-args) 1 0)))
(setq cl--bind-lets (nreverse cl--bind-lets))
(cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval)
,@(nreverse cl--bind-inits)))
(nconc (nreverse simple-args)
(list '&rest (car (pop cl--bind-lets))))
(nconc (let ((hdr (nreverse header)))
;; Macro expansion can take place in the middle of
;; apparently harmless computation, so it should not
;; touch the match-data.
(save-match-data
(require 'help-fns)
(cons (help-add-fundoc-usage
(if (stringp (car hdr)) (pop hdr))
(format "%S"
(cons 'fn
(cl--make-usage-args orig-args))))
hdr)))
(list `(let* ,cl--bind-lets
,@(nreverse cl--bind-forms)
,@body)))))))
;;;###autoload
(defmacro cl-defun (name args &rest body)
"Define NAME as a function.
@ -307,12 +366,6 @@ its argument list allows full Common Lisp conventions."
`(progn ,@(cdr (cdr (car res)))
(put ',func ',prop #'(lambda . ,(cdr res))))))
(defconst cl-lambda-list-keywords
'(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote)
(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms)
(declare-function help-add-fundoc-usage "help-fns" (docstring arglist))
(defun cl--make-usage-var (x)
@ -346,62 +399,9 @@ its argument list allows full Common Lisp conventions."
))))
arglist)))
(defun cl--transform-lambda (form bind-block)
(let* ((args (car form)) (body (cdr form)) (orig-args args)
(cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil)
(cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil)
(header nil) (simple-args nil))
(while (or (stringp (car body))
(memq (car-safe (car body)) '(interactive cl-declare)))
(push (pop body) header))
(setq args (if (listp args) (cl-copy-list args) (list '&rest args)))
(let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
(if (setq cl--bind-defs (cadr (memq '&cl-defs args)))
(setq args (delq '&cl-defs (delq cl--bind-defs args))
cl--bind-defs (cadr cl--bind-defs)))
(if (setq cl--bind-enquote (memq '&cl-quote args))
(setq args (delq '&cl-quote args)))
(if (memq '&whole args) (error "&whole not currently implemented"))
(let* ((p (memq '&environment args)) (v (cadr p))
(env-exp 'macroexpand-all-environment))
(if p (setq args (nconc (delq (car p) (delq v args))
(list '&aux (list v env-exp))))))
(while (and args (symbolp (car args))
(not (memq (car args) '(nil &rest &body &key &aux)))
(not (and (eq (car args) '&optional)
(or cl--bind-defs (consp (cadr args))))))
(push (pop args) simple-args))
(or (eq cl--bind-block 'cl-none)
(setq body (list `(cl-block ,cl--bind-block ,@body))))
(if (null args)
(cl-list* nil (nreverse simple-args) (nconc (nreverse header) body))
(if (memq '&optional simple-args) (push '&optional args))
(cl--do-arglist args nil (- (length simple-args)
(if (memq '&optional simple-args) 1 0)))
(setq cl--bind-lets (nreverse cl--bind-lets))
(cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval)
,@(nreverse cl--bind-inits)))
(nconc (nreverse simple-args)
(list '&rest (car (pop cl--bind-lets))))
(nconc (let ((hdr (nreverse header)))
;; Macro expansion can take place in the middle of
;; apparently harmless computation, so it should not
;; touch the match-data.
(save-match-data
(require 'help-fns)
(cons (help-add-fundoc-usage
(if (stringp (car hdr)) (pop hdr))
(format "%S"
(cons 'fn
(cl--make-usage-args orig-args))))
hdr)))
(list `(let* ,cl--bind-lets
,@(nreverse cl--bind-forms)
,@body)))))))
(defun cl--do-arglist (args expr &optional num) ; uses bind-*
(if (nlistp args)
(if (or (memq args cl-lambda-list-keywords) (not (symbolp args)))
(if (or (memq args cl--lambda-list-keywords) (not (symbolp args)))
(error "Invalid argument name: %s" args)
(push (list args expr) cl--bind-lets))
(setq args (cl-copy-list args))
@ -410,7 +410,7 @@ its argument list allows full Common Lisp conventions."
(if (memq '&environment args) (error "&environment used incorrectly"))
(let ((save-args args)
(restarg (memq '&rest args))
(safety (if (cl-compiling-file) cl-optimize-safety 3))
(safety (if (cl--compiling-file) cl-optimize-safety 3))
(keys nil)
(laterarg nil) (exactarg nil) minarg)
(or num (setq num 0))
@ -422,14 +422,14 @@ its argument list allows full Common Lisp conventions."
(push (list (cl-pop2 args) restarg) cl--bind-lets))
(let ((p args))
(setq minarg restarg)
(while (and p (not (memq (car p) cl-lambda-list-keywords)))
(while (and p (not (memq (car p) cl--lambda-list-keywords)))
(or (eq p args) (setq minarg (list 'cdr minarg)))
(setq p (cdr p)))
(if (memq (car p) '(nil &aux))
(setq minarg `(= (length ,restarg)
,(length (cl-ldiff args p)))
exactarg (not (eq args p)))))
(while (and args (not (memq (car args) cl-lambda-list-keywords)))
(while (and args (not (memq (car args) cl--lambda-list-keywords)))
(let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
restarg)))
(cl--do-arglist
@ -442,7 +442,7 @@ its argument list allows full Common Lisp conventions."
(length ,restarg)))))))
(setq num (1+ num) laterarg t))
(while (and (eq (car args) '&optional) (pop args))
(while (and args (not (memq (car args) cl-lambda-list-keywords)))
(while (and args (not (memq (car args) cl--lambda-list-keywords)))
(let ((arg (pop args)))
(or (consp arg) (setq arg (list arg)))
(if (cddr arg) (cl--do-arglist (nth 2 arg) `(and ,restarg t)))
@ -466,7 +466,7 @@ its argument list allows full Common Lisp conventions."
(+ ,num (length ,restarg)))))
cl--bind-forms)))
(while (and (eq (car args) '&key) (pop args))
(while (and args (not (memq (car args) cl-lambda-list-keywords)))
(while (and args (not (memq (car args) cl--lambda-list-keywords)))
(let ((arg (pop args)))
(or (consp arg) (setq arg (list arg)))
(let* ((karg (if (consp (car arg)) (caar arg)
@ -511,7 +511,7 @@ its argument list allows full Common Lisp conventions."
(car ,var)))))))
(push `(let ((,var ,restarg)) ,check) cl--bind-forms)))
(while (and (eq (car args) '&aux) (pop args))
(while (and args (not (memq (car args) cl-lambda-list-keywords)))
(while (and args (not (memq (car args) cl--lambda-list-keywords)))
(if (consp (car args))
(if (and cl--bind-enquote (cl-cadar args))
(cl--do-arglist (caar args)
@ -525,7 +525,7 @@ its argument list allows full Common Lisp conventions."
(let ((res nil) (kind nil) arg)
(while (consp args)
(setq arg (pop args))
(if (memq arg cl-lambda-list-keywords) (setq kind arg)
(if (memq arg cl--lambda-list-keywords) (setq kind arg)
(if (eq arg '&cl-defs) (pop args)
(and (consp arg) kind (setq arg (car arg)))
(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.
\(fn (WHEN...) BODY...)"
(declare (indent 1) (debug ((&rest &or "compile" "load" "eval") body)))
(if (and (fboundp 'cl-compiling-file) (cl-compiling-file)
(if (and (fboundp 'cl--compiling-file) (cl--compiling-file)
(not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge
(let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
(cl-not-toplevel t))
@ -586,7 +586,7 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.
"Like `progn', but evaluates the body at load time.
The result of the body appears to the compiler as a quoted constant."
(declare (debug (form &optional sexp)))
(if (cl-compiling-file)
(if (cl--compiling-file)
(let* ((temp (cl-gentemp "--cl-load-time--"))
(set `(set ',temp ,form)))
(if (and (fboundp 'byte-compile-file-form-defmumble)
@ -700,7 +700,7 @@ references may appear inside macro expansions, but not inside functions
called from BODY."
(declare (indent 1) (debug (symbolp body)))
(if (cl--safe-expr-p `(progn ,@body)) `(progn ,@body)
`(cl-block-wrapper
`(cl--block-wrapper
(catch ',(intern (format "--cl-block-%s--" name))
,@body))))
@ -720,7 +720,7 @@ This is compatible with Common Lisp, but note that `defun' and
`defmacro' do not create implicit blocks as they do in Common Lisp."
(declare (indent 1) (debug (symbolp &optional form)))
(let ((name2 (intern (format "--cl-block-%s--" name))))
`(cl-block-throw ',name2 ,result)))
`(cl--block-throw ',name2 ,result)))
;;; The "cl-loop" macro.
@ -1151,7 +1151,7 @@ Valid clauses are:
((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args)))
(t (setq buf (cl-pop2 cl--loop-args)))))
(setq cl--loop-map-form
`(cl-map-extents
`(cl--map-overlays
(lambda (,var ,(make-symbol "--cl-var--"))
(progn . --cl-map) nil)
,buf ,from ,to))))
@ -1170,7 +1170,7 @@ Valid clauses are:
(setq var1 (car var) var2 (cdr var))
(push (list var `(cons ,var1 ,var2)) loop-for-sets))
(setq cl--loop-map-form
`(cl-map-intervals
`(cl--map-intervals
(lambda (,var1 ,var2) . --cl-map)
,buf ,prop ,from ,to))))
@ -1188,7 +1188,7 @@ Valid clauses are:
(setq var (prog1 other (setq other var))))
(setq cl--loop-map-form
`(,(if (memq word '(key-seq key-seqs))
'cl-map-keymap-recursively 'map-keymap)
'cl--map-keymap-recursively 'map-keymap)
(lambda (,var ,other) . --cl-map) ,cl-map))))
((memq word '(frame frames screen screens))
@ -1606,10 +1606,10 @@ second list (or made unbound if VALUES is shorter than SYMBOLS); then the
BODY forms are executed and their result is returned. This is much like
a `let' form, except that the list of symbols can be computed at run-time."
(declare (indent 2) (debug (form form body)))
`(let ((cl-progv-save nil))
`(let ((cl--progv-save nil))
(unwind-protect
(progn (cl-progv-before ,symbols ,values) ,@body)
(cl-progv-after))))
(progn (cl--progv-before ,symbols ,values) ,@body)
(cl--progv-after))))
(defvar cl--labels-convert-cache nil)
@ -1868,7 +1868,7 @@ For instance
will turn off byte-compile warnings in the function.
See Info node `(cl)Declarations' for details."
(if (cl-compiling-file)
(if (cl--compiling-file)
(while specs
(if (listp cl-declare-stack) (push (car specs) cl-declare-stack))
(cl-do-proclaim (pop specs) nil)))
@ -2028,7 +2028,7 @@ Example:
(cl-defsetf buffer-name rename-buffer t)
(cl-defsetf buffer-string () (store)
`(progn (erase-buffer) (insert ,store)))
(cl-defsetf buffer-substring cl-set-buffer-substring)
(cl-defsetf buffer-substring cl--set-buffer-substring)
(cl-defsetf current-buffer set-buffer)
(cl-defsetf current-case-table set-case-table)
(cl-defsetf current-column move-to-column t)
@ -2050,7 +2050,7 @@ Example:
(cl-defsetf file-modes set-file-modes t)
(cl-defsetf frame-height set-screen-height t)
(cl-defsetf frame-parameters modify-frame-parameters t)
(cl-defsetf frame-visible-p cl-set-frame-visible-p)
(cl-defsetf frame-visible-p cl--set-frame-visible-p)
(cl-defsetf frame-width set-screen-width t)
(cl-defsetf frame-parameter set-frame-parameter t)
(cl-defsetf terminal-parameter set-terminal-parameter)
@ -2151,8 +2151,8 @@ Example:
(cons n (nth 1 method))
(list store-temp)
`(let ((,(car (nth 2 method))
(cl-set-nthcdr ,n-temp ,(nth 4 method)
,store-temp)))
(cl--set-nthcdr ,n-temp ,(nth 4 method)
,store-temp)))
,(nth 3 method) ,store-temp)
`(nthcdr ,n-temp ,(nth 4 method)))))
@ -2165,7 +2165,7 @@ Example:
(append (nth 1 method) (list tag def))
(list store-temp)
`(let ((,(car (nth 2 method))
(cl-set-getf ,(nth 4 method) ,tag-temp ,store-temp)))
(cl--set-getf ,(nth 4 method) ,tag-temp ,store-temp)))
,(nth 3 method) ,store-temp)
`(cl-getf ,(nth 4 method) ,tag-temp ,def-temp))))
@ -2178,8 +2178,8 @@ Example:
(append (nth 1 method) (list from to))
(list store-temp)
`(let ((,(car (nth 2 method))
(cl-set-substring ,(nth 4 method)
,from-temp ,to-temp ,store-temp)))
(cl--set-substring ,(nth 4 method)
,from-temp ,to-temp ,store-temp)))
,(nth 3 method) ,store-temp)
`(substring ,(nth 4 method) ,from-temp ,to-temp))))
@ -2325,7 +2325,7 @@ The form returns true if TAG was found and removed, nil otherwise."
(if (eq ,ttag (car ,tval))
(progn ,(cl-setf-do-store (nth 1 method) `(cddr ,tval))
t)
`(cl-do-remf ,tval ,ttag)))))
`(cl--do-remf ,tval ,ttag)))))
;;;###autoload
(defmacro cl-shiftf (place &rest args)
@ -2549,7 +2549,7 @@ value, that slot cannot be set via `cl-setf'.
(copier (intern (format "copy-%s" name)))
(predicate (intern (format "%s-p" name)))
(print-func nil) (print-auto nil)
(safety (if (cl-compiling-file) cl-optimize-safety 3))
(safety (if (cl--compiling-file) cl-optimize-safety 3))
(include nil)
(tag (intern (format "cl-struct-%s" name)))
(tag-symbol (intern (format "cl-struct-%s-tags" name)))
@ -2835,7 +2835,7 @@ TYPE is a Common Lisp-style type specifier."
"Verify that FORM is of type TYPE; signal an error if not.
STRING is an optional description of the desired type."
(declare (debug (place cl-type-spec &optional stringp)))
(and (or (not (cl-compiling-file))
(and (or (not (cl--compiling-file))
(< cl-optimize-speed 3) (= cl-optimize-safety 3))
(let* ((temp (if (cl--simple-expr-p form 3)
form (make-symbol "--cl-var--")))
@ -2854,7 +2854,7 @@ Other args STRING and ARGS... are arguments to be passed to `error'.
They are not evaluated unless the assertion fails. If STRING is
omitted, a default message listing FORM itself is used."
(declare (debug (form &rest form)))
(and (or (not (cl-compiling-file))
(and (or (not (cl--compiling-file))
(< cl-optimize-speed 3) (= cl-optimize-safety 3))
(let ((sargs (and show-args
(delq nil (mapcar (lambda (x)
@ -2919,7 +2919,7 @@ and then returning foo."
(defvar cl--active-block-names nil)
(cl-define-compiler-macro cl-block-wrapper (cl-form)
(cl-define-compiler-macro cl--block-wrapper (cl-form)
(let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil))
(cl--active-block-names (cons cl-entry cl--active-block-names))
(cl-body (macroexpand-all ;Performs compiler-macro expansions.
@ -2931,7 +2931,7 @@ and then returning foo."
`(catch ,(nth 1 cl-form) ,@(cdr cl-body))
cl-body)))
(cl-define-compiler-macro cl-block-throw (cl-tag cl-value)
(cl-define-compiler-macro cl--block-throw (cl-tag cl-value)
(let ((cl-found (assq (nth 1 cl-tag) cl--active-block-names)))
(if cl-found (setcdr cl-found t)))
`(throw ,cl-tag ,cl-value))
@ -2955,7 +2955,7 @@ surrounded by (cl-block NAME ...).
,(if (memq '&key args)
`(&whole cl-whole &cl-quote ,@args)
(cons '&cl-quote args))
(cl-defsubst-expand
(cl--defsubst-expand
',argns '(cl-block ,name ,@body)
;; We used to pass `simple' as
;; (not (or unsafe (cl-expr-access-order pbody argns)))
@ -2966,7 +2966,7 @@ surrounded by (cl-block NAME ...).
,(and (memq '&key args) 'cl-whole) ,unsafe ,@argns)))
(cl-defun ,name ,args ,@body))))
(defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
(defun cl--defsubst-expand (argns body simple whole unsafe &rest argvs)
(if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole
(if (cl--simple-exprs-p argvs) (setq simple t))
(let* ((substs ())
@ -3059,7 +3059,7 @@ surrounded by (cl-block NAME ...).
;;; Things that are inline.
(cl-proclaim '(inline cl-floatp-safe cl-acons cl-map cl-concatenate cl-notany cl-notevery
cl-set-elt cl-revappend cl-nreconc gethash))
cl--set-elt cl-revappend cl-nreconc gethash))
;;; Things that are side-effect-free.
(mapc (lambda (x) (put x 'side-effect-free t))

267
lisp/emacs-lisp/cl-seq.el
View File

@ -1,4 +1,4 @@
;;; cl-seq.el --- Common Lisp features, part 3
;;; cl-seq.el --- Common Lisp features, part 3 -*- lexical-binding: t -*-
;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc.
@ -43,99 +43,91 @@
(require 'cl-lib)
;;; Keyword parsing. This is special-cased here so that we can compile
;;; this file independent from cl-macs.
;; Keyword parsing.
;; This is special-cased here so that we can compile
;; this file independent from cl-macs.
(defmacro cl-parsing-keywords (kwords other-keys &rest body)
(defmacro cl--parsing-keywords (kwords other-keys &rest body)
(declare (indent 2) (debug (sexp sexp &rest form)))
(cons
'let*
(cons (mapcar
(function
(lambda (x)
(let* ((var (if (consp x) (car x) x))
(mem (list 'car (list 'cdr (list 'memq (list 'quote var)
'cl-keys)))))
(if (eq var :test-not)
(setq mem (list 'and mem (list 'setq 'cl-test mem) t)))
(if (eq var :if-not)
(setq mem (list 'and mem (list 'setq 'cl-if mem) t)))
(list (intern
(format "cl-%s" (substring (symbol-name var) 1)))
(if (consp x) (list 'or mem (car (cdr x))) mem)))))
kwords)
(append
(and (not (eq other-keys t))
(list
(list 'let '((cl-keys-temp cl-keys))
(list 'while 'cl-keys-temp
(list 'or (list 'memq '(car cl-keys-temp)
(list 'quote
(mapcar
(function
(lambda (x)
(if (consp x)
(car x) x)))
(append kwords
other-keys))))
'(car (cdr (memq (quote :allow-other-keys)
cl-keys)))
'(error "Bad keyword argument %s"
(car cl-keys-temp)))
'(setq cl-keys-temp (cdr (cdr cl-keys-temp)))))))
body))))
`(let* ,(mapcar
(lambda (x)
(let* ((var (if (consp x) (car x) x))
(mem `(car (cdr (memq ',var cl-keys)))))
(if (eq var :test-not)
(setq mem `(and ,mem (setq cl-test ,mem) t)))
(if (eq var :if-not)
(setq mem `(and ,mem (setq cl-if ,mem) t)))
(list (intern
(format "cl-%s" (substring (symbol-name var) 1)))
(if (consp x) `(or ,mem ,(car (cdr x))) mem))))
kwords)
,@(append
(and (not (eq other-keys t))
(list
(list 'let '((cl-keys-temp cl-keys))
(list 'while 'cl-keys-temp
(list 'or (list 'memq '(car cl-keys-temp)
(list 'quote
(mapcar
(function
(lambda (x)
(if (consp x)
(car x) x)))
(append kwords
other-keys))))
'(car (cdr (memq (quote :allow-other-keys)
cl-keys)))
'(error "Bad keyword argument %s"
(car cl-keys-temp)))
'(setq cl-keys-temp (cdr (cdr cl-keys-temp)))))))
body)))
(defmacro cl-check-key (x)
(defmacro cl--check-key (x) ;Expects `cl-key' in context of generated code.
(declare (debug edebug-forms))
(list 'if 'cl-key (list 'funcall 'cl-key x) x))
`(if cl-key (funcall cl-key ,x) ,x))
(defmacro cl-check-test-nokey (item x)
(defmacro cl--check-test-nokey (item x) ;cl-test cl-if cl-test-not cl-if-not.
(declare (debug edebug-forms))
(list 'cond
(list 'cl-test
(list 'eq (list 'not (list 'funcall 'cl-test item x))
'cl-test-not))
(list 'cl-if
(list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not))
(list 't (list 'if (list 'numberp item)
(list 'equal item x) (list 'eq item x)))))
`(cond
(cl-test (eq (not (funcall cl-test ,item ,x))
cl-test-not))
(cl-if (eq (not (funcall cl-if ,x)) cl-if-not))
(t (eql ,item ,x))))
(defmacro cl-check-test (item x)
(defmacro cl--check-test (item x) ;all of the above.
(declare (debug edebug-forms))
(list 'cl-check-test-nokey item (list 'cl-check-key x)))
`(cl--check-test-nokey ,item (cl--check-key ,x)))
(defmacro cl-check-match (x y)
(defmacro cl--check-match (x y) ;cl-key cl-test cl-test-not
(declare (debug edebug-forms))
(setq x (list 'cl-check-key x) y (list 'cl-check-key y))
(list 'if 'cl-test
(list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not)
(list 'if (list 'numberp x)
(list 'equal x y) (list 'eq x y))))
(setq x `(cl--check-key ,x) y `(cl--check-key ,y))
`(if cl-test
(eq (not (funcall cl-test ,x ,y)) cl-test-not)
(eql ,x ,y)))
(defvar cl-test) (defvar cl-test-not)
(defvar cl-if) (defvar cl-if-not)
(defvar cl-key)
;;;###autoload
(defun cl-reduce (cl-func cl-seq &rest cl-keys)
"Reduce two-argument FUNCTION across SEQ.
\nKeywords supported: :start :end :from-end :initial-value :key
\n(fn FUNCTION SEQ [KEYWORD VALUE]...)"
(cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) ()
(cl--parsing-keywords (:from-end (:start 0) :end :initial-value :key) ()
(or (listp cl-seq) (setq cl-seq (append cl-seq nil)))
(setq cl-seq (cl-subseq cl-seq cl-start cl-end))
(if cl-from-end (setq cl-seq (nreverse cl-seq)))
(let ((cl-accum (cond ((memq :initial-value cl-keys) cl-initial-value)
(cl-seq (cl-check-key (pop cl-seq)))
(cl-seq (cl--check-key (pop cl-seq)))
(t (funcall cl-func)))))
(if cl-from-end
(while cl-seq
(setq cl-accum (funcall cl-func (cl-check-key (pop cl-seq))
(setq cl-accum (funcall cl-func (cl--check-key (pop cl-seq))
cl-accum)))
(while cl-seq
(setq cl-accum (funcall cl-func cl-accum
(cl-check-key (pop cl-seq))))))
(cl--check-key (pop cl-seq))))))
cl-accum)))
;;;###autoload
@ -143,7 +135,7 @@
"Fill the elements of SEQ with ITEM.
\nKeywords supported: :start :end
\n(fn SEQ ITEM [KEYWORD VALUE]...)"
(cl-parsing-keywords ((:start 0) :end) ()
(cl--parsing-keywords ((:start 0) :end) ()
(if (listp seq)
(let ((p (nthcdr cl-start seq))
(n (if cl-end (- cl-end cl-start) 8000000)))
@ -164,14 +156,14 @@
SEQ1 is destructively modified, then returned.
\nKeywords supported: :start1 :end1 :start2 :end2
\n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)"
(cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) ()
(cl--parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) ()
(if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1))
(or (= cl-start1 cl-start2)
(let* ((cl-len (length cl-seq1))
(cl-n (min (- (or cl-end1 cl-len) cl-start1)
(- (or cl-end2 cl-len) cl-start2))))
(while (>= (setq cl-n (1- cl-n)) 0)
(cl-set-elt cl-seq1 (+ cl-start1 cl-n)
(cl--set-elt cl-seq1 (+ cl-start1 cl-n)
(elt cl-seq2 (+ cl-start2 cl-n))))))
(if (listp cl-seq1)
(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
to avoid corrupting the original SEQ.
\nKeywords supported: :test :test-not :key :count :start :end :from-end
\n(fn ITEM SEQ [KEYWORD VALUE]...)"
(cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
(cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end
(:start 0) :end) ()
(if (<= (or cl-count (setq cl-count 8000000)) 0)
cl-seq
@ -227,14 +219,14 @@ to avoid corrupting the original SEQ.
(setq cl-end (- (or cl-end 8000000) cl-start))
(if (= cl-start 0)
(while (and cl-seq (> cl-end 0)
(cl-check-test cl-item (car cl-seq))
(cl--check-test cl-item (car cl-seq))
(setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
(> (setq cl-count (1- cl-count)) 0))))
(if (and (> cl-count 0) (> cl-end 0))
(let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq)
(setq cl-end (1- cl-end)) (cdr cl-seq))))
(while (and cl-p (> cl-end 0)
(not (cl-check-test cl-item (car cl-p))))
(not (cl--check-test cl-item (car cl-p))))
(setq cl-p (cdr cl-p) cl-end (1- cl-end)))
(if (and cl-p (> cl-end 0))
(nconc (cl-ldiff cl-seq cl-p)
@ -271,7 +263,7 @@ to avoid corrupting the original SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
\nKeywords supported: :test :test-not :key :count :start :end :from-end
\n(fn ITEM SEQ [KEYWORD VALUE]...)"
(cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
(cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end
(:start 0) :end) ()
(if (<= (or cl-count (setq cl-count 8000000)) 0)
cl-seq
@ -291,7 +283,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
(progn
(while (and cl-seq
(> cl-end 0)
(cl-check-test cl-item (car cl-seq))
(cl--check-test cl-item (car cl-seq))
(setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
(> (setq cl-count (1- cl-count)) 0)))
(setq cl-end (1- cl-end)))
@ -299,7 +291,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
(if (and (> cl-count 0) (> cl-end 0))
(let ((cl-p (nthcdr cl-start cl-seq)))
(while (and (cdr cl-p) (> cl-end 0))
(if (cl-check-test cl-item (car (cdr cl-p)))
(if (cl--check-test cl-item (car (cdr cl-p)))
(progn
(setcdr cl-p (cdr (cdr cl-p)))
(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.
(defun cl--delete-duplicates (cl-seq cl-keys cl-copy)
(if (listp cl-seq)
(cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if)
(cl--parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if)
()
(if cl-from-end
(let ((cl-p (nthcdr cl-start cl-seq)) cl-i)
(setq cl-end (- (or cl-end (length cl-seq)) cl-start))
(while (> cl-end 1)
(setq cl-i 0)
(while (setq cl-i (cl--position (cl-check-key (car cl-p))
(while (setq cl-i (cl--position (cl--check-key (car cl-p))
(cdr cl-p) cl-i (1- cl-end)))
(if cl-copy (setq cl-seq (copy-sequence cl-seq)
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.
cl-seq)
(setq cl-end (- (or cl-end (length cl-seq)) cl-start))
(while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1)
(cl--position (cl-check-key (car cl-seq))
(cl--position (cl--check-key (car cl-seq))
(cdr cl-seq) 0 (1- cl-end)))
(setq cl-seq (cdr cl-seq) cl-end (1- cl-end)))
(let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq)
(setq cl-end (1- cl-end) cl-start 1) cl-seq)))
(while (and (cdr (cdr cl-p)) (> cl-end 1))
(if (cl--position (cl-check-key (car (cdr cl-p)))
(if (cl--position (cl--check-key (car (cdr cl-p)))
(cdr (cdr cl-p)) 0 (1- cl-end))
(progn
(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
to avoid corrupting the original SEQ.
\nKeywords supported: :test :test-not :key :count :start :end :from-end
\n(fn NEW OLD SEQ [KEYWORD VALUE]...)"
(cl-parsing-keywords (:test :test-not :key :if :if-not :count
(cl--parsing-keywords (:test :test-not :key :if :if-not :count
(:start 0) :end :from-end) ()
(if (or (eq cl-old cl-new)
(<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0))
@ -396,7 +388,7 @@ to avoid corrupting the original SEQ.
cl-seq
(setq cl-seq (copy-sequence cl-seq))
(or cl-from-end
(progn (cl-set-elt cl-seq cl-i cl-new)
(progn (cl--set-elt cl-seq cl-i cl-new)
(setq cl-i (1+ cl-i) cl-count (1- cl-count))))
(apply 'cl-nsubstitute cl-new cl-old cl-seq :count cl-count
:start cl-i cl-keys))))))
@ -425,14 +417,14 @@ to avoid corrupting the original SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
\nKeywords supported: :test :test-not :key :count :start :end :from-end
\n(fn NEW OLD SEQ [KEYWORD VALUE]...)"
(cl-parsing-keywords (:test :test-not :key :if :if-not :count
(cl--parsing-keywords (:test :test-not :key :if :if-not :count
(:start 0) :end :from-end) ()
(or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0)
(if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000)))
(let ((cl-p (nthcdr cl-start cl-seq)))
(setq cl-end (- (or cl-end 8000000) cl-start))
(while (and cl-p (> cl-end 0) (> cl-count 0))
(if (cl-check-test cl-old (car cl-p))
(if (cl--check-test cl-old (car cl-p))
(progn
(setcar cl-p cl-new)
(setq cl-count (1- cl-count))))
@ -441,12 +433,12 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
(if cl-from-end
(while (and (< cl-start cl-end) (> cl-count 0))
(setq cl-end (1- cl-end))
(if (cl-check-test cl-old (elt cl-seq cl-end))
(if (cl--check-test cl-old (elt cl-seq cl-end))
(progn
(cl-set-elt cl-seq cl-end cl-new)
(cl--set-elt cl-seq cl-end cl-new)
(setq cl-count (1- cl-count)))))
(while (and (< cl-start cl-end) (> cl-count 0))
(if (cl-check-test cl-old (aref cl-seq cl-start))
(if (cl--check-test cl-old (aref cl-seq cl-start))
(progn
(aset cl-seq cl-start cl-new)
(setq cl-count (1- cl-count))))
@ -500,7 +492,7 @@ Return the matching item, or nil if not found.
Return the index of the matching item, or nil if not found.
\nKeywords supported: :test :test-not :key :start :end :from-end
\n(fn ITEM SEQ [KEYWORD VALUE]...)"
(cl-parsing-keywords (:test :test-not :key :if :if-not
(cl--parsing-keywords (:test :test-not :key :if :if-not
(:start 0) :end :from-end) ()
(cl--position cl-item cl-seq cl-start cl-end cl-from-end)))
@ -510,7 +502,7 @@ Return the index of the matching item, or nil if not found.
(or cl-end (setq cl-end 8000000))
(let ((cl-res nil))
(while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end))
(if (cl-check-test cl-item (car cl-p))
(if (cl--check-test cl-item (car cl-p))
(setq cl-res cl-start))
(setq cl-p (cdr cl-p) cl-start (1+ cl-start)))
cl-res))
@ -518,10 +510,10 @@ Return the index of the matching item, or nil if not found.
(if cl-from-end
(progn
(while (and (>= (setq cl-end (1- cl-end)) cl-start)
(not (cl-check-test cl-item (aref cl-seq cl-end)))))
(not (cl--check-test cl-item (aref cl-seq cl-end)))))
(and (>= cl-end cl-start) cl-end))
(while (and (< cl-start cl-end)
(not (cl-check-test cl-item (aref cl-seq cl-start))))
(not (cl--check-test cl-item (aref cl-seq cl-start))))
(setq cl-start (1+ cl-start)))
(and (< cl-start cl-end) cl-start))))
@ -546,13 +538,13 @@ Return the index of the matching item, or nil if not found.
"Count the number of occurrences of ITEM in SEQ.
\nKeywords supported: :test :test-not :key :start :end
\n(fn ITEM SEQ [KEYWORD VALUE]...)"
(cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) ()
(cl--parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) ()
(let ((cl-count 0) cl-x)
(or cl-end (setq cl-end (length cl-seq)))
(if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq)))
(while (< cl-start cl-end)
(setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start)))
(if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count)))
(if (cl--check-test cl-item cl-x) (setq cl-count (1+ cl-count)))
(setq cl-start (1+ cl-start)))
cl-count)))
@ -577,14 +569,14 @@ Return nil if the sequences match. If one sequence is a prefix of the
other, the return value indicates the end of the shorter sequence.
\nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
\n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)"
(cl-parsing-keywords (:test :test-not :key :from-end
(cl--parsing-keywords (:test :test-not :key :from-end
(:start1 0) :end1 (:start2 0) :end2) ()
(or cl-end1 (setq cl-end1 (length cl-seq1)))
(or cl-end2 (setq cl-end2 (length cl-seq2)))
(if cl-from-end
(progn
(while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
(cl-check-match (elt cl-seq1 (1- cl-end1))
(cl--check-match (elt cl-seq1 (1- cl-end1))
(elt cl-seq2 (1- cl-end2))))
(setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2)))
(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.
(let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
(cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
(while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
(cl-check-match (if cl-p1 (car cl-p1)
(cl--check-match (if cl-p1 (car cl-p1)
(aref cl-seq1 cl-start1))
(if cl-p2 (car cl-p2)
(aref cl-seq2 cl-start2))))
@ -608,14 +600,14 @@ Return the index of the leftmost element of the first match found;
return nil if there are no matches.
\nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
\n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)"
(cl-parsing-keywords (:test :test-not :key :from-end
(cl--parsing-keywords (:test :test-not :key :from-end
(:start1 0) :end1 (:start2 0) :end2) ()
(or cl-end1 (setq cl-end1 (length cl-seq1)))
(or cl-end2 (setq cl-end2 (length cl-seq2)))
(if (>= cl-start1 cl-end1)
(if cl-from-end cl-end2 cl-start2)
(let* ((cl-len (- cl-end1 cl-start1))
(cl-first (cl-check-key (elt cl-seq1 cl-start1)))
(cl-first (cl--check-key (elt cl-seq1 cl-start1)))
(cl-if nil) cl-pos)
(setq cl-end2 (- cl-end2 (1- cl-len)))
(while (and (< cl-start2 cl-end2)
@ -636,7 +628,7 @@ This is a destructive function; it reuses the storage of SEQ if possible.
\n(fn SEQ PREDICATE [KEYWORD VALUE]...)"
(if (nlistp cl-seq)
(cl-replace cl-seq (apply 'cl-sort (append cl-seq nil) cl-pred cl-keys))
(cl-parsing-keywords (:key) ()
(cl--parsing-keywords (:key) ()
(if (memq cl-key '(nil identity))
(sort cl-seq cl-pred)
(sort cl-seq (function (lambda (cl-x cl-y)
@ -660,16 +652,15 @@ sequences, and PREDICATE is a `less-than' predicate on the elements.
\n(fn TYPE SEQ1 SEQ2 PREDICATE [KEYWORD VALUE]...)"
(or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil)))
(or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil)))
(cl-parsing-keywords (:key) ()
(cl--parsing-keywords (:key) ()
(let ((cl-res nil))
(while (and cl-seq1 cl-seq2)
(if (funcall cl-pred (cl-check-key (car cl-seq2))
(cl-check-key (car cl-seq1)))
(if (funcall cl-pred (cl--check-key (car cl-seq2))
(cl--check-key (car cl-seq1)))
(push (pop cl-seq2) cl-res)
(push (pop cl-seq1) cl-res)))
(cl-coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type))))
;;; See compiler macro in cl-macs.el
;;;###autoload
(defun cl-member (cl-item cl-list &rest cl-keys)
"Find the first occurrence of ITEM in LIST.
@ -678,8 +669,8 @@ Return the sublist of LIST whose car is ITEM.
\n(fn ITEM LIST [KEYWORD VALUE]...)"
(declare (compiler-macro cl--compiler-macro-member))
(if cl-keys
(cl-parsing-keywords (:test :test-not :key :if :if-not) ()
(while (and cl-list (not (cl-check-test cl-item (car cl-list))))
(cl--parsing-keywords (:test :test-not :key :if :if-not) ()
(while (and cl-list (not (cl--check-test cl-item (car cl-list))))
(setq cl-list (cdr cl-list)))
cl-list)
(if (and (numberp cl-item) (not (integerp cl-item)))
@ -705,12 +696,11 @@ Return the sublist of LIST whose car matches.
;;;###autoload
(defun cl--adjoin (cl-item cl-list &rest cl-keys)
(if (cl-parsing-keywords (:key) t
(apply 'cl-member (cl-check-key cl-item) cl-list cl-keys))
(if (cl--parsing-keywords (:key) t
(apply 'cl-member (cl--check-key cl-item) cl-list cl-keys))
cl-list
(cons cl-item cl-list)))
;;; See compiler macro in cl-macs.el
;;;###autoload
(defun cl-assoc (cl-item cl-alist &rest cl-keys)
"Find the first item whose car matches ITEM in LIST.
@ -718,10 +708,10 @@ Return the sublist of LIST whose car matches.
\n(fn ITEM LIST [KEYWORD VALUE]...)"
(declare (compiler-macro cl--compiler-macro-assoc))
(if cl-keys
(cl-parsing-keywords (:test :test-not :key :if :if-not) ()
(cl--parsing-keywords (:test :test-not :key :if :if-not) ()
(while (and cl-alist
(or (not (consp (car cl-alist)))
(not (cl-check-test cl-item (car (car cl-alist))))))
(not (cl--check-test cl-item (car (car cl-alist))))))
(setq cl-alist (cdr cl-alist)))
(and cl-alist (car cl-alist)))
(if (and (numberp cl-item) (not (integerp cl-item)))
@ -749,10 +739,10 @@ Return the sublist of LIST whose car matches.
\nKeywords supported: :test :test-not :key
\n(fn ITEM LIST [KEYWORD VALUE]...)"
(if (or cl-keys (numberp cl-item))
(cl-parsing-keywords (:test :test-not :key :if :if-not) ()
(cl--parsing-keywords (:test :test-not :key :if :if-not) ()
(while (and cl-alist
(or (not (consp (car cl-alist)))
(not (cl-check-test cl-item (cdr (car cl-alist))))))
(not (cl--check-test cl-item (cdr (car cl-alist))))))
(setq cl-alist (cdr cl-alist)))
(and cl-alist (car cl-alist)))
(rassq cl-item cl-alist)))
@ -813,13 +803,13 @@ to avoid corrupting the original LIST1 and LIST2.
\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
(and cl-list1 cl-list2
(if (equal cl-list1 cl-list2) cl-list1
(cl-parsing-keywords (:key) (:test :test-not)
(cl--parsing-keywords (:key) (:test :test-not)
(let ((cl-res nil))
(or (>= (length cl-list1) (length cl-list2))
(setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
(while cl-list2
(if (if (or cl-keys (numberp (car cl-list2)))
(apply 'cl-member (cl-check-key (car cl-list2))
(apply 'cl-member (cl--check-key (car cl-list2))
cl-list1 cl-keys)
(memq (car cl-list2) cl-list1))
(push (car cl-list2) cl-res))
@ -845,11 +835,11 @@ to avoid corrupting the original LIST1 and LIST2.
\nKeywords supported: :test :test-not :key
\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
(if (or (null cl-list1) (null cl-list2)) cl-list1
(cl-parsing-keywords (:key) (:test :test-not)
(cl--parsing-keywords (:key) (:test :test-not)
(let ((cl-res nil))
(while cl-list1
(or (if (or cl-keys (numberp (car cl-list1)))
(apply 'cl-member (cl-check-key (car cl-list1))
(apply 'cl-member (cl--check-key (car cl-list1))
cl-list2 cl-keys)
(memq (car cl-list1) cl-list2))
(push (car cl-list1) cl-res))
@ -901,9 +891,9 @@ I.e., if every element of LIST1 also appears in LIST2.
\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
(cond ((null cl-list1) t) ((null cl-list2) nil)
((equal cl-list1 cl-list2) t)
(t (cl-parsing-keywords (:key) (:test :test-not)
(t (cl--parsing-keywords (:key) (:test :test-not)
(while (and cl-list1
(apply 'cl-member (cl-check-key (car cl-list1))
(apply 'cl-member (cl--check-key (car cl-list1))
cl-list2 cl-keys))
(pop cl-list1))
(null cl-list1)))))
@ -949,24 +939,26 @@ Any element of TREE which matches is changed to NEW (via a call to `setcar').
\n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)"
(apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
(defvar cl--alist)
;;;###autoload
(defun cl-sublis (cl-alist cl-tree &rest cl-keys)
"Perform substitutions indicated by ALIST in TREE (non-destructively).
Return a copy of TREE with all matching elements replaced.
\nKeywords supported: :test :test-not :key
\n(fn ALIST TREE [KEYWORD VALUE]...)"
(cl-parsing-keywords (:test :test-not :key :if :if-not) ()
(cl-sublis-rec cl-tree)))
(cl--parsing-keywords (:test :test-not :key :if :if-not) ()
(let ((cl--alist cl-alist))
(cl--sublis-rec cl-tree))))
(defvar cl-alist)
(defun cl-sublis-rec (cl-tree) ; uses cl-alist/key/test*/if*
(let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist))
(while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
(defun cl--sublis-rec (cl-tree) ;Uses cl--alist cl-key/test*/if*.
(let ((cl-temp (cl--check-key cl-tree)) (cl-p cl--alist))
(while (and cl-p (not (cl--check-test-nokey (car (car cl-p)) cl-temp)))
(setq cl-p (cdr cl-p)))
(if cl-p (cdr (car cl-p))
(if (consp cl-tree)
(let ((cl-a (cl-sublis-rec (car cl-tree)))
(cl-d (cl-sublis-rec (cdr cl-tree))))
(let ((cl-a (cl--sublis-rec (car cl-tree)))
(cl-d (cl--sublis-rec (cdr cl-tree))))
(if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree)))
cl-tree
(cons cl-a cl-d)))
@ -978,20 +970,21 @@ Return a copy of TREE with all matching elements replaced.
Any matching element of TREE is changed via a call to `setcar'.
\nKeywords supported: :test :test-not :key
\n(fn ALIST TREE [KEYWORD VALUE]...)"
(cl-parsing-keywords (:test :test-not :key :if :if-not) ()
(let ((cl-hold (list cl-tree)))
(cl-nsublis-rec cl-hold)
(cl--parsing-keywords (:test :test-not :key :if :if-not) ()
(let ((cl-hold (list cl-tree))
(cl--alist cl-alist))
(cl--nsublis-rec cl-hold)
(car cl-hold))))
(defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if*
(defun cl--nsublis-rec (cl-tree) ;Uses cl--alist cl-key/test*/if*.
(while (consp cl-tree)
(let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist))
(while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
(let ((cl-temp (cl--check-key (car cl-tree))) (cl-p cl--alist))
(while (and cl-p (not (cl--check-test-nokey (car (car cl-p)) cl-temp)))
(setq cl-p (cdr cl-p)))
(if cl-p (setcar cl-tree (cdr (car cl-p)))
(if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree))))
(setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist)
(while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
(if (consp (car cl-tree)) (cl--nsublis-rec (car cl-tree))))
(setq cl-temp (cl--check-key (cdr cl-tree)) cl-p cl--alist)
(while (and cl-p (not (cl--check-test-nokey (car (car cl-p)) cl-temp)))
(setq cl-p (cdr cl-p)))
(if cl-p
(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'.
Atoms are compared by `eql'; cons cells are compared recursively.
\nKeywords supported: :test :test-not :key
\n(fn TREE1 TREE2 [KEYWORD VALUE]...)"
(cl-parsing-keywords (:test :test-not :key) ()
(cl-tree-equal-rec cl-x cl-y)))
(cl--parsing-keywords (:test :test-not :key) ()
(cl--tree-equal-rec cl-x cl-y)))
(defun cl-tree-equal-rec (cl-x cl-y)
(defun cl--tree-equal-rec (cl-x cl-y) ;Uses cl-key/test*.
(while (and (consp cl-x) (consp cl-y)
(cl-tree-equal-rec (car cl-x) (car cl-y)))
(cl--tree-equal-rec (car cl-x) (car cl-y)))
(setq cl-x (cdr cl-x) cl-y (cdr cl-y)))
(and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y)))
(and (not (consp cl-x)) (not (consp cl-y)) (cl--check-match cl-x cl-y)))
(run-hooks 'cl-seq-load-hook)

8
lisp/emacs-lisp/cl.el
View File

@ -337,6 +337,7 @@ The two cases that are handled are:
- closure-conversion of lambda expressions for `lexical-let'.
- renaming of F when it's a function defined via `cl-labels' or `labels'."
(require 'cl-macs)
(declare-function cl--expr-contains-any "cl-macs" (x y))
(cond
;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked
;; *after* handling `function', but we want to stop macroexpansion from
@ -460,7 +461,7 @@ go back to their previous definitions, or lack thereof).
(let ((func `(cl-function
(lambda ,(cadr x)
(cl-block ,(car x) ,@(cddr x))))))
(when (cl-compiling-file)
(when (cl--compiling-file)
;; Bug#411. It would be nice to fix this.
(and (get (car x) 'byte-compile)
(error "Byte-compiling a redefinition of `%s' \
@ -532,6 +533,11 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard.
(define-obsolete-function-alias 'cl-hash-table-p 'hash-table-p "24.2")
(define-obsolete-function-alias 'cl-hash-table-count 'hash-table-count "24.2")
(defun cl-maclisp-member (item list)
(declare (obsolete member "24.2"))
(while (and list (not (equal item (car list)))) (setq list (cdr list)))
list)
;; FIXME: More candidates: define-modify-macro, define-setf-expander.
(provide 'cl)

2
lisp/help-fns.el
View File

@ -510,7 +510,7 @@ suitable file is found, return nil."
(unless (looking-back "\n\n")
(terpri)))))
;; Note that list* etc do not get this property until
;; cl-hack-byte-compiler runs, after bytecomp is loaded.
;; cl--hack-byte-compiler runs, after bytecomp is loaded.
(when (and (symbolp function)
(eq (get function 'byte-compile)
'cl-byte-compile-compiler-macro))