summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/.gitignore2
-rw-r--r--lisp/emacs-lisp/cl-macs.el12
-rw-r--r--lisp/emacs-lisp/edebug.el26
-rw-r--r--lisp/emacs-lisp/ert.el173
-rw-r--r--lisp/emacs-lisp/map-ynp.el5
-rw-r--r--lisp/emacs-lisp/pcase.el17
6 files changed, 50 insertions, 185 deletions
diff --git a/lisp/emacs-lisp/.gitignore b/lisp/emacs-lisp/.gitignore
deleted file mode 100644
index 133e79e817a..00000000000
--- a/lisp/emacs-lisp/.gitignore
+++ /dev/null
@@ -1,2 +0,0 @@
-!*-loaddefs.el
-
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 3cf744f1245..c47c9b61030 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -1957,7 +1957,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
"Collect multiple return values.
FORM must return a list; the BODY is then executed with the first N elements
of this list bound (`let'-style) to each of the symbols SYM in turn. This
-is analogous to the Common Lisp `cl-multiple-value-bind' macro, using lists to
+is analogous to the Common Lisp `multiple-value-bind' macro, using lists to
simulate true multiple return values. For compatibility, (cl-values A B C) is
a synonym for (list A B C).
@@ -1975,7 +1975,7 @@ a synonym for (list A B C).
"Collect multiple return values.
FORM must return a list; the first N elements of this list are stored in
each of the symbols SYM in turn. This is analogous to the Common Lisp
-`cl-multiple-value-setq' macro, using lists to simulate true multiple return
+`multiple-value-setq' macro, using lists to simulate true multiple return
values. For compatibility, (cl-values A B C) is a synonym for (list A B C).
\(fn (SYM...) FORM)"
@@ -2002,7 +2002,7 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C).
(cons 'progn body))
;;;###autoload
(defmacro cl-the (_type form)
- "At present this ignores _TYPE and is simply equivalent to FORM."
+ "At present this ignores TYPE and is simply equivalent to FORM."
(declare (indent 1) (debug (cl-type-spec form)))
form)
@@ -2059,7 +2059,7 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C).
"Declare SPECS about the current function while compiling.
For instance
- \(cl-declare (warn 0))
+ (cl-declare (warn 0))
will turn off byte-compile warnings in the function.
See Info node `(cl)Declarations' for details."
@@ -2279,8 +2279,8 @@ KEYWORD can be one of :conc-name, :constructor, :copier, :predicate,
Each SLOT may instead take the form (SNAME SDEFAULT SOPTIONS...), where
SDEFAULT is the default value of that slot and SOPTIONS are keyword-value
pairs for that slot.
-Currently, only one keyword is supported, `:read-only'. If this has a non-nil
-value, that slot cannot be set via `setf'.
+Currently, only one keyword is supported, `:read-only'. If this has a
+non-nil value, that slot cannot be set via `setf'.
\(fn NAME SLOTS...)"
(declare (doc-string 2) (indent 1)
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 319af588eac..36c72f3a3bd 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -53,7 +53,7 @@
;;; Code:
(require 'macroexp)
-(eval-when-compile (require 'cl-lib))
+(require 'cl-lib)
(eval-when-compile (require 'pcase))
;;; Options
@@ -263,26 +263,6 @@ An extant spec symbol is a symbol that is not a function and has a
;;; Utilities
-;; Define edebug-gensym - from old cl.el
-(defvar edebug-gensym-index 0
- "Integer used by `edebug-gensym' to produce new names.")
-
-(defun edebug-gensym (&optional prefix)
- "Generate a fresh uninterned symbol.
-There is an optional argument, PREFIX. PREFIX is the string
-that begins the new name. Most people take just the default,
-except when debugging needs suggest otherwise."
- (if (null prefix)
- (setq prefix "G"))
- (let ((newsymbol nil)
- (newname ""))
- (while (not newsymbol)
- (setq newname (concat prefix (int-to-string edebug-gensym-index)))
- (setq edebug-gensym-index (+ edebug-gensym-index 1))
- (if (not (intern-soft newname))
- (setq newsymbol (make-symbol newname))))
- newsymbol))
-
(defun edebug-lambda-list-keywordp (object)
"Return t if OBJECT is a lambda list keyword.
A lambda list keyword is a symbol that starts with `&'."
@@ -1186,7 +1166,7 @@ Maybe clear the markers and delete the symbol's edebug property?"
;; Uses the dynamically bound vars edebug-def-name and edebug-def-args.
;; Do this after parsing since that may find a name.
(setq edebug-def-name
- (or edebug-def-name edebug-old-def-name (edebug-gensym "edebug-anon")))
+ (or edebug-def-name edebug-old-def-name (cl-gensym "edebug-anon")))
`(edebug-enter
(quote ,edebug-def-name)
,(if edebug-inside-func
@@ -1299,7 +1279,7 @@ expressions; a `progn' form will be returned enclosing these forms."
;; Set the name here if it was not set by edebug-make-enter-wrapper.
(setq edebug-def-name
- (or edebug-def-name edebug-old-def-name (edebug-gensym "edebug-anon")))
+ (or edebug-def-name edebug-old-def-name (cl-gensym "edebug-anon")))
;; Add this def as a dependent of containing def. Buggy.
'(if (and edebug-containing-def-name
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 656cb0a6a14..1f5edefea08 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -54,7 +54,7 @@
;;; Code:
-(eval-when-compile (require 'cl-lib))
+(require 'cl-lib)
(require 'button)
(require 'debug)
(require 'easymenu)
@@ -87,127 +87,6 @@
;;; Copies/reimplementations of cl functions.
-(defun ert--cl-do-remf (plist tag)
- "Copy of `cl-do-remf'. Modify PLIST by removing 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))))
-
-(defun ert--remprop (sym tag)
- "Copy of `cl-remprop'. Modify SYM's plist by removing TAG."
- (let ((plist (symbol-plist sym)))
- (if (and plist (eq tag (car plist)))
- (progn (setplist sym (cdr (cdr plist))) t)
- (ert--cl-do-remf plist tag))))
-
-(defun ert--remove-if-not (ert-pred ert-list)
- "A reimplementation of `remove-if-not'.
-
-ERT-PRED is a predicate, ERT-LIST is the input list."
- (cl-loop for ert-x in ert-list
- if (funcall ert-pred ert-x)
- collect ert-x))
-
-(defun ert--intersection (a b)
- "A reimplementation of `intersection'. Intersect the sets A and B.
-
-Elements are compared using `eql'."
- (cl-loop for x in a
- if (memql x b)
- collect x))
-
-(defun ert--set-difference (a b)
- "A reimplementation of `set-difference'. Subtract the set B from the set A.
-
-Elements are compared using `eql'."
- (cl-loop for x in a
- unless (memql x b)
- collect x))
-
-(defun ert--set-difference-eq (a b)
- "A reimplementation of `set-difference'. Subtract the set B from the set A.
-
-Elements are compared using `eq'."
- (cl-loop for x in a
- unless (memq x b)
- collect x))
-
-(defun ert--union (a b)
- "A reimplementation of `union'. Compute the union of the sets A and B.
-
-Elements are compared using `eql'."
- (append a (ert--set-difference b a)))
-
-(eval-and-compile
- (defvar ert--gensym-counter 0))
-
-(eval-and-compile
- (defun ert--gensym (&optional prefix)
- "Only allows string PREFIX, not compatible with CL."
- (unless prefix (setq prefix "G"))
- (make-symbol (format "%s%s"
- prefix
- (prog1 ert--gensym-counter
- (cl-incf ert--gensym-counter))))))
-
-(defun ert--coerce-to-vector (x)
- "Coerce X to a vector."
- (when (char-table-p x) (error "Not supported"))
- (if (vectorp x)
- x
- (vconcat x)))
-
-(cl-defun ert--remove* (x list &key key test)
- "Does not support all the keywords of remove*."
- (unless key (setq key #'identity))
- (unless test (setq test #'eql))
- (cl-loop for y in list
- unless (funcall test x (funcall key y))
- collect y))
-
-(defun ert--string-position (c s)
- "Return the position of the first occurrence of C in S, or nil if none."
- (cl-loop for i from 0
- for x across s
- when (eql x c) return i))
-
-(defun ert--mismatch (a b)
- "Return index of first element that differs between A and B.
-
-Like `mismatch'. Uses `equal' for comparison."
- (cond ((or (listp a) (listp b))
- (ert--mismatch (ert--coerce-to-vector a)
- (ert--coerce-to-vector b)))
- ((> (length a) (length b))
- (ert--mismatch b a))
- (t
- (let ((la (length a))
- (lb (length b)))
- (cl-assert (arrayp a) t)
- (cl-assert (arrayp b) t)
- (cl-assert (<= la lb) t)
- (cl-loop for i below la
- when (not (equal (aref a i) (aref b i))) return i
- finally (cl-return (if (/= la lb)
- la
- (cl-assert (equal a b) t)
- nil)))))))
-
-(defun ert--subseq (seq start &optional end)
- "Return a subsequence of SEQ from START to END."
- (when (char-table-p seq) (error "Not supported"))
- (let ((vector (substring (ert--coerce-to-vector seq) start end)))
- (cl-etypecase seq
- (vector vector)
- (string (concat vector))
- (list (append vector nil))
- (bool-vector (cl-loop with result
- = (make-bool-vector (length vector) nil)
- for i below (length vector) do
- (setf (aref result i) (aref vector i))
- finally (cl-return result)))
- (char-table (cl-assert nil)))))
-
(defun ert-equal-including-properties (a b)
"Return t if A and B have similar structure and contents.
@@ -258,7 +137,7 @@ Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'."
(defun ert-make-test-unbound (symbol)
"Make SYMBOL name no test. Return SYMBOL."
- (ert--remprop symbol 'ert--test)
+ (cl-remprop symbol 'ert--test)
symbol)
(defun ert--parse-keys-and-body (keys-and-body)
@@ -396,8 +275,8 @@ DATA is displayed to the user and should state the reason of the failure."
cl-macro-environment)))))
(cond
((or (atom form) (ert--special-operator-p (car form)))
- (let ((value (ert--gensym "value-")))
- `(let ((,value (ert--gensym "ert-form-evaluation-aborted-")))
+ (let ((value (cl-gensym "value-")))
+ `(let ((,value (cl-gensym "ert-form-evaluation-aborted-")))
,(funcall inner-expander
`(setq ,value ,form)
`(list ',whole :form ',form :value ,value)
@@ -410,10 +289,10 @@ DATA is displayed to the user and should state the reason of the failure."
(and (consp fn-name)
(eql (car fn-name) 'lambda)
(listp (cdr fn-name)))))
- (let ((fn (ert--gensym "fn-"))
- (args (ert--gensym "args-"))
- (value (ert--gensym "value-"))
- (default-value (ert--gensym "ert-form-evaluation-aborted-")))
+ (let ((fn (cl-gensym "fn-"))
+ (args (cl-gensym "args-"))
+ (value (cl-gensym "value-"))
+ (default-value (cl-gensym "ert-form-evaluation-aborted-")))
`(let ((,fn (function ,fn-name))
(,args (list ,@arg-forms)))
(let ((,value ',default-value))
@@ -450,7 +329,7 @@ FORM-DESCRIPTION-FORM before it has called INNER-FORM."
(ert--expand-should-1
whole form
(lambda (inner-form form-description-form value-var)
- (let ((form-description (ert--gensym "form-description-")))
+ (let ((form-description (cl-gensym "form-description-")))
`(let (,form-description)
,(funcall inner-expander
`(unwind-protect
@@ -491,7 +370,7 @@ and aborts the current test as failed if it doesn't."
(list type)
(symbol (list type)))))
(cl-assert signaled-conditions)
- (unless (ert--intersection signaled-conditions handled-conditions)
+ (unless (cl-intersection signaled-conditions handled-conditions)
(ert-fail (append
(funcall form-description-fn)
(list
@@ -528,8 +407,8 @@ failed."
`(should-error ,form ,@keys)
form
(lambda (inner-form form-description-form value-var)
- (let ((errorp (ert--gensym "errorp"))
- (form-description-fn (ert--gensym "form-description-fn-")))
+ (let ((errorp (cl-gensym "errorp"))
+ (form-description-fn (cl-gensym "form-description-fn-")))
`(let ((,errorp nil)
(,form-description-fn (lambda () ,form-description-form)))
(condition-case -condition-
@@ -591,7 +470,7 @@ Returns nil if they are."
`(proper-lists-of-different-length ,(length a) ,(length b)
,a ,b
first-mismatch-at
- ,(ert--mismatch a b))
+ ,(cl-mismatch a b :test 'equal))
(cl-loop for i from 0
for ai in a
for bi in b
@@ -611,7 +490,7 @@ Returns nil if they are."
,a ,b
,@(unless (char-table-p a)
`(first-mismatch-at
- ,(ert--mismatch a b))))
+ ,(cl-mismatch a b :test 'equal))))
(cl-loop for i from 0
for ai across a
for bi across b
@@ -656,8 +535,8 @@ key/value pairs in each list does not matter."
;; work, so let's punt on it for now.
(let* ((keys-a (ert--significant-plist-keys a))
(keys-b (ert--significant-plist-keys b))
- (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b))
- (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a)))
+ (keys-in-a-not-in-b (cl-set-difference keys-a keys-b :test 'eq))
+ (keys-in-b-not-in-a (cl-set-difference keys-b keys-a :test 'eq)))
(cl-flet ((explain-with-key (key)
(let ((value-a (plist-get a key))
(value-b (plist-get b key)))
@@ -1090,7 +969,7 @@ contained in UNIVERSE."
(cl-etypecase universe
((member t) (mapcar #'ert-get-test
(apropos-internal selector #'ert-test-boundp)))
- (list (ert--remove-if-not (lambda (test)
+ (list (cl-remove-if-not (lambda (test)
(and (ert-test-name test)
(string-match selector
(ert-test-name test))))
@@ -1123,13 +1002,13 @@ contained in UNIVERSE."
(not
(cl-assert (eql (length operands) 1))
(let ((all-tests (ert-select-tests 't universe)))
- (ert--set-difference all-tests
+ (cl-set-difference all-tests
(ert-select-tests (car operands)
all-tests))))
(or
(cl-case (length operands)
(0 (ert-select-tests 'nil universe))
- (t (ert--union (ert-select-tests (car operands) universe)
+ (t (cl-union (ert-select-tests (car operands) universe)
(ert-select-tests `(or ,@(cdr operands))
universe)))))
(tag
@@ -1141,7 +1020,7 @@ contained in UNIVERSE."
universe)))
(satisfies
(cl-assert (eql (length operands) 1))
- (ert--remove-if-not (car operands)
+ (cl-remove-if-not (car operands)
(ert-select-tests 't universe))))))))
(defun ert--insert-human-readable-selector (selector)
@@ -1285,7 +1164,7 @@ Also changes the counters in STATS to match."
"Create a new `ert--stats' object for running TESTS.
SELECTOR is the selector that was used to select TESTS."
- (setq tests (ert--coerce-to-vector tests))
+ (setq tests (cl-coerce tests 'vector))
(let ((map (make-hash-table :size (length tests))))
(cl-loop for i from 0
for test across tests
@@ -1548,10 +1427,10 @@ This can be used as an inverse of `add-to-list'."
(unless key (setq key #'identity))
(unless test (setq test #'equal))
(setf (symbol-value list-var)
- (ert--remove* element
- (symbol-value list-var)
- :key key
- :test test)))
+ (cl-remove element
+ (symbol-value list-var)
+ :key key
+ :test test)))
;;; Some basic interactive functions.
@@ -1810,7 +1689,7 @@ BEGIN and END specify a region in the current buffer."
"Return the first line of S, or S if it contains no newlines.
The return value does not include the line terminator."
- (substring s 0 (ert--string-position ?\n s)))
+ (substring s 0 (cl-position ?\n s)))
(defun ert-face-for-test-result (expectedp)
"Return a face that shows whether a test result was expected or unexpected.
diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
index 1919d47687b..56bfe04f9ce 100644
--- a/lisp/emacs-lisp/map-ynp.el
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -131,8 +131,9 @@ Returns the number of actions taken."
(unwind-protect
(progn
(if (stringp prompter)
- (setq prompter (lambda (object)
- (format prompter object))))
+ (setq prompter (let ((prompter prompter))
+ (lambda (object)
+ (format prompter object)))))
(while (funcall next)
(setq prompt (funcall prompter elt))
(cond ((stringp prompt)
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index e000c343721..511f1480099 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -482,12 +482,19 @@ MATCH is the pattern that needs to be matched, of the form:
all))
'(:pcase--succeed . nil))))
-(defun pcase--split-pred (upat pat)
- ;; FIXME: For predicates like (pred (> a)), two such predicates may
- ;; actually refer to different variables `a'.
+(defun pcase--split-pred (vars upat pat)
(let (test)
(cond
- ((equal upat pat) '(:pcase--succeed . :pcase--fail))
+ ((and (equal upat pat)
+ ;; For predicates like (pred (> a)), two such predicates may
+ ;; actually refer to different variables `a'.
+ (or (and (eq 'pred (car upat)) (symbolp (cadr upat)))
+ ;; FIXME: `vars' gives us the environment in which `upat' will
+ ;; run, but we don't have the environment in which `pat' will
+ ;; run, so we can't do a reliable verification. But let's try
+ ;; and catch at least the easy cases such as (bug#14773).
+ (not (pcase--fgrep (mapcar #'car vars) (cadr upat)))))
+ '(:pcase--succeed . :pcase--fail))
((and (eq 'pred (car upat))
(eq 'pred (car-safe pat))
(or (member (cons (cadr upat) (cadr pat))
@@ -589,7 +596,7 @@ Otherwise, it defers to REST which is a list of branches of the form
(if (eq (car upat) 'pred) (pcase--mark-used sym))
(let* ((splitrest
(pcase--split-rest
- sym (lambda (pat) (pcase--split-pred upat pat)) rest))
+ sym (lambda (pat) (pcase--split-pred vars upat pat)) rest))
(then-rest (car splitrest))
(else-rest (cdr splitrest)))
(pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat)))
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-21 18:34:36 +0000